From dd317947d14e06cb4bc713f53197e194f5e88a65 Mon Sep 17 00:00:00 2001 From: Jessica Meixner Date: Tue, 19 Oct 2021 09:49:17 -0400 Subject: [PATCH] Use CPP instead of Switches (#476) Use CPP ifdefs instead of switches for pre-processing and convert all code from ftn to F90 files. (ftn->src) The tools for converting ftn->src can be found in the model/tools directory. --- .gitignore | 1 + model/.gitignore | 4 +- model/bin/{ad3 => ad3.tmpl} | 83 +- model/bin/ad3_test | 145 - model/bin/all_switches | 4 +- model/bin/cmplr.env | 44 +- model/bin/comp.tmpl | 10 - model/bin/find_switch | 3 +- model/bin/list | 81 - model/bin/ln3 | 84 - model/bin/make_makefile.sh | 12 +- model/bin/w3_automake | 10 +- model/bin/w3_make | 12 +- model/bin/w3_new | 726 +- model/bin/w3_setenv | 1 - model/bin/w3_setup | 89 +- model/ftn/w3gridmd.ftn | 6600 -------------- model/ftn/w3initmd.ftn | 4791 ----------- model/ftn/w3iogrmd.ftn | 1558 ---- model/ftn/w3wavemd.ftn | 3371 -------- .../PDLIB/yowdatapool.F90} | 0 .../PDLIB/yowelementpool.F90} | 0 .../PDLIB/yowerr.ftn => src/PDLIB/yowerr.F90} | 0 .../PDLIB/yowexchangeModule.F90} | 36 +- .../PDLIB/yowfunction.F90} | 188 +- .../PDLIB/yownodepool.F90} | 0 .../PDLIB/yowpd.ftn => src/PDLIB/yowpd.F90} | 0 .../PDLIB/yowpdlibmain.F90} | 52 +- .../PDLIB/yowrankModule.F90} | 0 .../PDLIB/yowsidepool.F90} | 0 model/{ftn => src}/SCRIP/SCRIP.mk | 2 +- model/{ftn => src}/SCRIP/SCRIP_NC.mk | 2 +- model/{ftn => src}/SCRIP/scrip_constants.f | 0 model/{ftn => src}/SCRIP/scrip_errormod.f90 | 0 model/{ftn => src}/SCRIP/scrip_grids.f | 0 .../SCRIP/scrip_interface.F90} | 156 +- model/{ftn => src}/SCRIP/scrip_iounitsmod.f90 | 0 model/{ftn => src}/SCRIP/scrip_kindsmod.f90 | 0 model/{ftn => src}/SCRIP/scrip_netcdfmod.f90 | 0 .../SCRIP/scrip_remap_conservative.f | 0 model/{ftn => src}/SCRIP/scrip_remap_read.f | 0 model/{ftn => src}/SCRIP/scrip_remap_vars.f | 0 model/{ftn => src}/SCRIP/scrip_remap_write.f | 0 model/{ftn => src}/SCRIP/scrip_timers.f | 0 .../{ftn/constants.ftn => src/constants.F90} | 0 model/{ftn/ctest.ftn => src/ctest.F90} | 0 model/{ftn/gx_outf.ftn => src/gx_outf.F90} | 74 +- model/{ftn/gx_outp.ftn => src/gx_outp.F90} | 620 +- model/{ftn => src}/mod_constants.f90 | 0 model/{ftn => src}/mod_fileio.f90 | 0 model/{ftn => src}/mod_xnl4v5.f90 | 0 .../pdlib_field_vec.F90} | 410 +- model/{ftn => src}/serv_xnl4v5.f90 | 0 model/{ftn/w3adatmd.ftn => src/w3adatmd.F90} | 942 +- model/{ftn/w3agcmmd.ftn => src/w3agcmmd.F90} | 0 model/{ftn/w3arrymd.ftn => src/w3arrymd.F90} | 258 +- model/{ftn/w3bullmd.ftn => src/w3bullmd.F90} | 62 +- model/{ftn/w3canomd.ftn => src/w3canomd.F90} | 80 +- model/{ftn/w3cspcmd.ftn => src/w3cspcmd.F90} | 118 +- model/{ftn/w3dispmd.ftn => src/w3dispmd.F90} | 82 +- model/{ftn/w3fld1md.ftn => src/w3fld1md.F90} | 72 +- model/{ftn/w3fld2md.ftn => src/w3fld2md.F90} | 28 +- model/{ftn/w3fldsmd.ftn => src/w3fldsmd.F90} | 872 +- model/{ftn/w3flx1md.ftn => src/w3flx1md.F90} | 12 +- model/{ftn/w3flx2md.ftn => src/w3flx2md.F90} | 12 +- model/{ftn/w3flx3md.ftn => src/w3flx3md.F90} | 12 +- model/{ftn/w3flx4md.ftn => src/w3flx4md.F90} | 12 +- model/{ftn/w3flx5md.ftn => src/w3flx5md.F90} | 12 +- model/{ftn/w3gdatmd.ftn => src/w3gdatmd.F90} | 1936 +++-- model/{ftn => src}/w3getmem.c | 0 model/{ftn/w3gig1md.ftn => src/w3gig1md.F90} | 4 +- model/{ftn/w3gkemd.ftn => src/w3gkemd.F90} | 118 +- model/src/w3gridmd.F90 | 7584 +++++++++++++++++ model/{ftn/w3gsrumd.ftn => src/w3gsrumd.F90} | 412 +- model/{ftn/w3idatmd.ftn => src/w3idatmd.F90} | 306 +- model/{ftn/w3igcmmd.ftn => src/w3igcmmd.F90} | 0 model/src/w3initmd.F90 | 7047 +++++++++++++++ model/{ftn/w3iobcmd.ftn => src/w3iobcmd.F90} | 398 +- model/{ftn/w3iogomd.ftn => src/w3iogomd.F90} | 814 +- model/src/w3iogrmd.F90 | 2002 +++++ model/{ftn/w3iopomd.ftn => src/w3iopomd.F90} | 796 +- model/{ftn/w3iorsmd.ftn => src/w3iorsmd.F90} | 812 +- model/{ftn/w3iosfmd.ftn => src/w3iosfmd.F90} | 206 +- model/{ftn/w3iotrmd.ftn => src/w3iotrmd.F90} | 372 +- model/{ftn => src}/w3macros.h | 0 .../{ftn/w3meminfo.ftn => src/w3meminfo.F90} | 60 +- model/{ftn/w3metamd.ftn => src/w3metamd.F90} | 0 model/{ftn/w3netcdf.ftn => src/w3netcdf.F90} | 522 +- .../w3nmlbouncmd.ftn => src/w3nmlbouncmd.F90} | 36 +- .../w3nmlgridmd.ftn => src/w3nmlgridmd.F90} | 396 +- .../w3nmlmultimd.ftn => src/w3nmlmultimd.F90} | 268 +- .../w3nmlounfmd.ftn => src/w3nmlounfmd.F90} | 84 +- .../w3nmlounpmd.ftn => src/w3nmlounpmd.F90} | 132 +- .../w3nmlprncmd.ftn => src/w3nmlprncmd.F90} | 60 +- .../w3nmlshelmd.ftn => src/w3nmlshelmd.F90} | 188 +- .../w3nmltrncmd.ftn => src/w3nmltrncmd.F90} | 60 +- .../w3nmluprstrmd.F90} | 60 +- model/{ftn/w3oacpmd.ftn => src/w3oacpmd.F90} | 682 +- model/{ftn/w3odatmd.ftn => src/w3odatmd.F90} | 382 +- model/{ftn/w3ogcmmd.ftn => src/w3ogcmmd.F90} | 0 .../w3ounfmetamd.ftn => src/w3ounfmetamd.F90} | 132 +- model/{ftn/w3parall.ftn => src/w3parall.F90} | 694 +- model/{ftn/w3partmd.ftn => src/w3partmd.F90} | 60 +- model/{ftn/w3pro1md.ftn => src/w3pro1md.F90} | 308 +- model/{ftn/w3pro2md.ftn => src/w3pro2md.F90} | 600 +- model/{ftn/w3pro3md.ftn => src/w3pro3md.F90} | 648 +- .../{ftn/w3profsmd.ftn => src/w3profsmd.F90} | 134 +- .../w3profsmd_pdlib.F90} | 2286 +++-- model/{ftn/w3psmcmd.ftn => src/w3psmcmd.F90} | 1034 ++- model/{ftn/w3ref1md.ftn => src/w3ref1md.F90} | 304 +- model/{ftn/w3sbs1md.ftn => src/w3sbs1md.F90} | 36 +- model/{ftn/w3sbt1md.ftn => src/w3sbt1md.F90} | 62 +- model/{ftn/w3sbt4md.ftn => src/w3sbt4md.F90} | 24 +- model/{ftn/w3sbt8md.ftn => src/w3sbt8md.F90} | 12 +- model/{ftn/w3sbt9md.ftn => src/w3sbt9md.F90} | 12 +- model/{ftn/w3sdb1md.ftn => src/w3sdb1md.F90} | 82 +- model/{ftn/w3servmd.ftn => src/w3servmd.F90} | 722 +- model/{ftn/w3sic1md.ftn => src/w3sic1md.F90} | 60 +- model/{ftn/w3sic2md.ftn => src/w3sic2md.F90} | 70 +- model/{ftn/w3sic3md.ftn => src/w3sic3md.F90} | 62 +- model/{ftn/w3sic4md.ftn => src/w3sic4md.F90} | 72 +- model/{ftn/w3sic5md.ftn => src/w3sic5md.F90} | 184 +- model/{ftn/w3sis1md.ftn => src/w3sis1md.F90} | 52 +- model/{ftn/w3sis2md.ftn => src/w3sis2md.F90} | 62 +- model/{ftn/w3sln1md.ftn => src/w3sln1md.F90} | 20 +- model/{ftn/w3smcomd.ftn => src/w3smcomd.F90} | 24 +- model/{ftn/w3snl1md.ftn => src/w3snl1md.F90} | 92 +- model/{ftn/w3snl2md.ftn => src/w3snl2md.F90} | 102 +- model/{ftn/w3snl3md.ftn => src/w3snl3md.F90} | 190 +- model/{ftn/w3snl4md.ftn => src/w3snl4md.F90} | 52 +- model/{ftn/w3snl5md.ftn => src/w3snl5md.F90} | 102 +- model/{ftn/w3snlsmd.ftn => src/w3snlsmd.F90} | 120 +- model/{ftn/w3src0md.ftn => src/w3src0md.F90} | 24 +- model/{ftn/w3src1md.ftn => src/w3src1md.F90} | 152 +- model/{ftn/w3src2md.ftn => src/w3src2md.F90} | 416 +- model/{ftn/w3src3md.ftn => src/w3src3md.F90} | 232 +- model/{ftn/w3src4md.ftn => src/w3src4md.F90} | 266 +- model/{ftn/w3src6md.ftn => src/w3src6md.F90} | 130 +- model/{ftn/w3srcemd.ftn => src/w3srcemd.F90} | 1904 +++-- model/{ftn/w3str1md.ftn => src/w3str1md.F90} | 12 +- model/{ftn/w3str2md.ftn => src/w3str2md.F90} | 12 +- model/{ftn/w3strkmd.ftn => src/w3strkmd.F90} | 904 +- model/{ftn/w3swldmd.ftn => src/w3swldmd.F90} | 28 +- model/{ftn/w3tidemd.ftn => src/w3tidemd.F90} | 52 +- model/{ftn/w3timemd.ftn => src/w3timemd.F90} | 116 +- model/{ftn/w3triamd.ftn => src/w3triamd.F90} | 458 +- model/{ftn/w3uno2md.ftn => src/w3uno2md.F90} | 802 +- model/{ftn/w3uostmd.ftn => src/w3uostmd.F90} | 84 +- model/{ftn/w3updtmd.ftn => src/w3updtmd.F90} | 1578 ++-- model/{ftn/w3uqckmd.ftn => src/w3uqckmd.F90} | 796 +- model/src/w3wavemd.F90 | 4337 ++++++++++ model/{ftn/w3wavset.ftn => src/w3wavset.F90} | 520 +- model/{ftn/w3wdasmd.ftn => src/w3wdasmd.F90} | 98 +- model/{ftn/w3wdatmd.ftn => src/w3wdatmd.F90} | 448 +- model/{ftn/wmesmfmd.ftn => src/wmesmfmd.F90} | 914 +- model/{ftn/wmfinlmd.ftn => src/wmfinlmd.F90} | 72 +- model/{ftn/wmgridmd.ftn => src/wmgridmd.F90} | 2672 +++--- model/{ftn/wminiomd.ftn => src/wminiomd.F90} | 2570 ++++-- model/{ftn/wminitmd.ftn => src/wminitmd.F90} | 1772 ++-- model/{ftn/wmiopomd.ftn => src/wmiopomd.F90} | 770 +- model/{ftn/wmmdatmd.ftn => src/wmmdatmd.F90} | 292 +- model/{ftn/wmscrpmd.ftn => src/wmscrpmd.F90} | 106 +- model/{ftn/wmunitmd.ftn => src/wmunitmd.F90} | 170 +- model/{ftn/wmupdtmd.ftn => src/wmupdtmd.F90} | 604 +- model/{ftn/wmwavemd.ftn => src/wmwavemd.F90} | 1250 ++- .../{ftn/ww3_bounc.ftn => src/ww3_bounc.F90} | 62 +- .../{ftn/ww3_bound.ftn => src/ww3_bound.F90} | 78 +- model/{ftn/ww3_gint.ftn => src/ww3_gint.F90} | 154 +- model/{ftn/ww3_grib.ftn => src/ww3_grib.F90} | 1040 ++- model/{ftn/ww3_grid.ftn => src/ww3_grid.F90} | 0 model/{ftn/ww3_gspl.ftn => src/ww3_gspl.F90} | 640 +- .../{ftn/ww3_multi.ftn => src/ww3_multi.F90} | 64 +- model/{ftn/ww3_ounf.ftn => src/ww3_ounf.F90} | 1808 ++-- model/{ftn/ww3_ounp.ftn => src/ww3_ounp.F90} | 1352 +-- model/{ftn/ww3_outf.ftn => src/ww3_outf.F90} | 296 +- model/{ftn/ww3_outp.ftn => src/ww3_outp.F90} | 1096 ++- model/{ftn/ww3_prep.ftn => src/ww3_prep.F90} | 652 +- model/{ftn/ww3_prnc.ftn => src/ww3_prnc.F90} | 888 +- .../ww3_prtide.ftn => src/ww3_prtide.F90} | 300 +- model/{ftn/ww3_sbs1.ftn => src/ww3_sbs1.F90} | 90 +- model/{ftn/ww3_shel.ftn => src/ww3_shel.F90} | 1556 ++-- model/{ftn/ww3_strt.ftn => src/ww3_strt.F90} | 390 +- .../ww3_systrk.ftn => src/ww3_systrk.F90} | 988 ++- model/{ftn/ww3_trck.ftn => src/ww3_trck.F90} | 12 +- model/{ftn/ww3_trnc.ftn => src/ww3_trnc.F90} | 20 +- .../ww3_uprstr.ftn => src/ww3_uprstr.F90} | 734 +- model/tools/w3adc.f | 625 -- model/tools/w3list.f | 171 - model/tools/w3prnt.f | 219 - model/tools/w3split.f | 960 --- 190 files changed, 55775 insertions(+), 38875 deletions(-) rename model/bin/{ad3 => ad3.tmpl} (82%) delete mode 100755 model/bin/ad3_test delete mode 100755 model/bin/list delete mode 100755 model/bin/ln3 delete mode 100644 model/ftn/w3gridmd.ftn delete mode 100644 model/ftn/w3initmd.ftn delete mode 100644 model/ftn/w3iogrmd.ftn delete mode 100644 model/ftn/w3wavemd.ftn rename model/{ftn/PDLIB/yowdatapool.ftn => src/PDLIB/yowdatapool.F90} (100%) rename model/{ftn/PDLIB/yowelementpool.ftn => src/PDLIB/yowelementpool.F90} (100%) rename model/{ftn/PDLIB/yowerr.ftn => src/PDLIB/yowerr.F90} (100%) rename model/{ftn/PDLIB/yowexchangeModule.ftn => src/PDLIB/yowexchangeModule.F90} (95%) rename model/{ftn/PDLIB/yowfunction.ftn => src/PDLIB/yowfunction.F90} (70%) rename model/{ftn/PDLIB/yownodepool.ftn => src/PDLIB/yownodepool.F90} (100%) rename model/{ftn/PDLIB/yowpd.ftn => src/PDLIB/yowpd.F90} (100%) rename model/{ftn/PDLIB/yowpdlibmain.ftn => src/PDLIB/yowpdlibmain.F90} (98%) rename model/{ftn/PDLIB/yowrankModule.ftn => src/PDLIB/yowrankModule.F90} (100%) rename model/{ftn/PDLIB/yowsidepool.ftn => src/PDLIB/yowsidepool.F90} (100%) rename model/{ftn => src}/SCRIP/SCRIP.mk (96%) rename model/{ftn => src}/SCRIP/SCRIP_NC.mk (97%) rename model/{ftn => src}/SCRIP/scrip_constants.f (100%) rename model/{ftn => src}/SCRIP/scrip_errormod.f90 (100%) rename model/{ftn => src}/SCRIP/scrip_grids.f (100%) rename model/{ftn/SCRIP/scrip_interface.ftn => src/SCRIP/scrip_interface.F90} (88%) rename model/{ftn => src}/SCRIP/scrip_iounitsmod.f90 (100%) rename model/{ftn => src}/SCRIP/scrip_kindsmod.f90 (100%) rename model/{ftn => src}/SCRIP/scrip_netcdfmod.f90 (100%) rename model/{ftn => src}/SCRIP/scrip_remap_conservative.f (100%) rename model/{ftn => src}/SCRIP/scrip_remap_read.f (100%) rename model/{ftn => src}/SCRIP/scrip_remap_vars.f (100%) rename model/{ftn => src}/SCRIP/scrip_remap_write.f (100%) rename model/{ftn => src}/SCRIP/scrip_timers.f (100%) rename model/{ftn/constants.ftn => src/constants.F90} (100%) rename model/{ftn/ctest.ftn => src/ctest.F90} (100%) rename model/{ftn/gx_outf.ftn => src/gx_outf.F90} (97%) rename model/{ftn/gx_outp.ftn => src/gx_outp.F90} (73%) rename model/{ftn => src}/mod_constants.f90 (100%) rename model/{ftn => src}/mod_fileio.f90 (100%) rename model/{ftn => src}/mod_xnl4v5.f90 (100%) rename model/{ftn/pdlib_field_vec.ftn => src/pdlib_field_vec.F90} (87%) rename model/{ftn => src}/serv_xnl4v5.f90 (100%) rename model/{ftn/w3adatmd.ftn => src/w3adatmd.F90} (84%) rename model/{ftn/w3agcmmd.ftn => src/w3agcmmd.F90} (100%) rename model/{ftn/w3arrymd.ftn => src/w3arrymd.F90} (93%) rename model/{ftn/w3bullmd.ftn => src/w3bullmd.F90} (91%) rename model/{ftn/w3canomd.ftn => src/w3canomd.F90} (98%) rename model/{ftn/w3cspcmd.ftn => src/w3cspcmd.F90} (86%) rename model/{ftn/w3dispmd.ftn => src/w3dispmd.F90} (96%) rename model/{ftn/w3fld1md.ftn => src/w3fld1md.F90} (98%) rename model/{ftn/w3fld2md.ftn => src/w3fld2md.F90} (98%) rename model/{ftn/w3fldsmd.ftn => src/w3fldsmd.F90} (81%) rename model/{ftn/w3flx1md.ftn => src/w3flx1md.F90} (96%) rename model/{ftn/w3flx2md.ftn => src/w3flx2md.F90} (97%) rename model/{ftn/w3flx3md.ftn => src/w3flx3md.F90} (97%) rename model/{ftn/w3flx4md.ftn => src/w3flx4md.F90} (97%) rename model/{ftn/w3flx5md.ftn => src/w3flx5md.F90} (97%) rename model/{ftn/w3gdatmd.ftn => src/w3gdatmd.F90} (71%) rename model/{ftn => src}/w3getmem.c (100%) rename model/{ftn/w3gig1md.ftn => src/w3gig1md.F90} (99%) rename model/{ftn/w3gkemd.ftn => src/w3gkemd.F90} (96%) mode change 100755 => 100644 create mode 100644 model/src/w3gridmd.F90 rename model/{ftn/w3gsrumd.ftn => src/w3gsrumd.F90} (97%) rename model/{ftn/w3idatmd.ftn => src/w3idatmd.F90} (83%) rename model/{ftn/w3igcmmd.ftn => src/w3igcmmd.F90} (100%) create mode 100644 model/src/w3initmd.F90 rename model/{ftn/w3iobcmd.ftn => src/w3iobcmd.F90} (72%) rename model/{ftn/w3iogomd.ftn => src/w3iogomd.F90} (90%) create mode 100644 model/src/w3iogrmd.F90 rename model/{ftn/w3iopomd.ftn => src/w3iopomd.F90} (70%) rename model/{ftn/w3iorsmd.ftn => src/w3iorsmd.F90} (73%) rename model/{ftn/w3iosfmd.ftn => src/w3iosfmd.F90} (83%) rename model/{ftn/w3iotrmd.ftn => src/w3iotrmd.F90} (76%) rename model/{ftn => src}/w3macros.h (100%) rename model/{ftn/w3meminfo.ftn => src/w3meminfo.F90} (94%) rename model/{ftn/w3metamd.ftn => src/w3metamd.F90} (100%) rename model/{ftn/w3netcdf.ftn => src/w3netcdf.F90} (89%) rename model/{ftn/w3nmlbouncmd.ftn => src/w3nmlbouncmd.F90} (93%) rename model/{ftn/w3nmlgridmd.ftn => src/w3nmlgridmd.F90} (94%) rename model/{ftn/w3nmlmultimd.ftn => src/w3nmlmultimd.F90} (92%) rename model/{ftn/w3nmlounfmd.ftn => src/w3nmlounfmd.F90} (93%) rename model/{ftn/w3nmlounpmd.ftn => src/w3nmlounpmd.F90} (93%) rename model/{ftn/w3nmlprncmd.ftn => src/w3nmlprncmd.F90} (94%) rename model/{ftn/w3nmlshelmd.ftn => src/w3nmlshelmd.F90} (92%) rename model/{ftn/w3nmltrncmd.ftn => src/w3nmltrncmd.F90} (93%) rename model/{ftn/w3nmluprstrmd.ftn => src/w3nmluprstrmd.F90} (93%) rename model/{ftn/w3oacpmd.ftn => src/w3oacpmd.F90} (72%) rename model/{ftn/w3odatmd.ftn => src/w3odatmd.F90} (90%) rename model/{ftn/w3ogcmmd.ftn => src/w3ogcmmd.F90} (100%) rename model/{ftn/w3ounfmetamd.ftn => src/w3ounfmetamd.F90} (98%) rename model/{ftn/w3parall.ftn => src/w3parall.F90} (77%) rename model/{ftn/w3partmd.ftn => src/w3partmd.F90} (98%) rename model/{ftn/w3pro1md.ftn => src/w3pro1md.F90} (85%) rename model/{ftn/w3pro2md.ftn => src/w3pro2md.F90} (79%) rename model/{ftn/w3pro3md.ftn => src/w3pro3md.F90} (81%) rename model/{ftn/w3profsmd.ftn => src/w3profsmd.F90} (98%) rename model/{ftn/w3profsmd_pdlib.ftn => src/w3profsmd_pdlib.F90} (84%) rename model/{ftn/w3psmcmd.ftn => src/w3psmcmd.F90} (87%) rename model/{ftn/w3ref1md.ftn => src/w3ref1md.F90} (74%) rename model/{ftn/w3sbs1md.ftn => src/w3sbs1md.F90} (97%) rename model/{ftn/w3sbt1md.ftn => src/w3sbt1md.F90} (86%) rename model/{ftn/w3sbt4md.ftn => src/w3sbt4md.F90} (98%) rename model/{ftn/w3sbt8md.ftn => src/w3sbt8md.F90} (98%) rename model/{ftn/w3sbt9md.ftn => src/w3sbt9md.F90} (99%) rename model/{ftn/w3sdb1md.ftn => src/w3sdb1md.F90} (86%) rename model/{ftn/w3servmd.ftn => src/w3servmd.F90} (84%) rename model/{ftn/w3sic1md.ftn => src/w3sic1md.F90} (91%) rename model/{ftn/w3sic2md.ftn => src/w3sic2md.F90} (93%) rename model/{ftn/w3sic3md.ftn => src/w3sic3md.F90} (99%) rename model/{ftn/w3sic4md.ftn => src/w3sic4md.F90} (94%) rename model/{ftn/w3sic5md.ftn => src/w3sic5md.F90} (96%) rename model/{ftn/w3sis1md.ftn => src/w3sis1md.F90} (87%) rename model/{ftn/w3sis2md.ftn => src/w3sis2md.F90} (98%) rename model/{ftn/w3sln1md.ftn => src/w3sln1md.F90} (95%) rename model/{ftn/w3smcomd.ftn => src/w3smcomd.F90} (98%) rename model/{ftn/w3snl1md.ftn => src/w3snl1md.F90} (94%) rename model/{ftn/w3snl2md.ftn => src/w3snl2md.F90} (83%) rename model/{ftn/w3snl3md.ftn => src/w3snl3md.F90} (92%) rename model/{ftn/w3snl4md.ftn => src/w3snl4md.F90} (99%) rename model/{ftn/w3snl5md.ftn => src/w3snl5md.F90} (93%) mode change 100755 => 100644 rename model/{ftn/w3snlsmd.ftn => src/w3snlsmd.F90} (92%) rename model/{ftn/w3src0md.ftn => src/w3src0md.F90} (94%) rename model/{ftn/w3src1md.ftn => src/w3src1md.F90} (85%) rename model/{ftn/w3src2md.ftn => src/w3src2md.F90} (79%) rename model/{ftn/w3src3md.ftn => src/w3src3md.F90} (90%) rename model/{ftn/w3src4md.ftn => src/w3src4md.F90} (94%) rename model/{ftn/w3src6md.ftn => src/w3src6md.F90} (94%) rename model/{ftn/w3srcemd.ftn => src/w3srcemd.F90} (54%) rename model/{ftn/w3str1md.ftn => src/w3str1md.F90} (99%) rename model/{ftn/w3str2md.ftn => src/w3str2md.F90} (98%) rename model/{ftn/w3strkmd.ftn => src/w3strkmd.F90} (90%) rename model/{ftn/w3swldmd.ftn => src/w3swldmd.F90} (97%) rename model/{ftn/w3tidemd.ftn => src/w3tidemd.F90} (99%) rename model/{ftn/w3timemd.ftn => src/w3timemd.F90} (97%) rename model/{ftn/w3triamd.ftn => src/w3triamd.F90} (91%) rename model/{ftn/w3uno2md.ftn => src/w3uno2md.F90} (59%) rename model/{ftn/w3uostmd.ftn => src/w3uostmd.F90} (96%) rename model/{ftn/w3updtmd.ftn => src/w3updtmd.F90} (72%) rename model/{ftn/w3uqckmd.ftn => src/w3uqckmd.F90} (63%) create mode 100644 model/src/w3wavemd.F90 rename model/{ftn/w3wavset.ftn => src/w3wavset.F90} (90%) rename model/{ftn/w3wdasmd.ftn => src/w3wdasmd.F90} (80%) rename model/{ftn/w3wdatmd.ftn => src/w3wdatmd.F90} (72%) rename model/{ftn/wmesmfmd.ftn => src/wmesmfmd.F90} (93%) rename model/{ftn/wmfinlmd.ftn => src/wmfinlmd.F90} (83%) rename model/{ftn/wmgridmd.ftn => src/wmgridmd.F90} (76%) rename model/{ftn/wminiomd.ftn => src/wminiomd.F90} (52%) rename model/{ftn/wminitmd.ftn => src/wminitmd.F90} (84%) rename model/{ftn/wmiopomd.ftn => src/wmiopomd.F90} (61%) rename model/{ftn/wmmdatmd.ftn => src/wmmdatmd.F90} (88%) rename model/{ftn/wmscrpmd.ftn => src/wmscrpmd.F90} (95%) rename model/{ftn/wmunitmd.ftn => src/wmunitmd.F90} (88%) rename model/{ftn/wmupdtmd.ftn => src/wmupdtmd.F90} (87%) rename model/{ftn/wmwavemd.ftn => src/wmwavemd.F90} (66%) rename model/{ftn/ww3_bounc.ftn => src/ww3_bounc.F90} (96%) rename model/{ftn/ww3_bound.ftn => src/ww3_bound.F90} (94%) rename model/{ftn/ww3_gint.ftn => src/ww3_gint.F90} (97%) rename model/{ftn/ww3_grib.ftn => src/ww3_grib.F90} (67%) rename model/{ftn/ww3_grid.ftn => src/ww3_grid.F90} (100%) rename model/{ftn/ww3_gspl.ftn => src/ww3_gspl.F90} (88%) rename model/{ftn/ww3_multi.ftn => src/ww3_multi.F90} (82%) rename model/{ftn/ww3_ounf.ftn => src/ww3_ounf.F90} (72%) rename model/{ftn/ww3_ounp.ftn => src/ww3_ounp.F90} (88%) rename model/{ftn/ww3_outf.ftn => src/ww3_outf.F90} (93%) rename model/{ftn/ww3_outp.ftn => src/ww3_outp.F90} (80%) rename model/{ftn/ww3_prep.ftn => src/ww3_prep.F90} (81%) rename model/{ftn/ww3_prnc.ftn => src/ww3_prnc.F90} (82%) rename model/{ftn/ww3_prtide.ftn => src/ww3_prtide.F90} (82%) rename model/{ftn/ww3_sbs1.ftn => src/ww3_sbs1.F90} (92%) rename model/{ftn/ww3_shel.ftn => src/ww3_shel.F90} (72%) rename model/{ftn/ww3_strt.ftn => src/ww3_strt.F90} (80%) rename model/{ftn/ww3_systrk.ftn => src/ww3_systrk.F90} (60%) rename model/{ftn/ww3_trck.ftn => src/ww3_trck.F90} (98%) rename model/{ftn/ww3_trnc.ftn => src/ww3_trnc.F90} (99%) rename model/{ftn/ww3_uprstr.ftn => src/ww3_uprstr.F90} (79%) delete mode 100644 model/tools/w3adc.f delete mode 100644 model/tools/w3list.f delete mode 100644 model/tools/w3prnt.f delete mode 100644 model/tools/w3split.f diff --git a/.gitignore b/.gitignore index 5ae0eebaf..e627e4845 100644 --- a/.gitignore +++ b/.gitignore @@ -114,6 +114,7 @@ regtests/output *~ model/bin/comp model/bin/link +model/bin/ad3 model/bin/switch model/bin/switch.old model/bin/switch.old_DIST diff --git a/model/.gitignore b/model/.gitignore index 99678d7c1..62e54c218 100644 --- a/model/.gitignore +++ b/model/.gitignore @@ -12,5 +12,5 @@ tmp_* work* nuopc*.mk tools/makefile -ftn/makefile -ftn/makefile_* +src/makefile +src/makefile_* diff --git a/model/bin/ad3 b/model/bin/ad3.tmpl similarity index 82% rename from model/bin/ad3 rename to model/bin/ad3.tmpl index 2c3c8043a..e3cb7f616 100755 --- a/model/bin/ad3 +++ b/model/bin/ad3.tmpl @@ -1,12 +1,12 @@ #!/bin/bash # --------------------------------------------------------------------------- # -# ad3 : Run fortran preprocessor w3adc of WAVEWATCH III on for a single # +# ad3 : Run fortran CPP preprocessor on a single WAVEWATCH III # # source code file. Switches are set in the file 'switch', which # # has to be in the "bin" directory. After the preprocessing the code # # is compiled using the script comp in the "bin" directory. # # # # use : ad3 basename [itest [icomp]] # -# basename: name of source code file without the '.ftn' extension. # +# basename: name of source code file without the '.F90' extension. # # file with .f or .f90 extension is not preprocessed. # # file with .c extension uses standard cc compiler. # # itest : test output switch. # @@ -23,7 +23,6 @@ # 5 : compiler error. # # # # programs used : # -# w3adc : executable of proprocessing program. # # comp : compiler script. # # # # remarks : # @@ -32,10 +31,7 @@ # - The main WAVEWATCH directory ($main_dir) is obtained from the setup # # file $ww3_env, as is the scratch directory ($temp_dir). The following # # directories are used : # -# $main_dir/ftn : Raw FORTRAN file ($basename.ftn). If extension is # -# not .ftn, w3adc will be skipped. if the extension is # -# .c, then the simple cc compiler is used. The latter # -# is now used for profiling code only. # +# $main_dir/src : Raw FORTRAN file ($basename.F90). # # $main_dir/bin : File with preprocessor switches 'switch', and # # compiler script 'comp'. # # $main_dir/obj : Final object modules ($basename.o). # @@ -43,9 +39,6 @@ # # # The following temporary files (in $temp_dir) are used and are removed # # only if the corresponding step of ad3 is ompleted successfully : # -# w3adc.inp : input file for w3adc. # -# w3adc.out : output file for w3adc. # -# w3adc.err : eror file for w3adc. # # comp.out : input file for comp. # # comp.err : eror file for comp. # # comp.stat : status file of compiler, containing number of errors # @@ -104,12 +97,11 @@ source=$WWATCH3_SOURCE list=$WWATCH3_LIST - # 1.d Set up paths etc. - - - - - - - - - - - - - - - - - - - - - - - - - - - path_b="$main_dir/bin" path_w="$( cd $temp_dir && pwd )" - path_i="$main_dir/ftn" + path_i="$main_dir/src" path_o="$main_dir/obj" path_m="$main_dir/mod" path_e="$main_dir/exe" @@ -141,7 +133,7 @@ # 1.e Test necessity of running w3adc - - - - - - - - - - - - - - - - - - - - - if [ -f $path_i/$name.ftn ] + if [ -f $path_i/$name.F90 ] then w3adc='yes' idstr= @@ -200,7 +192,6 @@ cd $path_w rm -f $name.$fext rm -f $name.l - ln -s $main_dir/bin/w3list . 2> /dev/null # --------------------------------------------------------------------------- # # 2. Run w3adc # @@ -210,73 +201,31 @@ if [ "$w3adc" = 'yes' ] then - echo "0 $compress" > w3adc.inp.$name - echo "'$path_i/$name.ftn' '$name.$fext'" >> w3adc.inp.$name - echo "'$sw_str'" >> w3adc.inp.$name - -# 2.b Add NCEP/NCO docmentation - - - - - - - - - - - - - - - - - - - - - - - - -# Obsolete feature, removed +# 2.b Run CPP preprocessor - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -# 2.b Run w3adc - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + #Generate list of CPP Flags based on switches: + CPPFLAGS=() + for sw in $sw_str + do + CPPFLAGS+=("-DW3_$sw") + done - if [ "$itst" != '0' ] - then - echo '-- input file w3adc.inp -------------------------------------------' - cat w3adc.inp.$name - echo '-- end of file ----------------------------------------------------' - fi + CPPFLAGS+=("-D__WW3_SWITCHES__='$sw_str'") - $path_b/w3adc < w3adc.inp.$name > w3adc.out.$name 2> w3adc.err.$name + "${CPPFLAGS[@]}" $path_i/$name.F90 $name.F90 + mv $name.i $name.F90 # 2.c Test the output of w3adc - - - - - - - - - - - - - - - - - - - - - - - - - ad3_tst="`grep ERROR w3adc.out.$name`" - if [ -n "$ad3_tst" ] - then - echo ' *** w3adc error ***' - echo " $ad3_tst" ; exit 4 - fi - if [ ! -f $name.$fext ] then echo ' *** w3adc error ***' - echo " file $name.$fext not found (1)." - cat w3adc.out.$name ; cat w3adc.err.$name ; exit 4 fi if [ "`wc -l $name.$fext | awk '{ print $1}'`" -lt '2' ] then echo ' *** w3adc error ***' echo " file $name.$fext not found (2)." - cat w3adc.out.$name ; cat w3adc.err.$name ; exit 4 - fi - - if [ "$itst" != '0' ] - then - cat w3adc.out.$name - fi - -# 2.d Clean up - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - rm -f w3adc.*.$name - -# 2.e Add switches in w3initmd - - - - - - - - - - - - - - - - - - - - - - - - if [ "$name" = "w3initmd" ] - then - sw_1='' - cp $path_w/w3initmd.$fext $path_w/w3initmd.ft1 - for line in 1 2 3 - do - sw_1=`echo $sw_str | fold -w100 | sed -n "${line}p"` - sw_old="PUT_SW$line" - # echo $line $sw_1 $sw_old - sed -e "s/$sw_old/$sw_1/" $path_w/w3initmd.ft1 > $path_w/w3initmd.ft2 - mv $path_w/w3initmd.ft2 $path_w/w3initmd.ft1 - done - mv $path_w/w3initmd.ft1 $path_w/w3initmd.$fext - echo "'$path_w/$name.fts' '$name.$fext'" >> w3adc.inp fi else @@ -298,7 +247,6 @@ if [ "$icmp" != '0' ] then - rm -f w3list exit 0 fi @@ -420,7 +368,6 @@ then # 3.e process output files - - - - - - - - - - - - - - - - - - - - - - - - - - rm -f $name.o - rm -f w3list if [ "$source" != 'yes' ] then diff --git a/model/bin/ad3_test b/model/bin/ad3_test deleted file mode 100755 index 6ea5e3f2d..000000000 --- a/model/bin/ad3_test +++ /dev/null @@ -1,145 +0,0 @@ -#!/bin/bash -# --------------------------------------------------------------------------- # -# ad3_test : test version of ad3 generating maximum test output for w3adc # -# and skipping compile. # -# # -# Hendrik L. Tolman # -# May 2009 # -# January 2014 # -# # -# Copyright 2009-2014 National Weather Service (NWS), # -# National Oceanic and Atmospheric Administration. All rights # -# reserved. WAVEWATCH III is a trademark of the NWS. # -# No unauthorized use without permission. # -# # -# --------------------------------------------------------------------------- # - - -# --------------------------------------------------------------------------- # -# 1. Preparations # -# --------------------------------------------------------------------------- # -# 1.a Check and process input - - if [ "$#" -gt '3' ] || [ "$#" -lt 1 ] - then - echo "usage: ad3_test basename [itest [icomp]]" 1>&2 ; exit 1 - fi - - name=$1 - if test "$#" -ge '2' - then - itst=$2 - else - itst='0' - fi - -# 1.b Internal variables - - - - - - - - - - - - - - - - - - - - - - - - - - - - - switch="switch" # file containing switches - compress=0 # source code compression par in w3adc - # if not 0, documentaion removed from .f90 file - -# 1.c Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv - main_dir=$WWATCH3_DIR - temp_dir=$WWATCH3_TMP - source=$WWATCH3_SOURCE - list=$WWATCH3_LIST - - -# 1.d Set up paths etc. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - path_b="$main_dir/bin" - path_w="$temp_dir" - path_i="$main_dir/ftn" - path_o="$main_dir/obj" - path_m="$main_dir/mod" - path_e="$main_dir/exe" - if [ -n "`echo $name | grep scrip_ 2>/dev/null`" ] - then - path_i="$path_i/SCRIP" - fi - if [ ${name:0:3} = 'yow' ] - then - path_i="$path_i/PDLIB" - fi - - sw_str=`cat $path_b/$switch` - - if [ ! -d $path_w ] - then - if ! `mkdir $path_w` - then - echo ' *** w3adc error ***' - echo " Cannot create $path_w" - exit 3 - fi - fi - -# 1.e Test necessity of running w3adc - - - - - - - - - - - - - - - - - - - - - - if [ -f $path_i/$name.ftn ] - then - w3adc='yes' - idstr= - else - w3adc='no' - idstr='[no w3adc]' - fi - -# 1.f Output - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - echo "ad3 : processing $name $idstr" - - if [ "$itst" != '0' ] - then - echo ' ' ; echo 'Test output ad3 ' ; echo '----------------' - echo " bin directory : $path_b " - echo " work directory : $path_w " - echo " input directory : $path_i " - echo " object directory : $path_o " - echo " module directory : $path_m " - echo " executable dir. : $path_e " - echo " switches file : $switch " ; echo ' ' - echo " switches : $sw_str" - echo ' ' - fi - -# 1.g Final preparations - - - - - - - - - - - - - - - - - - - - - - - - - - - - - cd $path_w - -# --------------------------------------------------------------------------- # -# 2. Run w3adc # -# --------------------------------------------------------------------------- # -# 2.a Make input file - - if [ "$w3adc" = 'yes' ] - then - - echo "1 $compress" > w3adc.inp.$name - echo "'$path_i/$name.ftn' '$name.f90'" >> w3adc.inp.$name - echo "'$sw_str'" >> w3adc.inp.$name - -# 2.b Add NCEP/NCO docmentation - - - - - - - - - - - - - - - - - - - - - - - - -# Obsolete feature, removed - -# 2.c Run w3adc - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if [ "$itst" != '0' ] - then - echo '-- input file w3adc.inp -------------------------------------------' - cat w3adc.inp.$name - echo '-- end of file ----------------------------------------------------' - fi - - $path_b/w3adc < w3adc.inp.$name - - fi - - rm -f w3adc.inp.$name - rm -f $name.f90 - -# End of ad3 ---------------------------------------------------------------- # diff --git a/model/bin/all_switches b/model/bin/all_switches index e9c56c011..d02d5eb6b 100755 --- a/model/bin/all_switches +++ b/model/bin/all_switches @@ -1,7 +1,7 @@ #!/bin/bash # --------------------------------------------------------------------------- # # all_switches : Make a list of all switches hat are found in the program # -# (.ftn) files of WAVEWATCH III. # +# (.F90) files of WAVEWATCH III. # # # # use : all_switches # # # @@ -38,7 +38,7 @@ # 2. Strip all switches from sources # # --------------------------------------------------------------------------- # - cd $main_dir/ftn + cd $main_dir/src all=`sed -n '/^!\/[[:alpha:]]/'p *.ftn | awk '{print $1}' | \ awk -F'!/' 'BEGIN{OFS="\n"}{$1=$1; print $0}' | \ diff --git a/model/bin/cmplr.env b/model/bin/cmplr.env index d14b3604f..22e8db8fb 100644 --- a/model/bin/cmplr.env +++ b/model/bin/cmplr.env @@ -99,6 +99,14 @@ if [ "$cmplr" == "mpt" ] || [ "$cmplr" == "mpt_debug" ] || [ "$cmplr" == "mpt_pr optl="$optl -xhost" fi + #Flags for CPP: + cppad3procflag='-E' + cppad3flag2=' ' + cppad3flag3='-o' + cppad3flag4='#' + + + fi @@ -200,6 +208,14 @@ if [ "$cmplr" == "intel" ] || [ "$cmplr" == "intel_debug" ] || [ "$c optl='-o $prog -g' fi + + #Flags for CPP: + cppad3procflag='-E' + cppad3flag2=' ' + cppad3flag3='>' + cppad3flag4='#' + + fi ############################### @@ -272,6 +288,13 @@ if [ "$cmplr" == "gnu" ] || [ "$cmplr" == "gnu_debug" ] || [ "$cmplr" == "gnu_pr if [ ! -z "$(echo $cmplr | grep so)" ] ; then optc="$optc -fPIC" fi + + #Flags for CPP: + cppad3procflag='-E' + cppad3flag2=' ' + cppad3flag3='-o' + cppad3flag4='#' + fi ############################### @@ -287,13 +310,6 @@ if [ "$cmplr" == "pgi" ] || [ "$cmplr" == "pgi_debug" ] || [ "$cmplr" == "pgi_pr comp_seq='pgf90' comp_mpi='mpif90' - # Cray compiler - if [ ! -z "$(echo $cmplr | grep wcoss_cray)" ] ; then - comp_seq='ftn' - comp_mpi='ftn' - fi - - # OPTIONS - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # common options @@ -332,6 +348,13 @@ if [ "$cmplr" == "pgi" ] || [ "$cmplr" == "pgi_debug" ] || [ "$cmplr" == "pgi_pr optc="$optc" optl="$optl" fi + + #Flags for CPP: + cppad3procflag='-E' + cppad3flag2=' ' + cppad3flag3='>' + cppad3flag4='#' + fi @@ -384,4 +407,11 @@ if [ "$cmplr" == "ukmo_cray" ] || [ "$cmplr" == "ukmo_cray_debug" ] || \ # system-dependant options # N/A + #Flags for CPP: + cppad3procflag='-eP' + cppad3flag2=' ' + cppad3flag3='#' + cppad3flag4=' ' + + fi diff --git a/model/bin/comp.tmpl b/model/bin/comp.tmpl index feba730e0..6a39bc778 100755 --- a/model/bin/comp.tmpl +++ b/model/bin/comp.tmpl @@ -135,16 +135,6 @@ then mv $name.lst $name.l fi - # listing done by w3list - if [ ! -f $name.l ] - then - echo "w3list $name.$fext" - echo "$name.$fext" > w3list.inp - echo "T" >> w3list.inp - w3list < w3list.inp 2> /dev/null - rm -f w3list.inp - mv w3list.out $name.l - fi # add comp options, warnings and error to listing if [ -s $name.l ] then diff --git a/model/bin/find_switch b/model/bin/find_switch index 82e5b2b23..3ed3a7a04 100755 --- a/model/bin/find_switch +++ b/model/bin/find_switch @@ -48,7 +48,8 @@ # 1.d Raw data file - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - cd $main_dir/ftn +### TO DO: This needs to be improved for CPP transition + cd $main_dir/src grep "$switch" * | sed 's/\:/ /' | awk '{ print $1}' > ../.switch.files # 1.e Output - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/model/bin/list b/model/bin/list deleted file mode 100755 index 462712850..000000000 --- a/model/bin/list +++ /dev/null @@ -1,81 +0,0 @@ -#!/bin/bash -# --------------------------------------------------------------------------- # -# list : Printing of ASCII files (typically source codes) using the # -# program w3print.f This program is provided as a part of # -# WAVEWATCH III and get is printer setup from the file # -# $ww3_env (set in 1.b) in the users home directory. # -# # -# Hendrik L. Tolman # -# May 2009 # -# # -# Copyright 2009 National Weather Service (NWS), # -# National Oceanic and Atmospheric Administration. All rights # -# reserved. WAVEWATCH III is a trademark of the NWS. # -# No unauthorized use without permission. # -# # -# --------------------------------------------------------------------------- # - - -# --------------------------------------------------------------------------- # -# 1. Preparations # -# --------------------------------------------------------------------------- # -# 1.a Check input - - if test "$#" = '0' - then - echo "usage: list filename(s)" 1>&2 ; exit 1 - fi - - input="$*" - dir=`pwd` - -# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv - main_dir=$WWATCH3_DIR - temp_dir=$WWATCH3_TMP - source=$WWATCH3_SOURCE - list=$WWATCH3_LIST - - -# --------------------------------------------------------------------------- # -# 2. Loop over files # -# --------------------------------------------------------------------------- # -# 2.a Loop control - - cd $dir - set $input - - while test "$#" != '0' - do - - if test ! -f $1 - then - echo "file $1 not found" - else - echo "processing $1" - -# 2.b Run w3prnt - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - rm -f w3prnt.out - echo "$1" | $main_dir/bin/w3prnt 2> /dev/null - -# 2.c Spool to printer - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if test -f w3prnt.out - then - if test -z "$printer" - then - lpr w3prnt.out - else - lpr -P $printer w3prnt.out - fi - rm -f w3prnt.out - else - echo "listing not found" - fi - fi - shift - done - -# End of list --------------------------------------------------------------- # diff --git a/model/bin/ln3 b/model/bin/ln3 deleted file mode 100755 index 18bfd16bf..000000000 --- a/model/bin/ln3 +++ /dev/null @@ -1,84 +0,0 @@ -#!/bin/bash -# --------------------------------------------------------------------------- # -# ln3 : Make a link from a source code file of WAVEWATCH III to the work # -# directory. Now also looks in bin directory. # -# # -# Hendrik L. Tolman # -# February 2012 # -# # -# Copyright 2009-2012 National Weather Service (NWS), # -# National Oceanic and Atmospheric Administration. All rights # -# reserved. WAVEWATCH III is a trademark of the NWS. # -# No unauthorized use without permission. # -# # -# --------------------------------------------------------------------------- # - - -# --------------------------------------------------------------------------- # -# 1. Preparations # -# --------------------------------------------------------------------------- # -# 1.a Check input - - if test "$#" -lt '1' - then - echo "usage: ln3 filename(s)" 1>&2 ; exit 1 - fi - files="$*" - -# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv - main_dir=$WWATCH3_DIR - temp_dir=$WWATCH3_TMP - source=$WWATCH3_SOURCE - list=$WWATCH3_LIST - -# --------------------------------------------------------------------------- # -# 2. Make link(s) # -# --------------------------------------------------------------------------- # - - set $files - found='0' - - cd $main_dir/work - - while [ "$#" -ge '1' ] - do - name="$1" - - for file in $name $name.ftn $name.f90 $name.doc \ - w3$name.ftn w3$name.doc w3${name}md.ftn w3${name}md.doc - do - if test -f ../ftn/$file - then - rm -f $file - echo "make link to $file in ftn dir." - ln -s ../ftn/$file . - found=$(($found + 1)) - fi - if test -f ../bin/$file - then - rm -f $file - echo "make link to $file in bin dir." - ln -s ../bin/$file . - found=$(($found + 1)) - fi - if test -f ../test/$file - then - rm -f $file - echo "make link to $file in test dir." - ln -s ../test/$file . - found=$(($found + 1)) - fi - done - - shift - - done - - if test "$found" = '0' - then - echo "No files found." - fi - -# End of list --------------------------------------------------------------- # diff --git a/model/bin/make_makefile.sh b/model/bin/make_makefile.sh index 3ff736efa..8c4653a0c 100755 --- a/model/bin/make_makefile.sh +++ b/model/bin/make_makefile.sh @@ -253,12 +253,12 @@ ispdlibi=no for s in $suffixes do - if [ -f $main_dir/ftn/$file.$s ] + if [ -f $main_dir/src/$file.$s ] then fexti=$s break fi - if [ -f $main_dir/ftn/PDLIB/$file.$s ] + if [ -f $main_dir/src/PDLIB/$file.$s ] then fexti=$s ispdlibi=yes @@ -268,8 +268,8 @@ if [ "$fexti" = 'none' ] then echo ' *** make_makefile.sh error ***' - echo " Source file $main_dir/ftn/$file.* " - echo " or $main_dir/ftn/PDLIB/$file.* not found" + echo " Source file $main_dir/src/$file.* " + echo " or $main_dir/src/PDLIB/$file.* not found" echo " Source file suffixes checked: $suffixes" exit 2 fi @@ -487,7 +487,7 @@ echo '# -----------------' >> makefile echo ' ' >> makefile - scrip_dir=$main_dir/ftn/SCRIP + scrip_dir=$main_dir/src/SCRIP if [ ! -d $scrip_dir ] then echo "*** SCRIP directory $scrip_dir not found ***" @@ -515,6 +515,6 @@ # 4. Move makefile to proper place # # --------------------------------------------------------------------------- # - mv makefile $main_dir/ftn/makefile + mv makefile $main_dir/src/makefile # end of script ------------------------------------------------------------- # diff --git a/model/bin/w3_automake b/model/bin/w3_automake index 7d1d5b117..3233fdb6f 100755 --- a/model/bin/w3_automake +++ b/model/bin/w3_automake @@ -92,12 +92,12 @@ exit 1 fi - # ftn dir - makefile=$main_dir/ftn/makefile - if [ ! -d $main_dir/ftn ] + # src dir + makefile=$main_dir/src/makefile + if [ ! -d $main_dir/src ] then echo ' ' - echo "[ERROR] Directory $main_dir/ftn not found" + echo "[ERROR] Directory $main_dir/src not found" echo ' Please check the content of your directory model' exit 1 fi @@ -359,7 +359,7 @@ fi # clean up ftp - rm -f $main_dir/ftn/makefile + rm -f $main_dir/src/makefile # clean up exe mkdir -p $main_dir/exe diff --git a/model/bin/w3_make b/model/bin/w3_make index 483ad73b0..1fae69e61 100755 --- a/model/bin/w3_make +++ b/model/bin/w3_make @@ -117,12 +117,12 @@ exit 1 fi - # ftn dir - makefile=$main_dir/ftn/makefile - if [ ! -d $main_dir/ftn ] + # src dir + makefile=$main_dir/src/makefile + if [ ! -d $main_dir/src ] then echo ' ' - echo "[ERROR] Directory $main_dir/ftn not found" + echo "[ERROR] Directory $main_dir/src not found" echo ' Please check the content of your directory model' exit 1 fi @@ -385,14 +385,14 @@ EOF then rm -f *.l fi - cd $main_dir/ftn + cd $main_dir/src # 1.j Prepare makefile - - - - - - - - - - - - - - - - - - - - - - - - - - - - make_make='y' if test -f $switch_file_old then - if test -f $main_dir/ftn/makefile && \ + if test -f $main_dir/src/makefile && \ test -z "`diff $switch_file $switch_file_old`" then make_make='n' diff --git a/model/bin/w3_new b/model/bin/w3_new index 99b907837..0143b16f5 100755 --- a/model/bin/w3_new +++ b/model/bin/w3_new @@ -68,371 +68,371 @@ rm -f exe/ww3_* rm -f exe/gx_* rm -f exe/exec_type ;; - 'nco' ) cd $main_dir/ftn ; touch w3bullmd.ftn - touch ww3_prep.ftn - touch ww3_shel.ftn - touch ww3_ounp.ftn - touch ww3_prnc.ftn - touch ww3_outp.ftn - touch ww3_prtide.ftn - touch ww3_grib.ftn ;; - 'grib' ) cd $main_dir/ftn ; touch ww3_grib.ftn ;; - 'netcdf' ) cd $main_dir/ftn ; touch ww3_ounf.ftn - touch ww3_ounp.ftn - touch ww3_bounc.ftn - touch ww3_systrk.ftn - touch ww3_prnc.ftn - touch ww3_trnc.ftn ;; - 'scrip' ) cd $main_dir/ftn ; touch wmgridmd.ftn - touch wmscrpmd.ftn - touch w3gridmd.ftn - cd $main_dir/ftn/SCRIP ; touch scrip_interface.ftn ;; - 'scripnc') cd $main_dir/ftn ; touch wmgridmd.ftn - cd $main_dir/ftn/SCRIP ; touch scrip_interface.ftn ;; - 'trknc' ) cd $main_dir/ftn ; touch ww3_systrk.ftn ;; + 'nco' ) cd $main_dir/src ; touch w3bullmd.F90 + touch ww3_prep.F90 + touch ww3_shel.F90 + touch ww3_ounp.F90 + touch ww3_prnc.F90 + touch ww3_outp.F90 + touch ww3_prtide.F90 + touch ww3_grib.F90 ;; + 'grib' ) cd $main_dir/src ; touch ww3_grib.F90 ;; + 'netcdf' ) cd $main_dir/src ; touch ww3_ounf.F90 + touch ww3_ounp.F90 + touch ww3_bounc.F90 + touch ww3_systrk.F90 + touch ww3_prnc.F90 + touch ww3_trnc.F90 ;; + 'scrip' ) cd $main_dir/src ; touch wmgridmd.F90 + touch wmscrpmd.F90 + touch w3gridmd.F90 + cd $main_dir/src/SCRIP ; touch scrip_interface.F90 ;; + 'scripnc') cd $main_dir/src ; touch wmgridmd.F90 + cd $main_dir/src/SCRIP ; touch scrip_interface.F90 ;; + 'trknc' ) cd $main_dir/src ; touch ww3_systrk.F90 ;; 'shared' ) ;; 'mpp' );; - 'mpiexp' ) cd $main_dir/ftn ; touch wmgridmd.ftn ;; - 'thread' ) cd $main_dir/ftn ; touch w3wavemd.ftn - touch w3canomd.ftn - touch w3fld1md.ftn - touch w3fld2md.ftn - touch w3iogomd.ftn - touch w3pro1md.ftn - touch w3pro2md.ftn - touch w3pro3md.ftn - touch w3psmcmd.ftn - touch w3srcemd.ftn - touch w3pro1md.ftn - touch w3pro2md.ftn - touch w3pro3md.ftn - touch w3updtmd.ftn - touch wmgridmd.ftn - touch w3uno2md.ftn - touch w3updtmd.ftn - touch w3uqckmd.ftn - touch w3iogomd.ftn - touch ww3_multi.ftn - touch ww3_shel.ftn ;; - 'GSE' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3adatmd.ftn - touch w3idatmd.ftn - touch w3iogrmd.ftn - touch w3updtmd.ftn - touch w3wavemd.ftn - touch w3triamd.ftn - touch wmgridmd.ftn - touch ww3_gspl.ftn - touch ww3_shel.ftn - touch w3gridmd.ftn ;; - 'prop' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3adatmd.ftn - touch w3idatmd.ftn - touch w3iogrmd.ftn - touch w3wavemd.ftn - touch w3pro2md.ftn - touch w3pro3md.ftn - touch wmgridmd.ftn - touch w3updtmd.ftn - touch ww3_shel.ftn - touch w3gridmd.ftn - touch ww3_gspl.ftn ;; - 'stress' ) cd $main_dir/ftn ; touch w3srcemd.ftn - touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch w3gridmd.ftn - touch gx_outp.ftn ;; - 'dstress') cd $main_dir/ftn ; touch w3srcemd.ftn - touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch w3fld1md.ftn - touch w3fld2md.ftn - touch w3gridmd.ftn ;; - 's_ln' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3iorsmd.ftn - touch w3adatmd.ftn - touch w3iogrmd.ftn - touch wminitmd.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch ww3_prep.ftn - touch ww3_prnc.ftn - touch ww3_prtide.ftn - touch ww3_strt.ftn - touch gx_outp.ftn ;; - 'sterm' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3flx1md.ftn - touch w3flx2md.ftn - touch w3flx3md.ftn - touch w3updtmd.ftn - touch w3iogrmd.ftn - touch w3iogomd.ftn - touch w3updtmd.ftn - touch wmesmfmd.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch ww3_ounf.ftn - touch gx_outp.ftn ;; - 'stab' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch w3src3md.ftn - touch w3src4md.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch gx_outp.ftn ;; - 's_nl' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3adatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch wminitmd.ftn - touch w3gridmd.ftn - touch ww3_prep.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch ww3_prnc.ftn - touch ww3_strt.ftn - touch ww3_prtide.ftn - touch gx_outp.ftn ;; - 'snls' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch gx_outp.ftn ;; - 's_bot' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3odatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3iogomd.ftn - touch w3profsmd_pdlib.ftn - touch w3sic4md.ftn - touch w3wavemd.ftn - touch w3gridmd.ftn - touch ww3_gint.ftn - touch ww3_outp.ftn - touch ww3_outf.ftn - touch ww3_ounp.ftn - touch ww3_ounf.ftn - touch ww3_shel.ftn - touch gx_outp.ftn ;; - 's_db' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3profsmd_pdlib.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch gx_outp.ftn ;; - 'miche' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3gridmd.ftn ;; - 's_tr' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3profsmd_pdlib.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch gx_outp.ftn ;; - 's_bs' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3profsmd_pdlib.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch gx_outp.ftn ;; - 's_ice' ) cd $main_dir/ftn ; touch w3iogrmd.ftn - touch w3gdatmd.ftn - touch w3adatmd.ftn - touch w3profsmd_pdlib.ftn - touch w3updtmd.ftn - touch w3wavemd.ftn - touch w3srcemd.ftn - touch w3gridmd.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch ww3_shel.ftn - touch gx_outp.ftn ;; - 's_is' ) cd $main_dir/ftn ; touch w3srcemd.ftn - touch w3iogrmd.ftn - touch w3gdatmd.ftn - touch w3iogomd.ftn - touch w3odatmd.ftn - touch w3sic2md.ftn - touch w3wavemd.ftn - touch ww3_gint.ftn - touch w3gridmd.ftn - touch ww3_ounf.ftn - touch ww3_outf.ftn - touch ww3_shel.ftn - touch ww3_outp.ftn - touch ww3_ounp.ftn - touch gx_outf.ftn - touch gx_outp.ftn ;; -'reflection' )cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch w3iorsmd.ftn - touch w3profsmd.ftn - touch w3profsmd_pdlib.ftn - touch w3srcemd.ftn - touch w3triamd.ftn - touch w3updtmd.ftn - touch w3wavemd.ftn - touch w3gridmd.ftn ;; - 'wind' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch ww3_prnc.ftn - touch ww3_prep.ftn ;; - 'windx' ) cd $main_dir/ftn ; touch wmupdtmd.ftn ;; - 'rwind' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch w3gridmd.ftn ;; - 'wcor' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch w3gridmd.ftn ;; - 'rstwind') cd $main_dir/ftn ; touch wmesmfmd.ftn - touch w3idatmd.ftn - touch w3iorsmd.ftn ;; - 'curr' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch ww3_prnc.ftn - touch ww3_prep.ftn ;; - 'currx' ) cd $main_dir/ftn ; touch wmupdtmd.ftn ;; - 'mgwind' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch wminitmd.ftn - touch ww3_shel.ftn ;; - 'mgprop' ) cd $main_dir/ftn ; touch w3pro1md.ftn - touch w3pro2md.ftn - touch w3pro3md.ftn - touch w3profsmd.ftn - touch w3profsmd_pdlib.ftn - touch w3psmcmd.ftn - touch wminitmd.ftn - touch ww3_shel.ftn ;; - 'mggse' ) cd $main_dir/ftn ; touch w3pro3md.ftn - touch w3gridmd.ftn - touch ww3_shel.ftn ;; - 'subsec' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3iogrmd.ftn - touch w3wavemd.ftn - touch w3gridmd.ftn ;; - 'tdyn' ) cd $main_dir/ftn ; touch w3pro2md.ftn - touch w3psmcmd.ftn ;; - 'dss0' ) cd $main_dir/ftn ; touch w3pro2md.ftn - touch w3psmcmd.ftn ;; - 'pdif' ) cd $main_dir/ftn ; touch w3pro2md.ftn - touch w3psmcmd.ftn ;; - 'tide' ) cd $main_dir/ftn ; touch w3updtmd.ftn - touch w3idatmd.ftn - touch w3fldsmd.ftn - touch ww3_prnc.ftn - touch ww3_shel.ftn ;; - 'refrx' ) cd $main_dir/ftn ; touch w3wavemd.ftn - touch w3parall.ftn - touch w3pro1md.ftn - touch w3pro2md.ftn - touch w3pro3md.ftn ;; - 'ig' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3iogomd.ftn - touch w3iogrmd.ftn - touch w3ref1md.ftn - touch w3src4md.ftn - touch w3srcemd.ftn - touch w3gridmd.ftn - touch ww3_ounp.ftn - touch ww3_outp.ftn ;; - 'rotag' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3iobcmd.ftn - touch w3iogomd.ftn - touch w3iogrmd.ftn - touch w3iopomd.ftn - touch w3updtmd.ftn - touch ww3_grib.ftn - touch ww3_ounf.ftn - touch ww3_ounp.ftn - touch ww3_outf.ftn - touch w3gridmd.ftn ;; - 'nnt' ) cd $main_dir/ftn ; touch w3srcemd.ftn ;; - 'mprf' ) cd $main_dir/ftn ; touch wmmdatmd.ftn - touch wminitmd.ftn - touch wmwavemd.ftn - touch wmfinlmd.ftn ;; - 'cou' ) cd $main_dir/ftn ; touch w3iogomd.ftn - touch w3nmlmultimd.ftn - touch w3nmlshelmd.ftn - touch w3wavemd.ftn - touch wminitmd.ftn - touch ww3_shel.ftn ;; - 'oasis' ) cd $main_dir/ftn ; touch w3oacpmd.ftn - touch w3fldsmd.ftn - touch w3wavemd.ftn - touch w3wdatmd.ftn - touch ww3_shel.ftn ;; - 'agcm' ) cd $main_dir/ftn ; touch w3agcmmd.ftn - touch w3fldsmd.ftn - touch w3iogomd.ftn - touch w3oacpmd.ftn - touch w3wavemd.ftn - touch ww3_shel.ftn ;; - 'ogcm' ) cd $main_dir/ftn ; touch w3ogcmmd.ftn - touch w3fldsmd.ftn - touch w3iogomd.ftn - touch w3oacpmd.ftn - touch w3updtmd.ftn - touch w3wavemd.ftn - touch ww3_shel.ftn ;; - 'igcm' ) cd $main_dir/ftn ; touch w3igcmmd.ftn - touch w3fldsmd.ftn - touch w3oacpmd.ftn - touch w3wavemd.ftn - touch ww3_shel.ftn ;; - 'setup' ) cd $main_dir/ftn ; touch w3initmd.ftn - touch w3iogomd.ftn - touch w3iopomd.ftn - touch w3netcdf.ftn - touch w3odatmd.ftn - touch w3updtmd.ftn - touch w3wavemd.ftn - touch w3wdatmd.ftn - touch ww3_ounf.ftn - touch ww3_ounp.ftn;; - 'pdlib' ) cd $main_dir/ftn ; touch w3adatmd.ftn - touch w3gdatmd.ftn - touch w3initmd.ftn - touch w3iorsmd.ftn - touch w3netcdf.ftn - touch w3parall.ftn - touch w3srcemd.ftn - touch w3triamd.ftn - touch w3wavemd.ftn - touch w3wdatmd.ftn - touch wminiomd.ftn - touch wmmdatmd.ftn - touch ww3_shel.ftn ;; - 'memck' ) cd $main_dir/ftn ; touch w3adatmd.ftn - touch w3gdatmd.ftn - touch w3initmd.ftn - touch w3iogrmd.ftn - touch w3profsmd_pdlib.ftn - touch w3wavemd.ftn - touch ww3_shel.ftn ;; - 'uost' ) cd $main_dir/ftn ; touch w3gdatmd.ftn - touch w3initmd.ftn - touch w3iogrmd.ftn - touch w3srcemd.ftn - touch w3wavemd.ftn - touch ww3_grid.ftn ;; - 'smcg' ) cd $main_dir/ftn ; touch w3psmcmd.ftn - touch w3smcomd.ftn ;; - 'b4b' ) cd $main_dir/ftn ; touch w3psmcmd.ftn ;; + 'mpiexp' ) cd $main_dir/src ; touch wmgridmd.F90 ;; + 'thread' ) cd $main_dir/src ; touch w3wavemd.F90 + touch w3canomd.F90 + touch w3fld1md.F90 + touch w3fld2md.F90 + touch w3iogomd.F90 + touch w3pro1md.F90 + touch w3pro2md.F90 + touch w3pro3md.F90 + touch w3psmcmd.F90 + touch w3srcemd.F90 + touch w3pro1md.F90 + touch w3pro2md.F90 + touch w3pro3md.F90 + touch w3updtmd.F90 + touch wmgridmd.F90 + touch w3uno2md.F90 + touch w3updtmd.F90 + touch w3uqckmd.F90 + touch w3iogomd.F90 + touch ww3_multi.F90 + touch ww3_shel.F90 ;; + 'GSE' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3adatmd.F90 + touch w3idatmd.F90 + touch w3iogrmd.F90 + touch w3updtmd.F90 + touch w3wavemd.F90 + touch w3triamd.F90 + touch wmgridmd.F90 + touch ww3_gspl.F90 + touch ww3_shel.F90 + touch w3gridmd.F90 ;; + 'prop' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3adatmd.F90 + touch w3idatmd.F90 + touch w3iogrmd.F90 + touch w3wavemd.F90 + touch w3pro2md.F90 + touch w3pro3md.F90 + touch wmgridmd.F90 + touch w3updtmd.F90 + touch ww3_shel.F90 + touch w3gridmd.F90 + touch ww3_gspl.F90 ;; + 'stress' ) cd $main_dir/src ; touch w3srcemd.F90 + touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch w3gridmd.F90 + touch gx_outp.F90 ;; + 'dstress') cd $main_dir/src ; touch w3srcemd.F90 + touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch w3fld1md.F90 + touch w3fld2md.F90 + touch w3gridmd.F90 ;; + 's_ln' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3iorsmd.F90 + touch w3adatmd.F90 + touch w3iogrmd.F90 + touch wminitmd.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch ww3_prep.F90 + touch ww3_prnc.F90 + touch ww3_prtide.F90 + touch ww3_strt.F90 + touch gx_outp.F90 ;; + 'sterm' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3flx1md.F90 + touch w3flx2md.F90 + touch w3flx3md.F90 + touch w3updtmd.F90 + touch w3iogrmd.F90 + touch w3iogomd.F90 + touch w3updtmd.F90 + touch wmesmfmd.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch ww3_ounf.F90 + touch gx_outp.F90 ;; + 'stab' ) cd $main_dir/src ; touch w3updtmd.F90 + touch w3src3md.F90 + touch w3src4md.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch gx_outp.F90 ;; + 's_nl' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3adatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch wminitmd.F90 + touch w3gridmd.F90 + touch ww3_prep.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch ww3_prnc.F90 + touch ww3_strt.F90 + touch ww3_prtide.F90 + touch gx_outp.F90 ;; + 'snls' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch gx_outp.F90 ;; + 's_bot' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3odatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3iogomd.F90 + touch w3profsmd_pdlib.F90 + touch w3sic4md.F90 + touch w3wavemd.F90 + touch w3gridmd.F90 + touch ww3_gint.F90 + touch ww3_outp.F90 + touch ww3_outf.F90 + touch ww3_ounp.F90 + touch ww3_ounf.F90 + touch ww3_shel.F90 + touch gx_outp.F90 ;; + 's_db' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3profsmd_pdlib.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch gx_outp.F90 ;; + 'miche' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3gridmd.F90 ;; + 's_tr' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3profsmd_pdlib.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch gx_outp.F90 ;; + 's_bs' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3profsmd_pdlib.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch gx_outp.F90 ;; + 's_ice' ) cd $main_dir/src ; touch w3iogrmd.F90 + touch w3gdatmd.F90 + touch w3adatmd.F90 + touch w3profsmd_pdlib.F90 + touch w3updtmd.F90 + touch w3wavemd.F90 + touch w3srcemd.F90 + touch w3gridmd.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch ww3_shel.F90 + touch gx_outp.F90 ;; + 's_is' ) cd $main_dir/src ; touch w3srcemd.F90 + touch w3iogrmd.F90 + touch w3gdatmd.F90 + touch w3iogomd.F90 + touch w3odatmd.F90 + touch w3sic2md.F90 + touch w3wavemd.F90 + touch ww3_gint.F90 + touch w3gridmd.F90 + touch ww3_ounf.F90 + touch ww3_outf.F90 + touch ww3_shel.F90 + touch ww3_outp.F90 + touch ww3_ounp.F90 + touch gx_outf.F90 + touch gx_outp.F90 ;; +'reflection' )cd $main_dir/src ; touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch w3iorsmd.F90 + touch w3profsmd.F90 + touch w3profsmd_pdlib.F90 + touch w3srcemd.F90 + touch w3triamd.F90 + touch w3updtmd.F90 + touch w3wavemd.F90 + touch w3gridmd.F90 ;; + 'wind' ) cd $main_dir/src ; touch w3updtmd.F90 + touch ww3_prnc.F90 + touch ww3_prep.F90 ;; + 'windx' ) cd $main_dir/src ; touch wmupdtmd.F90 ;; + 'rwind' ) cd $main_dir/src ; touch w3updtmd.F90 + touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch w3gridmd.F90 ;; + 'wcor' ) cd $main_dir/src ; touch w3updtmd.F90 + touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch w3gridmd.F90 ;; + 'rstwind') cd $main_dir/src ; touch wmesmfmd.F90 + touch w3idatmd.F90 + touch w3iorsmd.F90 ;; + 'curr' ) cd $main_dir/src ; touch w3updtmd.F90 + touch ww3_prnc.F90 + touch ww3_prep.F90 ;; + 'currx' ) cd $main_dir/src ; touch wmupdtmd.F90 ;; + 'mgwind' ) cd $main_dir/src ; touch w3updtmd.F90 + touch wminitmd.F90 + touch ww3_shel.F90 ;; + 'mgprop' ) cd $main_dir/src ; touch w3pro1md.F90 + touch w3pro2md.F90 + touch w3pro3md.F90 + touch w3profsmd.F90 + touch w3profsmd_pdlib.F90 + touch w3psmcmd.F90 + touch wminitmd.F90 + touch ww3_shel.F90 ;; + 'mggse' ) cd $main_dir/src ; touch w3pro3md.F90 + touch w3gridmd.F90 + touch ww3_shel.F90 ;; + 'subsec' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3iogrmd.F90 + touch w3wavemd.F90 + touch w3gridmd.F90 ;; + 'tdyn' ) cd $main_dir/src ; touch w3pro2md.F90 + touch w3psmcmd.F90 ;; + 'dss0' ) cd $main_dir/src ; touch w3pro2md.F90 + touch w3psmcmd.F90 ;; + 'pdif' ) cd $main_dir/src ; touch w3pro2md.F90 + touch w3psmcmd.F90 ;; + 'tide' ) cd $main_dir/src ; touch w3updtmd.F90 + touch w3idatmd.F90 + touch w3fldsmd.F90 + touch ww3_prnc.F90 + touch ww3_shel.F90 ;; + 'refrx' ) cd $main_dir/src ; touch w3wavemd.F90 + touch w3parall.F90 + touch w3pro1md.F90 + touch w3pro2md.F90 + touch w3pro3md.F90 ;; + 'ig' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3iogomd.F90 + touch w3iogrmd.F90 + touch w3ref1md.F90 + touch w3src4md.F90 + touch w3srcemd.F90 + touch w3gridmd.F90 + touch ww3_ounp.F90 + touch ww3_outp.F90 ;; + 'rotag' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3iobcmd.F90 + touch w3iogomd.F90 + touch w3iogrmd.F90 + touch w3iopomd.F90 + touch w3updtmd.F90 + touch ww3_grib.F90 + touch ww3_ounf.F90 + touch ww3_ounp.F90 + touch ww3_outf.F90 + touch w3gridmd.F90 ;; + 'nnt' ) cd $main_dir/src ; touch w3srcemd.F90 ;; + 'mprf' ) cd $main_dir/src ; touch wmmdatmd.F90 + touch wminitmd.F90 + touch wmwavemd.F90 + touch wmfinlmd.F90 ;; + 'cou' ) cd $main_dir/src ; touch w3iogomd.F90 + touch w3nmlmultimd.F90 + touch w3nmlshelmd.F90 + touch w3wavemd.F90 + touch wminitmd.F90 + touch ww3_shel.F90 ;; + 'oasis' ) cd $main_dir/src ; touch w3oacpmd.F90 + touch w3fldsmd.F90 + touch w3wavemd.F90 + touch w3wdatmd.F90 + touch ww3_shel.F90 ;; + 'agcm' ) cd $main_dir/src ; touch w3agcmmd.F90 + touch w3fldsmd.F90 + touch w3iogomd.F90 + touch w3oacpmd.F90 + touch w3wavemd.F90 + touch ww3_shel.F90 ;; + 'ogcm' ) cd $main_dir/src ; touch w3ogcmmd.F90 + touch w3fldsmd.F90 + touch w3iogomd.F90 + touch w3oacpmd.F90 + touch w3updtmd.F90 + touch w3wavemd.F90 + touch ww3_shel.F90 ;; + 'igcm' ) cd $main_dir/src ; touch w3igcmmd.F90 + touch w3fldsmd.F90 + touch w3oacpmd.F90 + touch w3wavemd.F90 + touch ww3_shel.F90 ;; + 'setup' ) cd $main_dir/src ; touch w3initmd.F90 + touch w3iogomd.F90 + touch w3iopomd.F90 + touch w3netcdf.F90 + touch w3odatmd.F90 + touch w3updtmd.F90 + touch w3wavemd.F90 + touch w3wdatmd.F90 + touch ww3_ounf.F90 + touch ww3_ounp.F90;; + 'pdlib' ) cd $main_dir/src ; touch w3adatmd.F90 + touch w3gdatmd.F90 + touch w3initmd.F90 + touch w3iorsmd.F90 + touch w3netcdf.F90 + touch w3parall.F90 + touch w3srcemd.F90 + touch w3triamd.F90 + touch w3wavemd.F90 + touch w3wdatmd.F90 + touch wminiomd.F90 + touch wmmdatmd.F90 + touch ww3_shel.F90 ;; + 'memck' ) cd $main_dir/src ; touch w3adatmd.F90 + touch w3gdatmd.F90 + touch w3initmd.F90 + touch w3iogrmd.F90 + touch w3profsmd_pdlib.F90 + touch w3wavemd.F90 + touch ww3_shel.F90 ;; + 'uost' ) cd $main_dir/src ; touch w3gdatmd.F90 + touch w3initmd.F90 + touch w3iogrmd.F90 + touch w3srcemd.F90 + touch w3wavemd.F90 + touch ww3_grid.F90 ;; + 'smcg' ) cd $main_dir/src ; touch w3psmcmd.F90 + touch w3smcomd.F90 ;; + 'b4b' ) cd $main_dir/src ; touch w3psmcmd.F90 ;; * ) echo "w3_new: keyword [$key] not recognized" ;; esac done diff --git a/model/bin/w3_setenv b/model/bin/w3_setenv index 2d1ba35ac..7e13e1609 100755 --- a/model/bin/w3_setenv +++ b/model/bin/w3_setenv @@ -19,7 +19,6 @@ # list # # ln3 # # ad3 # -# ad3_test # # all_switches # # sort_all_switches # # find_switch # diff --git a/model/bin/w3_setup b/model/bin/w3_setup index 5e51efece..8334d3bbd 100755 --- a/model/bin/w3_setup +++ b/model/bin/w3_setup @@ -155,14 +155,8 @@ fi # 2.b Check for existing environment and set defaults if [ -f $ww3_env ] then - sed -i "s/WWATCH3_F77/WWATCH3_F90/g" $ww3_env - echo " Setup file $ww3_env found" - set `grep WWATCH3_F90 $ww3_env` ; shift - comp_fc="$*" - echo " auxiliary FORTRAN compiler : $comp_fc" - echo " Source directory : $path_s" set `grep WWATCH3_TMP $ww3_env` ; shift @@ -185,7 +179,6 @@ then else echo " Setup file $ww3_env not found" - comp_fc=gfortran if [ $tdir ] then temp_dir=$tdir @@ -197,7 +190,6 @@ else echo ' ' echo " Default set up :" - echo " Auxiliary FORTRAN comp. : $comp_fc" echo " Scratch directory : $temp_dir" echo " Save sources : $source" echo " Save listings : $list" @@ -235,13 +227,6 @@ then do echo ' ' - echo -n " Auxiliary FORTRAN compiler [$comp_fc] : " - instr="$NULL" ; read instr - if [ -n "$instr" ] - then - comp_fc="$instr" - fi - OK="$NULL" until [ "$OK" = 'y' ] do @@ -292,7 +277,6 @@ then echo ' ' echo " Modified set up :" - echo " Auxiliary FORTRAN comp. : $comp_fc" echo " Scratch directory : $temp_dir" echo " Save sources : $source" echo " Save listings : $list" @@ -309,7 +293,6 @@ echo '# Environment variables for wavewatch III' >> $ww3_env echo '# ---------------------------------------' >> $ww3_env echo '#' >> $ww3_env echo ' ' >> $ww3_env -echo "WWATCH3_F90 $comp_fc" >> $ww3_env echo "WWATCH3_DIR $path_s" >> $ww3_env echo "WWATCH3_TMP $temp_dir" >> $ww3_env echo "WWATCH3_SOURCE $source" >> $ww3_env @@ -319,46 +302,6 @@ echo ' ' >> $ww3_env # --------------------------------------------------------------------------- # # 3. Set up other WWATCH3 files # # --------------------------------------------------------------------------- # -# 3.a Setup makefile for auxiliary programs -echo ' ' -echo ' Setup makefile for auxiliary programs' -cd $path_a -cat > $path_a/makefile << 'EOF' -############################################################ -# FC & BIN must be defined when called -############################################################ - -BIN_LIST = $(BIN)/w3adc $(BIN)/w3list $(BIN)/w3prnt $(BIN)/w3split - -all: $(BIN_LIST) - -$(BIN)/w3adc: w3adc.f - $(FC) -o $(BIN)/w3adc w3adc.f - -$(BIN)/w3list: w3list.f - $(FC) -o $(BIN)/w3list w3list.f - -$(BIN)/w3prnt: w3prnt.f - $(FC) -o $(BIN)/w3prnt w3prnt.f - -$(BIN)/w3split: w3split.f - $(FC) -o $(BIN)/w3split w3split.f - -clean: - rm -f $(BIN_LIST) -EOF -echo ' ' - -# 3.b Compile auxiliary programs -echo ' ' -echo ' Compile auxiliary programs' -if make -C $path_a FC=$comp_fc BIN=$path_b -then : -else - errmsg "Error occured during compile of auxiliary programs" - exit 1 -fi -echo ' ' # 3.c Setup comp & link files if [ $cmplr ] @@ -427,7 +370,37 @@ then errmsg "$path_b/link.$cmplr not found" exit 1 fi - chmod 775 $path_b/comp $path_b/link + if [ -f $path_b/ad3.$cmplr ] + then + rm -f $path_b/ad3 + cp -f $path_b/ad3.$cmplr $path_b/ad3 + echo " copy $path_b/ad3.$cmplr => $path_b/ad3" + elif [ "$cmplr" == "mpt" ] || [ "$cmplr" == "mpt_debug" ] || \ + [ "$cmplr" == "datarmor_mpt" ] || [ "$cmplr" == "datarmor_mpt_debug" ] || \ + [ "$cmplr" == "intel" ] || [ "$cmplr" == "intel_debug" ] || \ + [ "$cmplr" == "so_intel" ] || [ "$cmplr" == "so_intel_debug" ] || \ + [ "$cmplr" == "datarmor_intel" ] || [ "$cmplr" == "datarmor_intel_debug" ] || \ + [ "$cmplr" == "gnu" ] || [ "$cmplr" == "gnu_debug" ] || \ + [ "$cmplr" == "hera.intel" ] || [ "$cmplr" == "orion.intel" ] || \ + [ "$cmplr" == "hera.gnu" ] || [ "$cmplr" == "jet.intel" ] || \ + [ "$cmplr" == "stampede.intel" ] || [ "$cmplr" == "gaea.intel" ] || \ + [ "$cmplr" == "wcoss2" ] || [ "$cmplr" == "s4.intel" ] || \ + [ "$cmplr" == "cheyenne.intel" ] || [ "$cmplr" == "cheyenne.gnu" ] || \ + [ "$cmplr" == "wcoss_cray" ] || [ "$cmplr" == "wcoss_dell_p3" ] || \ + [ "$cmplr" == "datarmor_gnu" ] || [ "$cmplr" == "datarmor_gnu_debug" ] || \ + [ "$cmplr" == "pgi" ] || [ "$cmplr" == "pgi_debug" ] || \ + [ "$cmplr" == "datarmor_pgi" ] || [ "$cmplr" == "datarmor_pgi_debug" ] || \ + [ "$cmplr" == "ukmo_cray" ] || [ "$cmplr" == "ukmo_cray_debug" ] || \ + [ "$cmplr" == "ukmo_cray_gnu" ] || [ "$cmplr" == "ukmo_cray_gnu_debug" ] || \ + [ "$cmplr" == "ukmo_cray_intel" ] || [ "$cmplr" == "ukmo_cray_intel_debug" ]; then + source $path_b/cmplr.env + sed -e "s//$comp_seq/" -e "s//$cppad3procflag/" -e "s//$cppad3flag2/" -e "s//$cppad3flag3/" -e "s//$cppad3flag4/" $path_b/ad3.tmpl > $path_b/ad3 + echo " sed $path_b/ad3.tmpl => $path_b/ad3" + else + errmsg "$path_b/ad3.$cmplr not found" + exit 1 + fi + chmod 775 $path_b/comp $path_b/link $path_b/ad3 fi # 3.d Setup switch file if [ $swtch ] diff --git a/model/ftn/w3gridmd.ftn b/model/ftn/w3gridmd.ftn deleted file mode 100644 index b8c988fe9..000000000 --- a/model/ftn/w3gridmd.ftn +++ /dev/null @@ -1,6600 +0,0 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3GRIDMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | J. H. Alves | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 27-May-2021 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 27-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Add UNFORMATTED bath file option. -!/ Read options with namelists. -!/ 14-Feb-2000 : Adding exact Snl ( version 2.01 ) -!/ 04-May-2000 : Non central source term int. ( version 2.03 ) -!/ 24-Jan-2001 : Flat grid option. ( version 2.06 ) -!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 27-Feb-2001 : O0 output switch added. ( version 2.08 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 29-Mar-2001 : Sub-grid island treatment. ( version 2.10 ) -!/ 20-Jul-2001 : Clean up. ( version 2.11 ) -!/ 12-Sep-2001 : Clean up. ( version 2.13 ) -!/ 09-Nov-2001 : Clean up. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice treatment. ( version 2.15 ) -!/ 17-Jan-2002 : DSII bug fix. ( version 2.16 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 26-Nov-2002 : Adding first version of NL-3/4. ( version 3.01 ) -!/ Removed before distribution in 3.12. -!/ 26-Dec-2002 : Relaxing CFL time step. ( version 3.02 ) -!/ 01-Aug-2003 : Modify GSE correction for moving gr.( version 3.03 ) -!/ Add offset option for first direction. -!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Allow active points at edge. ( version 3.07 ) -!/ 07-Jul-2005 : Add MAPST2 and map processing. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Adding alternative source terms. ( version 3.09 ) -!/ Module W3SLN1MD, dummy for others. -!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 28-Oct-2006 : Spectral partitioning. ( version 3.09 ) -!/ 09-Jan-2007 : Correct edges of read mask. ( version 3.10 ) -!/ 26-Mar-2007 : Add to spectral partitioning. ( version 3.11 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 18-Sep-2007 : Adding WAM4 physics option. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 09-Oct-2007 : Adding bottom scattering SBS1. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 22-Feb-2008 : Initialize TRNX-Y properly. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 23-Jul-2009 : Modification of ST3 namelist . ( version 3.14-SHOM ) -!/ 31-Mar-2010 : Addition of shoreline reflection ( version 3.14-IFREMER ) -!/ 29-Jun-2010 : Adding Stokes drift profile output ( version 3.14-IFREMER ) -!/ 30-Aug-2010 : Adding ST4 option ( version 3.14-IFREMER ) - -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Clean up of unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. Change GLOBAL -!/ input in ww3_grid.inp to CSTRG. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 25-Jun-2011 : Adding movable bed friction ( version 4.01 ) -!/ 16-Sep-2011 : Clean up. ( version 4.05 ) -!/ 01-Dec-2011 : New namelist for reflection ( version 4.05 ) -!/ 01-Mar-2012 : Bug correction for NLPROP in ST2 ( version 4.05 ) -!/ 12-Jun-2012 : Add /RTD rotated grid option. JGLi ( version 4.06 ) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of reflection and UG grids ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 19-Dec-2012 : Add NOSWLL as namelist variable. ( version 4.OF ) -!/ 05-Mar-2013 : Adjusted default roughness for rocks( version 4.09 ) -!/ 01-Jun-2013 : Adding namelist for spectral output ( version 4.10 ) -!/ 12-Sep-2013 : Adding Arctic part for SMC grid. ( version 4.11 ) -!/ 01-Nov-2013 : Changed UG list name to UNST ( version 4.12 ) -!/ 11-Nov-2013 : Make SMC and RTD option compatible. ( version 4.13 ) -!/ 13-Nov-2013 : Moved out reflection to W3UPDTMD ( version 4.12 ) -!/ 27-Jul-2013 : Adding free infragravity waves ( version 4.15 ) -!/ 02-Dec-2013 : Update of ST4 ( version 4.16 ) -!/ 16-Feb-2014 : Adds wind bias correction: WCOR ( version 5.00 ) -!/ 10-Mar-2014 : Adding namelist for IC2 ( version 5.01 ) -!/ 29-May-2014 : Adding namelist for IC3 ( version 5.01 ) -!/ 15 Oct-2015 : Change SMC grid input files. JGLi ( version 5.09 ) -!/ 10-Jan-2017 : Changes for US3D and USSP ( version 6.01 ) -!/ 20-Jan-2017 : Bug fix for mask input from file. ( version 6.02 ) -!/ 01-Mar-2018 : RTD poles info read from namelist ( version 6.02 ) -!/ 14-Mar-2018 : Option to read UNST boundary file ( version 6.02 ) -!/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) -!/ 15-May-2018 : Dry sea points over zlim ( version 6.04 ) -!/ 06-Jun-2018 : add Implicit grid parameters for unstructured grids -!/ add DEBUGGRID/DEBUGSTP ( version 6.04 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 20-Jun-2018 : Update of ST6 (Q. Liu) ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 27-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Jan-2020 : Update default values for IS2 ( version 7.05 ) -!/ 20-Feb-2020 : Include Romero's dissipation in ST4 ( version 7.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) -!/ 24-Jun-2020 : RTD output b. c. to rotated grid. ( version 7.11 ) -!/ 05-Jan-2021 : Update SMC grid for multi-grid. JGLi( version 7.13 ) -!/ 27-May-2021 : Updates for IC5 (Q. Liu) ( version 7.12 ) -!/ 27-May-2021 : Moved to a subroutine ( version 7.13 ) -!/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! "Grid" preprocessing subroutine, which writes a model definition -! file containing the model parameter settigs and grid data. -! -! 2. Method : -! -! Information is read from the file ww3_grid.inp (NDSI), or -! preset in this subroutine. A model definition file mod_def.ww3 is -! then produced by W3IOGR. Note that the name of the model -! definition file is set in W3IOGR. -! -! 3. Parameters : -! -! Local parameters. -! ---------------------------------------------------------------- -! NDSI Int. Input unit number ("ww3_grid.inp"). -! NDSS Int. Scratch file. -! NDSG Int. Grid unit ( may be NDSI ) -! NDSTR Int. Sub-grid unit ( may be NDSI or NDSG ) -! VSC Real Scale factor. -! VOF Real Add offset. -! ZLIM Real Limiting bottom depth, used to define land. -! IDLA Int. Layout indicator used by INA2R. -! IDFM Int. Id. FORMAT indicator. -! RFORM C*16 Id. FORMAT. -! FNAME C*60 File name with bottom level data. -! FROM C*4 Test string for open, 'UNIT' or 'FILE' -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3NMOD Subr. W3GDATMD Set number of model. -! W3SETG Subr. Id. Point to selected model. -! W3DIMS Subr. Id. Set array dims for a spectral grid. -! W3DIMX Subr. Id. Set array dims for a spatial grid. -! W3GRMP Subr. W3GSRUMD Compute bilinear interpolation for point -! W3NOUT Subr. W3ODATMD Set number of model for output. -! W3SETO Subr. Id. Point to selected model for output. -! W3DMO5 Subr. Id. Set array dims for output type 5. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! NEXTLN Subr. Id. Get next line from input file -! EXTCDE Subr. Id. Abort program as graceful as possible. -! DISTAB Subr. W3DISPMD Make tables for solution of the -! dispersion relation. -! READNL Subr. Internal Read namelist. -! INAR2R Subr. W3ARRYMD Read in an REAL array. -! PRTBLK Subr. Id. Print plot of array. -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! ww3_grid program -! -! 6. Error messages : -! -! 7. Remarks : -! -! Physical grid : -! ----------------- -! -! The physical grid is defined by a grid counter IX defining the -! discrete longitude and IY defining the discrete latitude as shown -! below. For mathemathical convenience, these grid axes will -! generally be denoted as the X and Y axes. Two-dimensional arrays -! describing parameters on this grid are given as A(IY,IX). -! -! IY=NY -! ^ | | | | | | ^ N -! | |------|------|------|------|------|---- | -! | | :: | 25 | 26 | 27 | 28 | --|-- -! |------|------|------|------|------|---- | -! IY=3 | :: | :: | 9 | 10 | 11 | | -! |------|------|------|------|------|---- -! IY=2 | :: | 1 | 2 | :: | 3 | -! |------|------|------|------|------|---- -! IY=1 | :: | :: | :: | :: | :: | -! +------+------+------+------+------+---- -! IX=1 IX=2 IX=3 IX=4 IX=5 ---> IX=NX -! -! :: is a land point. -! -! To reduce memory usage of the model, spectra are stored for sea -! points only, in a one-dimensional grid with the length NSEA. This -! grid is called the storage grid. The definition of the counter -! in the storage grid is graphically depicted above. To transfer -! data between the two grids, the maps MAPFS and MAPSF are -! determined. MAPFS gives the counter of the storage grid ISEA -! for every physical grid point (IY,IX), such that -! -! MAPFS(IY,IX) = ISEA -! -! ISEA = 0 corresponds to land points. The map MAPSF gives the grid -! counters (IY,IX) for a given storage point ISEA. -! -! MAPSF(ISEA,1) = IX -! MAPSF(ISEA,2) = IY -! MAPSF(ISEA,3) = IY+(IX-1)*NY ( filled during reading ) -! -! Finally, a status maps MAPSTA and MAPST2 are determined, where -! the status indicator ISTAT = MAPSTA(IY,IX) determines the type -! of the grid point. -! -! ISTAT Means -! --------------------------------------------------- -! 0 Point excluded from grid. -! (-)1 Sea point -! (-)2 "Active" boundary point (data prescribed) -! -! For ISTAT=0, the secondary status counter ISTA2 is defined as -! -! ISTA2 Means -! --------------------------------------------------- -! 0 Land point. -! 1 Point excluded from grid. -! -! Negative values of ISTAT identify points that are temporarily -! taken out of the computation. For these points ISTA2 are -! defined per bit -! -! BIT Means -! --------------------------------------------------- -! 1 Ice flag (1 = ice coverage) -! 2 Dry flag (1 = dry point with depth 0) -! 3 Inferred land in multi-grid model. -! 4 Masking in multi-grid model. -! 5 land point flag for relocatable grid. -! -! Thus ISTA2=0 for ISTAT<0 is in error, ISTA2=1 means ice cover, -! ISTA2=3 means ice on dry point, etc. -! -! Spectral grid : -! ----------------- -! -! In the spectral grid (and in physical space in general), -! the cartesian convention for directions is used, i.e., the -! direction 0 corresponds to waves propagating in the positive -! X-direction and 90 degr. corresponds to waves propagating in -! the positive Y-direction. Similar definitions are used for the -! internal description of winds and currents. Output can obviously -! be transformed according to any preferred convention. -! -! ITH=NTH -! ^ | | | | | -! | |------|------|------|------|---- -! | | | | | | TH(3) = DTH*2. -! |------|------|------|------|---- -! ITH=2 | | | | | TH(2) = DTH -! |------|------|------|------|---- -! ITH=1 | | | | | TH(1) = 0. -! +------+------+------+------+---- -! IK=1 IK=2 IK=3 IK=4 ---> IK=NK -! -! The spectral grid consists of NK wavenumbers. The first -! wavenumber IK=1 corresponds to the longest wave. The wavenumber -! grid varies in space, as given by an invariant relative freq. -! grid and the local depth. The spectral grid furthermore contains -! NTH directions, equally spaced over a full circle. the first -! direction corresponds to the direction 0, etc. -! -! (Begin SMC description) -! -! Spherical Multiple-Cell (SMC) grid -! ----------------------------------- -! -! SMC grid is a multi-resolution grid using cells of multiple times -! of each other. It is similar to the lat-lon grid using rectangular -! cells but only cells at sea points are retained. All land points -! have been removed from the model. At high latitudes, cells are -! merged longitudinally to relax the CFL resctiction on time steps. -! Near coastlines, cells are divided into quarters in a few steps so -! that high resolution is achieved to refine coastlines and resolve -! small islands. At present, three tiers of quarter cells are used. -! For locating purpose, a usual x-y counter is setup by the smallest -! cell size and starting from the south-west corner of the usual -! rectuangular domain. Each sea cell is then given a pair of x-y -! index, plus a pair of increments. These four index are stored in -! the cell array IJKCel(NCel, 5), each row holds i, j, di, dj, ndps -! where ndps is an integer depth in metre. If precision higher than -! a metre is required, it may use other unit (cm for instance) with a -! conversion factor. -! -! For transport calculation, two face arrays, IJKUFc(NUFc, 7) and -! IJKVFc(NVFc,8), are also created to store the neighbouring cell -! sequential numbers and the face location and size. The 3 arrays -! are calculated outside the wave model and input from text files. -! -! Boundary condition is added for SMC grid so that it can be used for -! regional model as well. Most of the original boundary settings -! are reclaimed as long as the boundary condition file is provided -! by a lat-lon grid WW3 model, which will set the interpolation -! parameters in the boundary condition file. The NBI number is -! reset with an input value because the NX-Y double loop overcount -! the boundary cells for merged cells in the SMC grid. ISBPI -! boundary cell mapping array is fine as MAPFS uses duplicated cell -! number in any merged cell. From there, all original NBI loops are -! reusable. -! -! The whole Arctic can be included in the SMC grid if ARCTC variable -! is set to be .TRUE. within the SMC option. The ARCTC option appends -! the polar Arctic part above 86N to the existing SMC grid and uses -! a map-east reference direction for this extra polar region. -! Because the map-east direction changes with latitude and longitude -! the wave spectra defined to the map-east direction could not be -! mixed up with the conventional spectra defined to the local east -! direction. A rotation sub is provided for convertion from one to -! another. Propagation part will be calculated together, including -! the boundary cells. The boundary cells are then updated by -! assigning the corresponding inner cells to them after conversion. -! Boundary cells are duplicated northmost 4 rows of the global part -! and they can be excluded for source term and output if required. -! For convenience, Arctic cellls are all base level cells and are -! appended to the end of the global cells. If refined cells were -! used in the Arctic part, it would not be kept all together, making -! the sub-loops much more complicated. If refined resolution cells -! are required for a Arctic regional model, users may consider use -! the rotated SMC grid options (RTD and SMC). -! -! For more information about the SMC grid, please refer to -! Li, J.G. (2012) Propagation of Ocean Surface Waves on a Spherical -! Multiple-Cell Grid. J. Comput. Phys., 231, 8262-8277. online at -! http://dx.doi.org/10.1016/j.jcp.2012.08.007 -! -! (End SMC description) -! -! ICEWIND is the scale factor for reduction of wind input by ice -! concentration. Value specified corresponds to the fractional -! input for 100% ice concentration. Default is 1.0, meaning that -! 100% ice concentration result in zero wind input. -! Sin_in_ice=Sin_in_open_water * (1-ICE*ICEWIND) - -! -----------------------------------------------------------------* -! 8. Structure : -! -! ---------------------------------------------------------------- -! 1. Set up grid storage structure. -! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) -! 2.a I-O setup. -! b Print heading(s). -! 3. Prepare int. table for dispersion relation ( DISTAB ) -! 4. Read and process input file up to spectrum. -! a Get comment character -! b Name of grid -! c Define spectrum ( W3DIMS ) -! 5. Set-up discrete spectrum. -! a Directions. -! b Frequency for spectrum. -! 6. Read and process input file up to numerical parameters -! a Set model flags and time steps -! b Set / select source term package -! c Pre-process namelists. -! d Wind input source term. -! e Nonlinear interactions. -! f Whitecapping term. -! g Bottom friction source term. -! h Depth indiced breaking source term. -! i Triad interaction source term. -! j Bottom scattering source term. -! k Undefined source term. -! l Set / select propagaton scheme -! m Parameters for propagation scheme. -! n Set misc. parameters (ice, seeding, ...) -! o End of namelist processing -! p Set various other variables -! 7. Read and prepare grid. -! a Layout of grid -! b Storage of grid of grid -! c Read bottom depths -! d Set up temp map -! e Subgrid information -! 1 Info from input file -! 2 Open file and check if necessary -! 3 Read the data -! 4 Limit -! 8 Finalize status maps -! a Determine where to get the data -! Get data in parts from input file -! ---------------------------------------------------- -! b Read and update TMPSTA with bound. and excl. points. -! c Finalize excluded points -! ---------------------------------------------------- -! Read data from file -! ---------------------------------------------------- -! d Read data from file -! ---------------------------------------------------- -! e Get NSEA and other counters -! f Set up all maps ( W3DIMX ) -! 9. Prepare output boundary points. -! a Read -! b Update -! 10. Write model definition file. ( W3IOGR ) -! ---------------------------------------------------------------- -! -! 9. Switches : -! -! !/FLX1 Stresses according to Wu (1980). -! !/FLX2 Stresses according to T&C (1996). -! !/FLX3 Stresses according to T&C (1996) with cap on Cd. -! !/FLX4 Stresses according to Hwang (2011). -! !/FLX5 Direct use of stress from atmospheric model/input file. -! -! !/LN0 No linear input source term. -! !/SEED 'Seeding' of lowest frequency for sufficiently strong -! winds. Proxi for linear input. -! !/LN1 Cavaleri and Melanotte-Rizzoli with Tolman filter. -! -! !/ST0 No source terms included (input/dissipation) -! !/ST1 WAM-3 physics package. -! !/ST2 Tolman and Chalikov (1996) physics package. -! !/ST3 WAM 4+ source terms from P.A.E.M. Janssen and J-R. Bidlot -! !/ST4 Input and dissipation using saturation following Ardhuin et al. (2009,2010) -! Filipot & Ardhuin (2010) or Romero (2019) -! !/ST6 BYDRZ source term package featuring Donelan et al. -! (2006) input and Babanin et al. (2001,2010) dissipation. -! -! !/NL0 No nonlinear interactions. -! !/NL1 Discrete interaction approximation (DIA). -! !/NL2 Exact interactions (WRT). -! !/NL3 Generalized Multiple DIA (GMD). -! !/NL4 Two Scale Approximation -! !/NL5 Generalized Kinetic Equation (GKE) -! !/NLS Snl based HF filter. -! -! !/BT0 No bottom friction included. -! !/BT1 JONSWAP bottom friction package. -! !/BT4 SHOWEX bottom friction using movable bed roughness -! (Tolman 1994, Ardhuin & al. 2003) -! -! !/IC1 Sink term for interaction with ice (uniform k_i) -! !/IC2 Sink term for under-ice boundary layer friction -! (Liu et al. 1991: JGR 96 (C3), 4605-4621) -! (Liu and Mollo 1988: JPO 18 1720-1712) -! !/IC3 Sink term for interaction with ice (Wang and Shen method) -! (Wang and Shen JGR 2010) -! !/IC4 Sink term for empirical, frequency-dependent attenuation -! in ice (Wadhams et al. 1988: JGR 93 (C6) 6799-6818) -! !/IC5 Sink term for interaction with ice (effective medium mod.) -! (Mosig et al. 2015, Meylan et al. 2018, Liu et al. -! 2020) -! -! !/UOST Unresolved Obstacles Source Term (UOST), Mentaschi et al. 2015 -! -! !/DB0 No depth-induced breaking included. -! !/DB1 Battjes-Janssen depth-limited breaking. -! !/MLIM Mich-style limiter. -! -! !/TR0 No triad interactions included. -! -! !/BS0 No bottom scattering included. -! !/BS1 Routines from F. Ardhuin. -! -! !/PR1 First order propagation scheme. -! !/PR2 QUICKEST scheme with ULTIMATE limite and diffusion -! correction for swell dispersion. -! !/PR3 Averaging ULTIMATE QUICKEST scheme. -! -! !/RTD Rotated regular lat-lon grid. Special case is standard Polat=90. -! !/SMC Spherical Multiple-Cell grid, may includes the whole Arctic. -! -! !/MGG GSE correction for moving grid. -! -! !/S Enable subroutine tracing. -! !/T Enable test output. -! !/T0 Enable test output tables for boundary output. -! -! !/O0 Print equivalent namelist setting to std out. -! !/O1 Print tables with boundary points as part of output. -! !/O2 Print MAPSTA as part of output. -! !/O2a Print land-sea mask in mask.ww3. -! !/O2b Print obstruction data. -! !/O2c Print extended status map. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3TRIAMD - USE W3GSRUMD, ONLY: W3GRMP - USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 - USE W3IOGRMD, ONLY: W3IOGR - USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE -!/RTD USE W3SERVMD, ONLY: W3EQTOLL, W3LLTOEQ -!/SMC USE W3SERVMD, ONLY: W3LLTOEQ -!/S USE W3SERVMD, ONLY: STRACE - USE W3ARRYMD, ONLY: INA2R, INA2I -!/T USE W3ARRYMD, ONLY: PRTBLK - USE W3DISPMD, ONLY: DISTAB -!/ - USE W3GDATMD - USE W3ODATMD, ONLY: NDSE, NDST, NDSO - USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & - IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE, & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, & - NOSWLL, PTMETH, PTFCUT - USE W3TIMEMD, ONLY: CALTYPE - USE W3NMLGRIDMD -!/SCRIP USE SCRIP_GRIDS, ONLY: GRID1_UNITS, GRID1_NAME, & -!/SCRIP GRID1_CENTER_LON, GRID1_CENTER_LAT, & -!/SCRIP GRID1_CORNER_LON, GRID1_CORNER_LAT, & -!/SCRIP GRID1_MASK, GRID1_SIZE, GRID1_RANK, & -!/SCRIP GRID1_IMASK, & -!/SCRIP GRID1_CORNERS, GRID1_DIMS -!/SCRIP USE SCRIP_KINDSMOD -!/SCRIP USE WMSCRPMD -!/SCRIPNC USE NETCDF -! -!/NL3 USE W3SNL3MD, ONLY: LAMMAX, DELTHM -!/NLS USE W3SNLSMD, ONLY: ABMAX -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - TYPE(NML_SPECTRUM_T) :: NML_SPECTRUM - TYPE(NML_RUN_T) :: NML_RUN - TYPE(NML_TIMESTEPS_T) :: NML_TIMESTEPS - TYPE(NML_GRID_T) :: NML_GRID - TYPE(NML_RECT_T) :: NML_RECT - TYPE(NML_CURV_T) :: NML_CURV - TYPE(NML_UNST_T) :: NML_UNST - TYPE(NML_SMC_T) :: NML_SMC - TYPE(NML_DEPTH_T) :: NML_DEPTH - TYPE(NML_MASK_T) :: NML_MASK - TYPE(NML_OBST_T) :: NML_OBST - TYPE(NML_SLOPE_T) :: NML_SLOPE - TYPE(NML_SED_T) :: NML_SED - TYPE(NML_INBND_COUNT_T) :: NML_INBND_COUNT - TYPE(NML_INBND_POINT_T), ALLOCATABLE :: NML_INBND_POINT(:) - TYPE(NML_EXCL_COUNT_T) :: NML_EXCL_COUNT - TYPE(NML_EXCL_POINT_T), ALLOCATABLE :: NML_EXCL_POINT(:) - TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: NML_EXCL_BODY(:) - TYPE(NML_OUTBND_COUNT_T) :: NML_OUTBND_COUNT - TYPE(NML_OUTBND_LINE_T), ALLOCATABLE :: NML_OUTBND_LINE(:) -! - INTEGER, PARAMETER :: NFL = 6 - INTEGER :: NDSI, NDSI2, NDSS, NDSM, NDSG, NDSTR,& - IERR, NDSTRC, NTRACE, ITH, IK, ITH0, & - ISP, IYN(NFL), NRLIN, NRSRCE, NRNL, & - NRBT, NRDB, NRTR, NRBS, NRPROP, & - IDLA, IDFM, IX0, IXN, IX, IY, ISEA, & - IDX, IXO, IDY, IYO, IBA, NBA, ILOOP, & - IFL, NBOTOT, NPO, IP, IX1, IX2, IY1, & - IY2, J, JJ, IXR(4), IYR(4), ISEAI(4),& - IST, NKI, NTHI, NRIC, NRIS, I, IDFT, & - NSTAT, NBT, NLAND, NOSW, NMAPB, IMAPB -!/NL2 INTEGER :: IDEPTH -!/O1 INTEGER :: IBI, IP0, IPN, IPH, IPI - INTEGER :: NCOL = 78 -!/SMC !!Li Offset to change Equator index = 0 to regular index JEQT -!/SMC !!Li LvSMC levels of refinded resolutions for SMC grid. -!/SMC !!Li NBISMC number of boundary point for regional SMC grid. -!/SMC !!Li ISHFT for SMC i-index from smc origin to regular grid west edge. -!/SMC !!Li SMC cell only subgrid obstruction array dimensions NCObst, JObs. -!/SMC INTEGER :: JEQT, LvSMC, NBISMC, JS, NCObst, JObs, ISHFT -!/SMC INTEGER :: NGUI, NGVJ, NAUI, NAVJ -! -!/O2 INTEGER :: NMAP, IMAP -!/T INTEGER :: IX3, IY3 -!/T0 INTEGER :: IFILE -!/S INTEGER, SAVE :: IENT = 0 -! - INTEGER, ALLOCATABLE :: TMPSTA(:,:), TMPMAP(:,:), READMP(:,:) -!/T INTEGER, ALLOCATABLE :: MAPOUT(:,:) -! - REAL :: RXFR, RFR1, SIGMA, SXFR, FACHF, & - VSC, VSC0, VOF, & - ZLIM, X, Y, XP, XO0, YO0, DXO, DYO, & - XO, YO, RD(4), RDTOT, & - FACTOR, RTH0, FMICHE, RWNDC, & - WCOR1, WCOR2 -! - CHARACTER(LEN=4) :: GSTRG, CSTRG -! -! Variables used to allow spectral output on full grid -! - INTEGER :: P2SF,I1P2SF,I2P2SF - INTEGER :: E3D,I1E3D,I2E3D - INTEGER :: US3D,I1US3D,I2US3D, & - USSP, IUSSP, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M - ! STK_WN are the decays for Stokes drift partitions - REAL :: STK_WN(25) - -!/DEBUGGRID INTEGER :: nbCase1, nbCase2, nbCase3, & -!/DEBUGGRID nbCase4, nbCase5, nbCase6, & -!/DEBUGGRID nbCase7, nbCase8 -!/DEBUGGRID INTEGER :: nbTMPSTA0, nbTMPSTA1, nbTMPSTA2 -!/DEBUGGRID INTEGER :: IAPROC -! -!/LN1 REAL :: CLIN, RFPM, RFHF -!/ST1 REAL :: CINP, CDIS, APM -!/ST2 REAL :: PHIMIN, FPIA, FPIB, DPHID -!/NL1 REAL :: NLPROP -!/NL2 REAL :: DPTFAC, DEPTHS(100) -!/NL3 REAL :: QPARMS(500) -!/NLS REAL :: A34, FHFC, DNM, FC1, FC2, FC3 -!/BT1 REAL :: GAMMA -!/PR2 REAL :: LATMIN -! -!/SMC REAL :: TRNMX, TRNMY -!/SMC INTEGER, ALLOCATABLE :: NLvCelsk(:), NLvUFcsk(:), NLvVFcsk(:) -!/SMC INTEGER, ALLOCATABLE :: IJKCelin(:,:),IJKUFcin(:,:),IJKVFcin(:,:) -!/SMC INTEGER, ALLOCATABLE :: NBICelin(:), IJKObstr(:,:) -!/SMC REAL :: PoLonAC, PoLatAC -!/SMC INTEGER, ALLOCATABLE :: IJKCelAC(:,:),IJKUFcAC(:,:),IJKVFcAC(:,:) -!/SMC REAL, ALLOCATABLE :: XLONAC(:),YLATAC(:),ELONAC(:),ELATAC(:) -! -!/RTD REAL, ALLOCATABLE :: AnglDin(:,:),StdLon(:,:),StdLat(:,:) -!/RTD ! 1-dim boundary sectors -!/RTD REAL, ALLOCATABLE :: BDYLON(:), BDYLAT(:), & -!/RTD ELatbdy(:), ELonbdy(:), Anglbdy(:) -!/RTD ! If the destination grid for an output b.c. is rotated, its pole is: -!/RTD REAL :: bPolat, bPolon -!/RTD! - REAL, ALLOCATABLE :: XGRDIN(:,:), YGRDIN(:,:) - REAL, ALLOCATABLE :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) - REAL, ALLOCATABLE :: REFD(:,:), REFD2(:,:), REFS(:,:) -!/BT4 REAL, ALLOCATABLE :: SED_D50FILE(:,:), SED_POROFILE(:,:) -!/BT4 LOGICAL :: SEDMAPD50 -!/BT4 REAL :: SED_D50_UNIFORM, SED_DSTAR, RIPFAC1, & -!/BT4 RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & -!/BT4 BOTROUGHMIN, BOTROUGHFAC -! - LOGICAL :: FLLIN, FLINDS, FLNL, FLBT, FLDB, & - FLTR, FLBS, FLPROP, FLREF, & - FIRST, CONNCT, FLNEW, INGRID,FLIC, & - FLIS, FLGNML - LOGICAL :: FLTC96 = .FALSE. - LOGICAL :: FLNMLO = .FALSE. - LOGICAL :: FLSTB2 = .FALSE. - LOGICAL :: FLST4 = .FALSE. - LOGICAL :: FLST6 = .FALSE. - - REAL :: FACBERG, REFSLOPE -!/IS1 REAL :: ISC1, ISC2 -!/IS2 REAL :: ISC1, IS2BACKSCAT, IS2C2, IS2C3,& -!/IS2 IS2FRAGILITY, IS2DMIN, IS2DAMP, & -!/IS2 IS2CONC, IS2CREEPB, IS2CREEPC, & -!/IS2 IS2CREEPD, IS2CREEPN, IS2BREAKE,& -!/IS2 IS2WIM1, IS2BREAKF, IS2FLEXSTR, & -!/IS2 IS2ANDISN, IS2ANDISE, IS2ANDISD -!/IS2 LOGICAL :: IS2BREAK, IS2DISP, IS2DUPDATE, & -!/IS2 IS2ISOSCAT, IS2ANDISB -! -!/REF1 REAL :: REFCOAST, REFFREQ, REFMAP, & -!/REF1 REFSUBGRID, REFRMAX, REFMAPD, & -!/REF1 REFICEBERG, REFCOSP_STRAIGHT, & -!/REF1 REFFREQPOW, REFUNSTSOURCE -! -!/IG1 LOGICAL :: IGSWELLMAX, IGBCOVERWRITE -!/IG1 INTEGER :: IGMETHOD, IGADDOUTP, IGSOURCE, & -!/IG1 IGSOURCEATBP, IGSTERMS -!/IG1 REAL :: IGMAXFREQ, IGMINDEP, IGMAXDEP, & -!/IG1 IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL -! -!/IC2 LOGICAL :: IC2DISPER -!/IC2 REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & -!/IC2 IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX - -!/IC3 REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & -!/IC3 IC2SMOOTH, IC2VISC, IC2TURBS, & -!/IC3 IC3MAXTHK, IC3MAXCNC, & -!/IC3 IC3HILIM, IC3KILIM, & -!/IC3 IC3VISC, IC3ELAS, IC3DENS, IC3HICE -!/IC3 LOGICAL :: IC3CHENG,USECGICE - -!/IC4 INTEGER :: IC4METHOD -!/IC4 REAL :: IC4KI(NIC4), IC4FC(NIC4) -! -!/IC5 REAL :: IC5MINIG, IC5MINWT, & -!/IC5 IC5MAXKRATIO, IC5MAXKI, IC5MINHW, & -!/IC5 IC5MAXITER, IC5RKICK, IC5KFILTER, & -!/IC5 IC5VEMOD -!/IC5 CHARACTER(LEN=4) :: IC5MSTR(3) = (/' EFS', ' RP ', ' M2 '/) - - CHARACTER :: COMSTR*1, PNAME*30, RFORM*16, & - FROM*4, FNAME*60, TNAME*60, LINE*80, & - STATUS*20,FNAME2*60, PNAME2*40 - CHARACTER(LEN=6) :: YESXNO(2) -!/FLX3 CHARACTER(LEN=18) :: TYPEID - -!/SCRIP INTEGER :: NCID -!/SCRIP INTEGER :: grid_size_dimid, grid_rank_dimid, grid_corners_dimid -!/SCRIP INTEGER :: grid_center_lat_varid, grid_center_lon_varid -!/SCRIP INTEGER :: grid_corner_lat_varid, grid_corner_lon_varid -!/SCRIP INTEGER :: grid_area_varid, grid_imask_varid -!/SCRIP INTEGER :: grid_dims_varid -!/SCRIP REAL (SCRIP_R8) :: CONV_DX,CONV_DY,OFFSET - -!/ ------------------------------------------------------------------- / -!/ Namelists -!/ - INTEGER :: FLAGTR, IHM - REAL :: CFLTM, CICE0, CICEN, PMOVE, XFILT, & - LICE, XSEED, XR, HSPM, WSM, WSC, STDX,& - STDY, STDT, ICEHMIN, ICEHFAC, ICEHINIT, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEHDISP, ICEFDISP, ICEDDISP, BTBET -! - REAL(8) :: GSHIFT ! see notes in WMGHGH - LOGICAL :: FLC, ICEDISP, TRCKCMPR - INTEGER :: PTM ! Partitioning method - REAL :: PTFC ! Part. cut off freq (for method 5) - REAL :: AIRCMIN, AIRGB - CHARACTER :: PMNAME*45, PMNAM2*45 ! Part. method desc. -!/FLD1 INTEGER :: TAILTYPE -!/FLD1 REAL :: TAILLEV, TAILT1, TAILT2 -!/FLD2 INTEGER :: TAILTYPE -!/FLD2 REAL :: TAILLEV, TAILT1, TAILT2 -!/FLX3 INTEGER :: CTYPE -!/FLX3 REAL :: CDMAX -!/FLX4 REAL :: CDFAC -!/ST2 REAL :: ZWND, SWELLF, STABSH, STABOF, & -!/ST2 CNEG, CPOS, FNEG, FPOS -!/ST2 REAL :: SDSA0, SDSA1, SDSA2, & -!/ST2 SDSB0, SDSB1, SDSB2, SDSB3 -!/ST3 REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& -!/ST3 ZALP, SWELLF, FXPM3, FXFM3, & -!/ST3 WNMEANPTAIL, WNMEANP, STXFTF, STXFTWN -!/ST3 REAL :: STXFTFTAIL, SDSC1, & -!/ST3 SDSDELTA1, SDSDELTA2 -! -!/ST4 INTEGER :: SWELLFPAR, SDSISO, SDSBRFDF -!/ST4 REAL :: SDSBCHOICE -!/ST4 REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& -!/ST4 ZALP, Z0RAT, TAUWSHELTER, SWELLF, & -!/ST4 SWELLF2,SWELLF3,SWELLF4, SWELLF5, & -!/ST4 SWELLF6, SWELLF7, FXPM3, FXFM3, & -!/ST4 WNMEANPTAIL, WNMEANP, STXFTF, STXFTFTAIL, & -!/ST4 STXFTWN, SINBR, FXFMAGE, & -!/ST4 SDSC2, SDSCUM, SDSC4, SDSC5, SDSC6, WHITECAPWIDTH, WHITECAPDUR, & -!/ST4 SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & -!/ST4 SDSBR, SDSP, SDSBT, SDS4A, SDKOF, & -!/ST4 SDSCOS, SDSDTH, SDSBCK, SDSABK, & -!/ST4 SDSPBK, SDSBINT, SDSHCK, & -!/ST4 SDSBRF1, & -!/ST4 SDSBM0, SDSBM1, SDSBM2, SDSBM3, & -!/ST4 SDSBM4, SDSFACMTF, SDSCUMP, SDSNUW, & -!/ST4 SDSL, SDSMWD, SDSMWPOW, SPMSS, SDSNMTF -! -!/ST6 REAL :: SINA0, SINWS, SINFC, & -!/ST6 SDSA1, SDSA2, SWLB1 -!/ST6 INTEGER :: SDSP1, SDSP2 -!/ST6 LOGICAL :: SDSET, CSTB1 -! -!/NL1 REAL :: LAMBDA, KDCONV, KDMIN, & -!/NL1 SNLCS1, SNLCS2, SNLCS3 -!/NL2 INTEGER :: IQTYPE, NDEPTH -!/NL2 REAL :: TAILNL -!/NL3 INTEGER :: NQDEF -!/NL3 REAL :: MSC, NSC, KDFD, KDFS -!/NL4 INTEGER :: INDTSA, ALTLP -!/NL5 REAL :: NL5DPT, NL5OML -!/NL5 INTEGER :: NL5DIS, NL5KEV, NL5IPL, NL5PMX -!/DB1 REAL :: BJALFA, BJGAM -!/DB1 LOGICAL :: BJFLAG -!/PR2 REAL :: DTIME -! -!/SMC REAL :: DTIMS, CFLSM, RFMAXD, SYMR, YJ0R -!/SMC LOGICAL :: UNO3, AVERG, SEAWND, Arctic -!/SMC CHARACTER :: PNSMC*30 -! -!/PR3 REAL :: WDTHCG, WDTHTH - LOGICAL :: JGS_TERMINATE_MAXITER = .TRUE. - LOGICAL :: JGS_TERMINATE_DIFFERENCE = .TRUE. - LOGICAL :: JGS_TERMINATE_NORM = .TRUE. - LOGICAL :: JGS_LIMITER = .FALSE. - LOGICAL :: JGS_BLOCK_GAUSS_SEIDEL = .TRUE. - LOGICAL :: JGS_USE_JACOBI = .TRUE. - LOGICAL :: JGS_SOURCE_NONLINEAR = .FALSE. - LOGICAL :: UGOBCAUTO = .FALSE. - LOGICAL :: UGBCCFL = .FALSE. - LOGICAL :: EXPFSN = .TRUE. - LOGICAL :: EXPFSPSI = .FALSE. - LOGICAL :: EXPFSFCT = .FALSE. - LOGICAL :: IMPFSN = .FALSE. - LOGICAL :: EXPTOTAL = .FALSE. - LOGICAL :: IMPTOTAL = .FALSE. - LOGICAL :: IMPREFRACTION = .FALSE. - LOGICAL :: IMPFREQSHIFT = .FALSE. - LOGICAL :: IMPSOURCE = .FALSE. - LOGICAL :: SETUP_APPLY_WLV = .FALSE. - INTEGER :: JGS_MAXITER=100 - INTEGER :: nbSel - INTEGER :: UNSTSCHEMES(4) - INTEGER :: UNSTSCHEME - INTEGER :: JGS_NLEVEL = 0 - REAL*8 :: JGS_PMIN = 0. - REAL*8 :: JGS_DIFF_THR = 1.E-10 - REAL*8 :: JGS_NORM_THR = 1.E-20 - REAL*8 :: SOLVERTHR_SETUP = 1.E-20 - REAL*8 :: CRIT_DEP_SETUP = 0. -! - CHARACTER :: UGOBCFILE*60 - REAL :: UGOBCDEPTH - LOGICAL :: UGOBCOK - -!/RTD REAL :: PLAT, PLON -!/RTD LOGICAL :: UNROT -!/RTD ! Poles of the output nested grids. May be a mix of rotated and standard -!/RTD REAL, DIMENSION(9) :: BPLAT, BPLON -! -!/FLD1 NAMELIST /FLD1/ TAILTYPE, TAILLEV, TAILT1, TAILT2 -!/FLD2 NAMELIST /FLD2/ TAILTYPE, TAILLEV, TAILT1, TAILT2 -!/FLX3 NAMELIST /FLX3/ CDMAX, CTYPE -!/FLX4 NAMELIST /FLX4/ CDFAC -!/IC2 NAMELIST /SIC2/ IC2DISPER, IC2TURB, IC2ROUGH, IC2REYNOLDS, & -!/IC2 IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX -!/IC3 NAMELIST /SIC3/ IC3MAXTHK, IC2TURB, IC2ROUGH, IC2REYNOLDS, & -!/IC3 IC2SMOOTH, IC2VISC, IC2TURBS, IC3MAXCNC, & -!/IC3 IC3CHENG, USECGICE, IC3HILIM, IC3KILIM, & -!/IC3 IC3VISC, IC3ELAS, IC3DENS, IC3HICE -!/IC4 NAMELIST /SIC4/ IC4METHOD, IC4KI, IC4FC -!/IC5 NAMELIST /SIC5/ IC5MINIG, IC5MINWT, IC5MAXKRATIO, & -!/IC5 IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK,& -!/IC5 IC5KFILTER, IC5VEMOD -!/IG1 NAMELIST /SIG1/ IGMETHOD, IGADDOUTP, IGSOURCE, IGBCOVERWRITE, & -!/IG1 IGMAXFREQ, IGSTERMS, IGSWELLMAX, & -!/IG1 IGSOURCEATBP, IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL -!/LN1 NAMELIST /SLN1/ CLIN, RFPM, RFHF -!/ST1 NAMELIST /SIN1/ CINP -!/ST2 NAMELIST /SIN2/ ZWND, SWELLF, STABSH, STABOF, CNEG, CPOS, FNEG -!/ST3 NAMELIST /SIN3/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & -!/ST3 SWELLF -!/ST4 NAMELIST /SIN4/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & -!/ST4 TAUWSHELTER, SWELLFPAR, SWELLF, & -!/ST4 SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, & -!/ST4 SWELLF7, Z0RAT, SINBR -!/NL1 NAMELIST /SNL1/ LAMBDA, NLPROP, KDCONV, KDMIN, & -!/NL1 SNLCS1, SNLCS2, SNLCS3 -!/NL2 NAMELIST /SNL2/ IQTYPE, TAILNL, NDEPTH -!/NL2 NAMELIST /ANL2/ DEPTHS -!/NL3 NAMELIST /SNL3/ NQDEF, MSC, NSC, KDFD, KDFS -!/NL3 NAMELIST /ANL3/ QPARMS -!/NL4 NAMELIST /SNL4/ INDTSA, ALTLP -!/NL5 NAMELIST /SNL5/ NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX -!/NLS NAMELIST /SNLS/ A34, FHFC, DNM, FC1, FC2, FC3 -!/ST1 NAMELIST /SDS1/ CDIS, APM -!/ST2 NAMELIST /SDS2/ SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN -!/ST3 NAMELIST /SDS3/ SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & -!/ST3 SDSDELTA2 -!/ST4 NAMELIST /SDS4/ SDSBCHOICE, WNMEANP, WNMEANPTAIL, FXPM3, FXFM3, & -!/ST4 FXFMAGE, SDSC2, SDSCUM, SDSSTRAIN, SDSSTRAINA, & -!/ST4 SDSSTRAIN2, SDSC4, SDSFACMTF, SDSNMTF,SDSCUMP, & -!/ST4 SDSC5, SDSC6, SDSBR, SDSBT, SDSP, SDSISO, & -!/ST4 SDSBCK, SDSABK, SDSPBK, SDSBINT, SDSHCK, & -!/ST4 SDSDTH, SDSCOS, SDSBRF1, SDSBRFDF, SDSNUW, & -!/ST4 SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & -!/ST4 WHITECAPWIDTH, WHITECAPDUR, SDSMWD, SDSMWPOW, SDKOF - -!/ST6 NAMELIST /SIN6/ SINA0, SINWS, SINFC -!/ST6 NAMELIST /SDS6/ SDSET, SDSA1, SDSA2, SDSP1, SDSP2 -!/ST6 NAMELIST /SWL6/ SWLB1, CSTB1 -!/BT1 NAMELIST /SBT1/ GAMMA -!/BT4 NAMELIST /SBT4/ SEDMAPD50, SED_D50_UNIFORM, RIPFAC1, & -!/BT4 RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & -!/BT4 BOTROUGHMIN, BOTROUGHFAC -!/DB1 NAMELIST /SDB1/ BJALFA, BJGAM, BJFLAG -!/UOST NAMELIST /UOST/ UOSTFILELOCAL, UOSTFILESHADOW, & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW -! -!/PR1 NAMELIST /PRO1/ CFLTM -!/PR2 NAMELIST /PRO2/ CFLTM, DTIME, LATMIN -!/SMC NAMELIST /PSMC/ CFLSM, DTIMS, RFMAXD, Arctic, AVERG, UNO3, & -!/SMC LvSMC, ISHFT, JEQT, NBISMC, SEAWND -! -!/PR3 NAMELIST /PRO3/ CFLTM, WDTHCG, WDTHTH - NAMELIST /UNST/ UGOBCAUTO, UGOBCDEPTH, UGOBCFILE, & - UGBCCFL, EXPFSN, EXPFSPSI, EXPFSFCT, & - IMPFSN, IMPTOTAL, EXPTOTAL, & - IMPREFRACTION, IMPFREQSHIFT, & - IMPSOURCE, & - JGS_TERMINATE_MAXITER, & - JGS_TERMINATE_DIFFERENCE, & - JGS_TERMINATE_NORM, & - JGS_LIMITER, & - JGS_USE_JACOBI, & - JGS_BLOCK_GAUSS_SEIDEL, & - JGS_MAXITER, & - JGS_PMIN, & - JGS_DIFF_THR, & - JGS_NORM_THR, & - JGS_NLEVEL, & - JGS_SOURCE_NONLINEAR, & - SETUP_APPLY_WLV, SOLVERTHR_SETUP, & - CRIT_DEP_SETUP - NAMELIST /MISC/ CICE0, CICEN, LICE, XSEED, FLAGTR, XP, XR, & - XFILT, PMOVE, IHM, HSPM, WSM, WSC, FLC, FMICHE, & - RWNDC, FACBERG, NOSW, GSHIFT, WCOR1, WCOR2, & - STDX, STDY, STDT, ICEHMIN, ICEHINIT, ICEDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, ICEHFAC, & - ICEHDISP, ICEDDISP, ICEFDISP, CALTYPE, & - TRCKCMPR, PTM, PTFC, BTBET - NAMELIST /OUTS/ P2SF, I1P2SF, I2P2SF, & - US3D, I1US3D, I2US3D, & - USSP, IUSSP, STK_WN, & - E3D, I1E3D, I2E3D, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M -!/IS1 NAMELIST /SIS1/ ISC1, ISC2 -!/IS2 NAMELIST /SIS2/ ISC1, IS2C2, IS2C3, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & -!/IS2 IS2DISP, IS2FRAGILITY, IS2CONC, IS2DMIN, & -!/IS2 IS2DAMP, IS2DUPDATE, IS2CREEPB, IS2CREEPC, & -!/IS2 IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, & -!/IS2 IS2WIM1, IS2FLEXSTR, IS2ANDISB, IS2ANDISE, IS2ANDISD, & -!/IS2 IS2ANDISN -!/REF1 NAMELIST /REF1/ REFCOAST, REFFREQ, REFMAP, REFMAPD, & -!/REF1 REFSUBGRID, REFICEBERG, & -!/REF1 REFCOSP_STRAIGHT, REFSLOPE, REFRMAX, & -!/REF1 REFFREQPOW, REFUNSTSOURCE -!/ -!/RTD NAMELIST /ROTD/ PLAT, PLON, UNROT -!/RTD! Poles of destination grids for boundary conditions output -!/RTD NAMELIST /ROTB/ BPLAT, BPLON -!/ -!/ ------------------------------------------------------------------- / -!/ - DATA YESXNO / 'YES/--' , '---/NO' / - - CONTAINS - - SUBROUTINE W3GRID() - -!/O0 FLNMLO = .TRUE. -!/STAB2 FLSTB2 = .TRUE. -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 1. Set up grid storage structure -! - CALL W3NMOD ( 1, 6, 6 ) - CALL W3SETG ( 1, 6, 6 ) - CALL W3NOUT ( 6, 6 ) - CALL W3SETO ( 1, 6, 6 ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 2. IO set-up. -! -!/DEBUGGRID IAPROC = 1 - NDSI = 10 - NDSS = 99 - NDSM = 20 -! - INQUIRE(FILE=TRIM(FNMPRE)//"ww3_grid.nml", EXIST=FLGNML) - IF (FLGNML) THEN - ! Read namelist - CALL W3NMLGRID (NDSI, TRIM(FNMPRE)//'ww3_grid.nml', NML_SPECTRUM, NML_RUN, & - NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & - NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & - NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & - NML_INBND_POINT, NML_EXCL_COUNT, & - NML_EXCL_POINT, NML_EXCL_BODY, & - NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) - ELSE - OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_grid.inp',STATUS='OLD', & - ERR=2000,IOSTAT=IERR) - END IF -! - NDSTRC = 6 - NTRACE = 10 - CALL ITRACE ( NDSTRC, NTRACE ) -! -!/S CALL STRACE (IENT, 'W3GRID') - WRITE (NDSO,900) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3.a Interpolation table for dispersion relation. -! - CALL DISTAB -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 3.b Table for friction factors -! - CALL TABU_FW -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 4 Read and process input file up to spectrum -! - - IF (FLGNML) THEN - ! grid name - GNAME=TRIM(NML_GRID%NAME) - WRITE (NDSO,902) GNAME - - ! spectrum parameters - RXFR=NML_SPECTRUM%XFR - RFR1=NML_SPECTRUM%FREQ1 - NKI=NML_SPECTRUM%NK - NTHI=NML_SPECTRUM%NTH - RTH0=NML_SPECTRUM%THOFF - - ELSE - - READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) COMSTR - IF (COMSTR.EQ.' ') COMSTR = '$' - WRITE (NDSO,901) COMSTR - CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) GNAME - WRITE (NDSO,902) GNAME -! - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) RXFR, RFR1, NKI, NTHI, RTH0 - END IF - - - NK = NKI - NK2 = NKI + 2 - NTH = NTHI - NSPEC = NK * NTH - XFR = MAX ( RXFR , 1.00001 ) - FR1 = MAX ( RFR1 , 1.E-6 ) - DTH = TPI / REAL(NTH) - RTH0 = MAX ( -0.5 , MIN ( 0.5 , RTH0 ) ) - WRITE (NDSO,903) NTH, DTH*RADE - WRITE (NDSO,904) 360./REAL(NTH)*RTH0 - WRITE (NDSO,905) NK, FR1, FR1*XFR**(NK-1), XFR -! - CALL W3DIMS ( 1, NK, NTH, NDSE, NDST ) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 5. Initialize spectral parameters. -! 5.a Directions : -! - DO ITH=1, NTH - TH (ITH) = DTH * ( RTH0 + REAL(ITH-1) ) - ESIN(ITH) = SIN ( TH(ITH) ) - ECOS(ITH) = COS ( TH(ITH) ) - IF ( ABS(ESIN(ITH)) .LT. 1.E-5 ) THEN - ESIN(ITH) = 0. - IF ( ECOS(ITH) .GT. 0.5 ) THEN - ECOS(ITH) = 1. - ELSE - ECOS(ITH) = -1. - END IF - END IF - IF ( ABS(ECOS(ITH)) .LT. 1.E-5 ) THEN - ECOS(ITH) = 0. - IF ( ESIN(ITH) .GT. 0.5 ) THEN - ESIN(ITH) = 1. - ELSE - ESIN(ITH) = -1. - END IF - END IF - ES2 (ITH) = ESIN(ITH)**2 - EC2 (ITH) = ECOS(ITH)**2 - ESC (ITH) = ESIN(ITH)*ECOS(ITH) - END DO -! - DO IK=2, NK+1 - ITH0 = (IK-1)*NTH - DO ITH=1, NTH - ESIN(ITH0+ITH) = ESIN(ITH) - ECOS(ITH0+ITH) = ECOS(ITH) - ES2 (ITH0+ITH) = ES2 (ITH) - EC2 (ITH0+ITH) = EC2 (ITH) - ESC (ITH0+ITH) = ESC (ITH) - END DO - END DO -! -! b Frequencies : -! - SIGMA = FR1 * TPI / XFR**2 - SXFR = 0.5 * (XFR-1./XFR) -! - DO IK=0, NK+1 - SIGMA = SIGMA * XFR - SIG (IK) = SIGMA - DSIP(IK) = SIGMA * SXFR - END DO -! - DSII( 1) = 0.5 * SIG( 1) * (XFR-1.) - DO IK=2, NK-1 - DSII(IK) = DSIP(IK) - END DO - DSII(NK) = 0.5 * SIG(NK) * (XFR-1.) / XFR -! - DO IK=1, NK - DDEN(IK) = DTH * DSII(IK) * SIG(IK) - END DO -! - DO ISP=1, NSPEC - IK = 1 + (ISP-1)/NTH - SIG2 (ISP) = SIG (IK) - DDEN2(ISP) = DDEN(IK) - END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 6 Read and process input file up to numerical parameters -! 6.a Set model flags and time steps -! - WRITE (NDSO,910) - IF (FLGNML) THEN - FLDRY=NML_RUN%FLDRY - FLCX=NML_RUN%FLCX - FLCY=NML_RUN%FLCY - FLCTH=NML_RUN%FLCTH - FLCK=NML_RUN%FLCK - FLSOU=NML_RUN%FLSOU - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) & - FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU - END IF -! - IYN = 2 - IF ( FLDRY ) IYN(1) = 1 - IF ( FLCX ) IYN(2) = 1 - IF ( FLCY ) IYN(3) = 1 - IF ( FLCTH ) IYN(4) = 1 - IF ( FLCK ) IYN(5) = 1 - IF ( FLSOU ) IYN(6) = 1 -! - WRITE (NDSO,911) (YESXNO(IYN(IFL)),IFL=1,NFL) -! - IF ( .NOT. (FLDRY.OR.FLCX.OR.FLCY.OR.FLCK.OR.FLCTH.OR.FLSOU) ) THEN - WRITE (NDSE,1010) - CALL EXTCDE ( 2 ) - END IF -! - IF (FLGNML) THEN - DTMAX=NML_TIMESTEPS%DTMAX - DTCFL=NML_TIMESTEPS%DTXY - DTCFLI=NML_TIMESTEPS%DTKTH - DTMIN=NML_TIMESTEPS%DTMIN - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) DTMAX, DTCFL, DTCFLI, DTMIN - END IF -!/SEC1 IF (DTMAX.LT.1.) THEN -!/SEC1 NITERSEC1=CEILING(1./DTMAX) -!/SEC1 WRITE (NDSO,913) NITERSEC1 -!/SEC1 ELSE -!/SEC1 NITERSEC1=1 -!/SEC1 END IF - - DTMAX = MAX ( 1. , DTMAX ) -! -! Commented to allow very high resolution zooms -! -! DTCFL = MAX ( 1. , DTCFL ) -! DTCFLI = MIN ( DTMAX , MAX ( 1. , DTCFLI ) ) - DTMIN = MIN ( DTMAX , MAX ( 0. , DTMIN ) ) - WRITE (NDSO,912) DTMAX, DTCFL, DTCFLI, DTMIN -! -! 6.b Set / select source term package -! - NRLIN = 0 - NRSRCE = 0 - NRNL = 0 - NRBT = 0 - NRIC = 0 - NRIS = 0 - NRDB = 0 - NRTR = 0 - NRBS = 0 -! - FLLIN = .TRUE. - FLINDS = .TRUE. - FLNL = .TRUE. - FLBT = .TRUE. - FLIC = .FALSE. - FLIS = .FALSE. - FLDB = .TRUE. - FLTR = .TRUE. - FLBS = .TRUE. - FLREF = .FALSE. -! -!/LN0 NRLIN = NRLIN + 1 -!/LN0 FLLIN = .FALSE. -!/SEED NRLIN = NRLIN + 1 -!/LN1 NRLIN = NRLIN + 1 -! -!/ST0 NRSRCE = NRSRCE + 1 -!/ST0 FLINDS = .FALSE. -!/ST1 NRSRCE = NRSRCE + 1 -!/ST2 NRSRCE = NRSRCE + 1 -!/ST2 FLTC96 = .TRUE. -!/ST3 NRSRCE = NRSRCE + 1 -!/ST4 NRSRCE = NRSRCE + 1 -!/ST4 FLST4 = .TRUE. -!/ST6 NRSRCE = NRSRCE + 1 -!/ST6 FLST6 = .TRUE. -! -!/NL0 NRNL = NRNL + 1 -!/NL0 FLNL = .FALSE. -!/NL1 NRNL = NRNL + 1 -!/NL2 NRNL = NRNL + 1 -!/NL3 NRNL = NRNL + 1 -!/NL4 NRNL = NRNL + 1 -!/NL5 NRNL = NRNL + 1 -! -!/BT0 NRBT = NRBT + 1 -!/BT0 FLBT = .FALSE. -!/BT1 NRBT = NRBT + 1 -!/BT4 NRBT = NRBT + 1 -!/BT8 NRBT = NRBT + 1 -!/BT9 NRBT = NRBT + 1 -! -!/IC1 NRIC = NRIC + 1 -!/IC1 FLIC = .TRUE. -!/IC2 NRIC = NRIC + 1 -!/IC2 FLIC = .TRUE. -!/IC3 NRIC = NRIC + 1 -!/IC3 FLIC = .TRUE. -!/IC4 NRIC = NRIC + 1 -!/IC4 FLIC = .TRUE. -!/IC5 NRIC = NRIC + 1 -!/IC5 FLIC = .TRUE. -! -!/IS1 NRIS = NRIS + 1 -!/IS1 FLIS = .TRUE. -!/IS2 NRIS = NRIS + 1 -!/IS2 FLIS = .TRUE. -! -!/DB0 NRDB = NRDB + 1 -!/DB0 FLDB = .FALSE. -!/DB1 NRDB = NRDB + 1 -! -!/TR0 NRTR = NRTR + 1 -!/TR0 FLTR = .FALSE. -!/TR1 NRTR = NRTR + 1 -! -!/BS0 NRBS = NRBS + 1 -!/BS0 FLBS = .FALSE. -!/BS1 NRBS = NRBS + 1 -! -!/REF1 FLREF = .TRUE. -! - IF ( .NOT.FLLIN .AND. .NOT.FLINDS .AND. .NOT.FLNL .AND. & - .NOT.FLBT .AND. .NOT.FLIC .AND. .NOT.FLIS .AND. & - .NOT.FLDB .AND. .NOT.FLTR .AND. .NOT.FLBS .AND. & - .NOT.FLREF .AND. FLSOU ) THEN - WRITE (NDSE,1020) - CALL EXTCDE ( 10 ) - END IF -! - IF ( ( FLLIN .OR. FLINDS .OR. FLNL .OR. FLBT .OR. FLDB .OR. & - FLTR .OR. FLBS .OR. FLREF .OR. FLIC ) & - .AND. .NOT.FLSOU ) THEN - WRITE (NDSE,1021) - END IF -! - IF ( NRLIN .NE. 1 ) THEN - WRITE (NDSE,1022) NRLIN - CALL EXTCDE ( 11 ) - END IF -! - IF ( NRSRCE .NE. 1 ) THEN - WRITE (NDSE,1023) NRSRCE - CALL EXTCDE ( 12 ) - END IF -! - IF ( NRNL .NE. 1 ) THEN - WRITE (NDSE,1024) NRNL - CALL EXTCDE ( 13 ) - END IF -! - IF ( NRBT .NE. 1 ) THEN - WRITE (NDSE,1025) NRBT - CALL EXTCDE ( 14 ) - END IF -! - IF ( NRDB .NE. 1 ) THEN - WRITE (NDSE,1026) NRDB - CALL EXTCDE ( 15 ) - END IF -! - IF ( NRTR .NE. 1 ) THEN - WRITE (NDSE,1027) NRTR - CALL EXTCDE ( 16 ) - END IF -! - IF ( NRBS .NE. 1 ) THEN - WRITE (NDSE,1028) NRBS - CALL EXTCDE ( 17 ) - END IF -! - IF ( NRIC .GT. 1 ) THEN - WRITE (NDSE,1034) NRIC - CALL EXTCDE ( 19 ) - END IF -! - IF ( NRIS .GT. 1 ) THEN - WRITE (NDSE,1036) NRIS - CALL EXTCDE ( 26 ) - END IF - - -! -! 6.c Read namelist file or Pre-process namelists into scratch file -! - WRITE (NDSO,915) - IF (FLGNML) THEN - OPEN (NDSS,FILE=TRIM(FNMPRE)//TRIM(NML_GRID%NML),STATUS='OLD',FORM='FORMATTED') - ELSE - OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') - DO - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,'(A)',END=2001,ERR=2002) LINE - IF ( LINE(1:16) .EQ. 'END OF NAMELISTS' ) THEN - EXIT - ELSE - WRITE (NDSS,'(A)') LINE - ENDIF - END DO - END IF - WRITE (NDSO,916) -! -! 6.d Define Sin. -! 6.d.1 Stresses -! -!/FLX1 WRITE (NDSO,810) -!/FLX2 WRITE (NDSO,810) -! -!/FLX2 CINXSI = 0.20 -!/FLX2 NITTIN = 3 -!/FLX3 CINXSI = 0.20 -!/FLX3 NITTIN = 3 -!/FLX3 CDMAX = 2.5E-3 -!/FLX3 CTYPE = 0 -! -!/FLX3 CALL READNL ( NDSS, 'FLX3', STATUS ) -!/FLX3 WRITE (NDSO,810) STATUS -!/FLX3 CDMAX = MAX ( 0. , CDMAX ) -!/FLX3 IF ( CTYPE .EQ. 1 ) THEN -!/FLX3 TYPEID = 'hyperbolic tangent' -!/FLX3 ELSE -!/FLX3 CTYPE = 0 -!/FLX3 TYPEID = 'discontinuous ' -!/FLX3 END IF -!/FLX3 WRITE (NDSO,811) CDMAX*1.E3, TYPEID -!/FLX3 CD_MAX = CDMAX -!/FLX3 CAP_ID = CTYPE -! -!/FLX4 CDFAC = 1.0 -!/FLX4 CALL READNL ( NDSS, 'FLX4', STATUS ) -!/FLX4 WRITE (NDSO,810) STATUS -!/FLX4 WRITE (NDSO,811) CDFAC -!/FLX4 FLX4A0 = CDFAC -!/FLX5 WRITE (NDSO,810) -! -! 6.d.2 Linear input -! -!/LN0 WRITE (NDSO,820) -!/SEED WRITE (NDSO,820) -! -!/LN1 CLIN = 80. -!/LN1 RFPM = 1. -!/LN1 RFHF = 0.5 -! -!/LN1 CALL READNL ( NDSS, 'SLN1', STATUS ) -!/LN1 WRITE (NDSO,820) STATUS -!/LN1 CLIN = MAX (0.,CLIN) -!/LN1 RFPM = MAX (0.,RFPM) -!/LN1 RFHF = MAX(0.,MIN (1.,RFHF)) -!/LN1 WRITE (NDSO,821) CLIN, RFPM, RFHF -!/LN1 SLNC1 = CLIN * (DAIR/DWAT)**2 / GRAV**2 -!/LN1 FSPM = RFPM -!/LN1 FSHF = RFHF -! -! 6.d.3 Exponential input -! -!/ST0 WRITE (NDSO,920) -! -!/ST1 CINP = 0.25 -!/ST2 ZWND = 10. -!/ST2 SWELLF = 0.100 -!/ST2 STABSH = 1.38 -!/ST2 STABOF = -0.01 -!/ST2 CNEG = -0.1 -!/ST2 CPOS = 0.1 -!/ST2 FNEG = 150. -! -!/ST3 ZWND = 10. -!/ST3 ALPHA0 = 0.0095 -!/ST3 Z0MAX = 0.0 -!/ST3 BETAMAX = 1.2 ! default WAM4 / WAM4 + is 1.2 with rhow=1000 -!/ST3 SINTHP = 2. -!/ST3 SWELLF = 0. -!/ST3 ZALP = 0.0110 -! -!/ST4 ZWND = 10. -!/ST4 ALPHA0 = 0.0095 -!/ST4 Z0MAX = 0.0 -!/ST4 Z0RAT = 0.04 -!/ST4 BETAMAX = 1.43 -!/ST4 SINTHP = 2. -!/ST4 SWELLF = 0.66 -!/ST4 SWELLFPAR = 1 -!/ST4 SWELLF2 = -0.018 -!/ST4 SWELLF3 = 0.022 -!/ST4 SWELLF4 = 1.5E5 -!/ST4 SWELLF5 = 1.2 -!/ST4 SWELLF6 = 0. -!/ST4 SWELLF7 = 360000. -!/ST4 TAUWSHELTER = 0.3 -!/ST4 ZALP = 0.006 -!/ST4 SINBR = 0. -! -!/ST6 SINA0 = 0.09 -!/ST6 SINWS = 32.0 -!/ST6 SINFC = 6.0 -! -!/ST1 CALL READNL ( NDSS, 'SIN1', STATUS ) -!/ST1 WRITE (NDSO,920) STATUS -!/ST1 WRITE (NDSO,921) CINP -!/ST1 SINC1 = 28. * CINP * DAIR / DWAT -! -!/ST2 CALL READNL ( NDSS, 'SIN2', STATUS ) -!/ST2 WRITE (NDSO,920) STATUS -!/ST2 IF ( SWELLF.LT.0. .OR. SWELLF.GT.1. ) SWELLF = 1. -!/ST2 WRITE (NDSO,921) ZWND, SWELLF -!/ST2 IF ( STABSH .LT. 0.1 ) STABSH = 1. -!/ST2 IF ( CNEG*CPOS .EQ. 0. ) THEN -!/ST2 CNEG = 0. -!/ST2 CPOS = 0. -!/ST2 FNEG = 0. -!/ST2 FPOS = 0. -!/ST2 ELSE -!/ST2 CPOS = - ABS(CPOS) * ABS(CNEG)/CNEG -!/ST2 FNEG = - MAX(1.,ABS(FNEG)) -!/ST2 FPOS = FNEG * CNEG/CPOS -!/ST2 END IF -!/STAB2 WRITE (NDSO,1921) STABSH, STABOF, CNEG, CPOS, FNEG, FPOS -!/ST2 ZWIND = ZWND -!/ST2 FSWELL = SWELLF -!/ST2 SHSTAB = STABSH -!/ST2 OFSTAB = STABOF -!/ST2 CCNG = CNEG -!/ST2 CCPS = CPOS -!/ST2 FFNG = FNEG -!/ST2 FFPS = FPOS -! -!/ST3 CALL READNL ( NDSS, 'SIN3', STATUS ) -!/ST3 WRITE (NDSO,920) STATUS -!/ST3 WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, & -!/ST3 SWELLF -!/ST3 ZZWND = ZWND -!/ST3 AALPHA = ALPHA0 -!/ST3 BBETA = BETAMAX -!/ST3 SSINTHP = SINTHP -!/ST3 ZZ0MAX = Z0MAX -!/ST3 ZZALP = ZALP -!/ST3 SSWELLF(1) = SWELLF -! -!/ST4 CALL READNL ( NDSS, 'SIN4', STATUS ) -!/ST4 WRITE (NDSO,920) STATUS -!/ST4 WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, TAUWSHELTER, & -!/ST4 SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & -!/ST4 SWELLF6, SWELLF7, Z0RAT -!/ST4 ZZWND = ZWND -!/ST4 AALPHA = ALPHA0 -!/ST4 BBETA = BETAMAX -!/ST4 SSINBR = SINBR -!/ST4 SSINTHP = SINTHP -!/ST4 ZZ0MAX = Z0MAX -!/ST4 ZZ0RAT = Z0RAT -!/ST4 ZZALP = ZALP -!/ST4 TTAUWSHELTER = TAUWSHELTER -!/ST4 SSWELLF(1) = SWELLF -!/ST4 SSWELLF(2) = SWELLF2 -!/ST4 SSWELLF(3) = SWELLF3 -!/ST4 SSWELLF(4) = SWELLF4 -!/ST4 SSWELLF(5) = SWELLF5 -!/ST4 SSWELLF(6) = SWELLF6 -!/ST4 SSWELLF(7) = SWELLF7 -!/ST4 SSWELLFPAR = SWELLFPAR -! -!/ST6 CALL READNL ( NDSS, 'SIN6', STATUS ) -!/ST6 WRITE (NDSO,920) STATUS -!/ST6 SIN6A0 = SINA0 -!/ST6 SIN6WS = SINWS -!/ST6 SIN6FC = SINFC -!/ST6 J = 1 -!/ST6 IF ( SIN6A0.LE.0. ) J = 2 -!/ST6 WRITE (NDSO,921) YESXNO(J), SIN6A0, SIN6WS, SIN6FC -! -! 6.e Define Snl. -! -!/NL0 WRITE (NDSO,922) -! -!/NL1 LAMBDA = 0.25 -!/NL1 IF ( FLTC96 ) THEN -!/NL1 NLPROP = 1.00E7 -!/NL1 ELSE IF ( FLST4 ) THEN -!/NL1 NLPROP = 2.50E7 -!/NL1 ELSE IF ( FLST6 ) THEN -!/NL1 NLPROP = 3.00E7 -!/NL1 ELSE -!/NL1 NLPROP = 2.78E7 -!/NL1 END IF -! -!/NL1 KDCONV = 0.75 -!/NL1 KDMIN = 0.50 -!/NL1 SNLCS1 = 5.5 -!/NL1 SNLCS2 = 0.833 -!/NL1 SNLCS3 = -1.25 -! -!/NL1 CALL READNL ( NDSS, 'SNL1', STATUS ) -!/NL1 WRITE (NDSO,922) STATUS -!/NL1 WRITE (NDSO,923) LAMBDA, NLPROP, KDCONV, KDMIN, & -!/NL1 SNLCS1, SNLCS2, SNLCS3 -!/NL1 SNLC1 = NLPROP / GRAV**4 -!/NL1 LAM = LAMBDA -!/NL1 KDCON = KDCONV -!/NL1 KDMN = KDMIN -!/NL1 SNLS1 = SNLCS1 -!/NL1 SNLS2 = SNLCS2 -!/NL1 SNLS3 = SNLCS3 -! -!/ST0 FACHF = 5. -!/ST1 FACHF = 4.5 -!/ST2 FACHF = 5. -!/ST3 FACHF = 5. -!/ST4 FACHF = 5. -!/ST6 FACHF = 5. -!/NL2 IQTYPE = 2 -!/NL2 TAILNL = -FACHF -!/NL2 NDEPTH = 0 -!/NL3 NQDEF = 0 -!/NL3 MSC = 0. -!/NL3 NSC = -3.5 -!/NL3 KDFD = 0.20 -!/NL3 KDFS = 5.00 -!/NL4 INDTSA = 1 -!/NL4 ALTLP = 2 -!/NL5 NL5DPT = 3000. -!/NL5 NL5OML = 0.10 -!/NL5 NL5DIS = 0 -!/NL5 NL5KEV = 0 -!/NL5 NL5IPL = 1 -!/NL5 NL5PMX = 100 -!/NLS A34 = 0.05 -!/NLS FHFC = 1.E10 -!/NLS DNM = 0.25 -!/NLS FC1 = 1.25 -!/NLS FC2 = 1.50 -!/NLS FC3 = 6.00 -! -!/NL2 CALL READNL ( NDSS, 'SNL2', STATUS ) -!/NL2 WRITE (NDSO,922) STATUS -!/NL2 TAILNL = MIN ( MAX ( TAILNL, -5. ) , -4. ) -!/NL2 IF ( IQTYPE .EQ. 3 ) THEN -!/NL2 WRITE (NDSO,923) 'Shallow water', TAILNL -!/NL2 ELSE IF ( IQTYPE .EQ. 2 ) THEN -!/NL2 WRITE (NDSO,923) 'Deep water with scaling', TAILNL -!/NL2 ELSE -!/NL2 WRITE (NDSO,923) 'Deep water', TAILNL -!/NL2 IQTYPE = 1 -!/NL2 END IF -! -!/NL2 IF ( IQTYPE .NE. 3 ) THEN -!/NL2 NDEPTH = 1 -!/NL2 ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) -!/NL2 DPTHNL => MPARS(1)%SNLPS%DPTHNL -!/NL2 DPTHNL = 1000. -!/NL2 ELSE -!/NL2 IF ( NDEPTH .EQ. 0 ) NDEPTH = 7 -!/NL2 NDEPTH = MAX ( 1 , NDEPTH ) -!/NL2 ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) -!/NL2 DPTHNL => MPARS(1)%SNLPS%DPTHNL -!/NL2 DPTHNL(1) = 640. -!/NL2 DPTHNL(NDEPTH) = 10. -!/NL2 IF ( NDEPTH .GT. 1 ) THEN -!/NL2 DPTFAC = (DPTHNL(NDEPTH)/DPTHNL(1))**(1./(REAL(NDEPTH-1))) -!/NL2 DO IDEPTH=2, NDEPTH-1 -!/NL2 DPTHNL(IDEPTH) = DPTFAC*DPTHNL(IDEPTH-1) -!/NL2 END DO -!/NL2 END IF -!/NL2 CALL READNL ( NDSS, 'ANL2', STATUS ) -!/NL2 WRITE (NDSO,1923) NDEPTH, DPTHNL(1:MIN(5,NDEPTH)) -!/NL2 IF (NDEPTH .GT. 5 )WRITE (NDSO,2923) DPTHNL(6:NDEPTH) -!/NL2 END IF -!/NL2 WRITE (NDST,*) -!/NL2 IQTPE = IQTYPE -!/NL2 NDPTHS = NDEPTH -!/NL2 NLTAIL = TAILNL -! -!/NL3 CALL READNL ( NDSS, 'SNL3', STATUS ) -!/NL3 WRITE (NDSO,922) STATUS -!!/NL3 MSC = MAX ( 0. , MIN ( 8. , MSC ) ) ! Disabled HLT ca. 2009 -!/NL3 KDFD = MAX ( 0.001 , MIN ( 10. , KDFD ) ) -!/NL3 KDFS = MAX ( KDFD , MIN ( 10. , KDFS ) ) -!/NL3 WRITE (NDSO,923) MSC, NSC, KDFD, KDFS -! -!/NL3 NQDEF = MAX ( 0 , NQDEF ) -!/NL3 IF ( NQDEF .EQ. 0 ) THEN -!/NL3 NQDEF = 1 -!/NL3 QPARMS(1:5) = [ 0.25 , 0.00, -1., 1.E7, 0.00 ] -!/NL3 ELSE -!/NL3 DO J=1, NQDEF -!/NL3 QPARMS((J-1)*5+1:J*5) = [ 0.25, 0.00, -1., 1.E7, 1.E6 ] -!/NL3 END DO -!/NL3 CALL READNL ( NDSS, 'ANL3', STATUS ) -!/NL3 END IF -!/NL3 DO J=1, NQDEF -!/NL3 QPARMS((J-1)*5+1) = MAX(0.,MIN (LAMMAX,QPARMS((J-1)*5+1))) -!/NL3 QPARMS((J-1)*5+2) = MAX(0.,MIN (QPARMS((J-1)*5+1), & -!/NL3 QPARMS((J-1)*5+2))) -!/NL3 QPARMS((J-1)*5+3) = MIN (DELTHM,QPARMS((J-1)*5+3)) -!/NL3 QPARMS((J-1)*5+4) = MAX (0.,QPARMS((J-1)*5+4)) -!/NL3 QPARMS((J-1)*5+5) = MAX (0.,QPARMS((J-1)*5+5)) -!/NL3 END DO -!/NL3 WRITE (NDSO,1923) NQDEF -!/NL3 WRITE (NDSO,2923) QPARMS(1:NQDEF*5) -!/NL3 WRITE (NDSO,*) -!/NL3 SNLNQ = NQDEF -!/NL3 SNLMSC = MSC -!/NL3 SNLNSC = NSC -!/NL3 SNLSFD = SQRT ( KDFD * TANH(KDFD) ) -!/NL3 SNLSFS = SQRT ( KDFS * TANH(KDFS) ) -!/NL3 ALLOCATE ( MPARS(1)%SNLPS%SNLL(NQDEF), & -!/NL3 MPARS(1)%SNLPS%SNLM(NQDEF), & -!/NL3 MPARS(1)%SNLPS%SNLT(NQDEF), & -!/NL3 MPARS(1)%SNLPS%SNLCD(NQDEF), & -!/NL3 MPARS(1)%SNLPS%SNLCS(NQDEF) ) -!/NL3 SNLL => MPARS(1)%SNLPS%SNLL -!/NL3 SNLL = QPARMS(1:NQDEF*5:5) -!/NL3 SNLM => MPARS(1)%SNLPS%SNLM -!/NL3 SNLM = QPARMS(2:NQDEF*5:5) -!/NL3 SNLT => MPARS(1)%SNLPS%SNLT -!/NL3 SNLT = QPARMS(3:NQDEF*5:5) -!/NL3 SNLCD => MPARS(1)%SNLPS%SNLCD -!/NL3 SNLCD = QPARMS(4:NQDEF*5:5) -!/NL3 SNLCS => MPARS(1)%SNLPS%SNLCS -!/NL3 SNLCS = QPARMS(5:NQDEF*5:5) -! -!/NL4 CALL READNL ( NDSS, 'SNL4', STATUS ) -!/NL4 WRITE (NDSO,922) STATUS -!/NL4 WRITE (NDSO,923) INDTSA, ALTLP -!/NL4 ITSA = INDTSA -!/NL4 IALT = ALTLP -! -!/NL5 CALL READNL ( NDSS, 'SNL5', STATUS ) -!/NL5 WRITE (NDSO,922) STATUS -!/NL5 NL5DPT = MAX(0., MIN(NL5DPT, 3000.)) -!/NL5 NL5DIS = MAX(0 , MIN(NL5DIS, 1)) -!/NL5 NL5KEV = MAX(0 , MIN(NL5KEV, 1)) -!/NL5 NL5IPL = MAX(0 , MIN(NL5IPL, 1)) -!/NL5 IF (NL5DIS .EQ. 1) NL5IPL = 0 -!/NL5 IF (NL5PMX .GT. 0) NL5PMX = MAX(10, NL5PMX) -!/NL5 WRITE (NDSO,923) NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX -!/NL5 QR5DPT = NL5DPT -!/NL5 QR5OML = NL5OML -!/NL5 QI5DIS = NL5DIS -!/NL5 QI5KEV = NL5KEV -!/NL5 QI5IPL = NL5IPL -!/NL5 QI5PMX = NL5PMX -! -!/NLS CALL READNL ( NDSS, 'SNLS', STATUS ) -!/NLS WRITE (NDSO,9922) STATUS -!/NLS A34 = MAX ( 0. , MIN ( A34 , ABMAX ) ) -!/NLS FHFC = MAX ( 0. , FHFC ) -!/NLS DNM = MAX ( 0., DNM ) -!/NLS WRITE (NDSO,9923) A34, (XFR-1.)*A34, FHFC, DNM, FC1, FC2, FC3 -!/NLS CNLSA = A34 -!/NLS CNLSC = FHFC -!/NLS CNLSFM = DNM -!/NLS CNLSC1 = FC1 -!/NLS CNLSC2 = FC2 -!/NLS CNLSC3 = FC3 -! -! 6.f Define Sds. -! -!/ST0 WRITE (NDSO,924) -! -!/ST1 CDIS = -2.36E-5 -!/ST1 APM = 3.02E-3 -!/ST2 SDSA0 = 4.8 -!/ST2 SDSA1 = 1.7e-4 -!/ST2 SDSA2 = 2.0 -!/ST2 SDSB0 = 0.3e-3 -!/ST2 SDSB1 = 0.47 -!/ST2 PHIMIN = 0.003 -!/ST2 SDSALN = 0.002 -!/ST2 FPIMIN = 0.009 -!/ST3 SDSC1 = -2.1 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -4.5 -!/ST3 WNMEANP = 0.5 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -0.5 -!/ST3 FXFM3 = 2.5 -!/ST3 FXPM3 = 4. -!/ST3 WNMEANPTAIL = 0.5 -!/ST3 SDSDELTA1 = 0.4 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 -!/ST3 SDSDELTA2 = 0.6 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 -! -!/ST4 WNMEANP = 0.5 ! taken from Bidlot et al. 2005 -!/ST4 FXFM3 = 2.5 -!/ST4 FXFMAGE = 0. -!/ST4 FXPM3 = 4. -!/ST4 WNMEANPTAIL = -0.5 -!/ST4 SDSBCHOICE =1 ! 1: Ardhuin et al., 2: Filipot & Ardhuin, 3: Romero -!/ST4 SDSC2 = -2.2E-5 ! -3.8 for Romero -!/ST4 SDSCUM = -0.40344 -!/ST4 SDSC4 = 1. -!/ST4 SDSC5 = 0. -!/ST4 SDSNUW = 0. -!/ST4 SDSC6 = 0.3 -!/ST4 SDSBR = 0.90E-3 ! 0.005 for Romero -!/ST4 SDSBRFDF = 0 -!/ST4 SDSBRF1 = 0.5 -!/ST4 SDSP = 2. ! this is now fixed in w3sds4, should be cleaned up -!/ST4 SDSDTH = 80. -!/ST4 SDSCOS = 2. -!/ST4 SDSISO = 2 -!/ST4 SDSBM0 = 1. -!/ST4 SDSBM1 = 0. -!/ST4 SDSBM2 = 0. -!/ST4 SDSBM3 = 0. -!/ST4 SDSBM4 = 0. -!/ST4 SDSBCK = 0. -!/ST4 SDSABK = 1.5 -!/ST4 SDSPBK = 4. -!/ST4 SDSBINT = 0.3 -!/ST4 SDSHCK = 1.5 -!/ST4 WHITECAPWIDTH = 0.3 -!/ST4 SDSSTRAIN = 0. -!/ST4 SDSFACMTF = 400 ! MTF factor for Lambda , Romero (2019) -!/ST4 SDSSTRAINA = 15. -!/ST4 SDSSTRAIN2 = 0. -!/ST4 WHITECAPDUR = 0.56 ! breaking duration factor -!/ST4! b (strength of breaking) -!/ST4 SDSBT = 1.100E-3 ! B_T (sturation threshold for dissipation rate b) -!/ST4! Lambda parameters -!/ST4 SDSL = 3.5000e-05 ! L scaling -!/ST4! MTF -!/ST4 SPMSS = 0.5 ! cmss^SPMSS -!/ST4 SDSNMTF = 1.5 ! MTF power -!/ST4 SDSCUMP = 2. -!/ST4! MW -!/ST4 SDSMWD = .9 ! new AFo -!/ST4 SDSMWPOW = 1. ! (k )^pow -!/ST4 SDKOF = 3. ! ko factor such that ko= g (SDKOF/(28 us))^2 -! -!/ST6 SDSET = .TRUE. -!/ST6 SDSA1 = 4.75E-06 -!/ST6 SDSP1 = 4 -!/ST6 SDSA2 = 7.00E-05 -!/ST6 SDSP2 = 4 -!/ST6 CSTB1 = .FALSE. -!/ST6 SWLB1 = 0.41E-02 -! -!/ST1 CALL READNL ( NDSS, 'SDS1', STATUS ) -!/ST1 WRITE (NDSO,924) STATUS -!/ST1 WRITE (NDSO,925) CDIS, APM -!/ST1 SDSC1 = TPI * CDIS / APM**2 -! -!/ST2 CALL READNL ( NDSS, 'SDS2', STATUS ) -!/ST2 WRITE (NDSO,924) STATUS -!/ST2 IF ( PHIMIN .LE. 0. ) THEN -!/ST2 SDSB2 = 0. -!/ST2 SDSB3 = 0. -!/ST2 PHIMIN = SDSB0 + SDSB1*FPIMIN -!/ST2 ELSE -!/ST2 FPIA = ( PHIMIN - SDSB0 ) / SDSB1 -!/ST2 IF ( FPIA .LT. FPIMIN ) THEN -!/ST2 SDSB3 = 4. -!/ST2 SDSB2 = FPIMIN**SDSB3 * (PHIMIN-SDSB0-SDSB1*FPIMIN) -!/ST2 ELSE -!/ST2 FPIB = MAX ( FPIA-0.0025 , FPIMIN ) -!/ST2 DPHID = MAX ( PHIMIN - SDSB0 - SDSB1*FPIB , 1.E-15 ) -!/ST2 SDSB3 = MIN ( 10. , SDSB1*FPIB / DPHID ) -!/ST2 SDSB2 = FPIB**SDSB3 * DPHID -!/ST2 FPIMIN = FPIB -!/ST2 END IF -!/ST2 END IF -!/ST2 WRITE (NDSO,925) SDSA0, SDSA1, SDSA2, & -!/ST2 SDSB0, SDSB1, SDSB2, SDSB3, FPIMIN, PHIMIN -!/ST2 CDSA0 = SDSA0 -!/ST2 CDSA1 = SDSA1 -!/ST2 CDSA2 = SDSA2 -!/ST2 CDSB0 = SDSB0 -!/ST2 CDSB1 = SDSB1 -!/ST2 CDSB2 = SDSB2 -!/ST2 CDSB3 = SDSB3 -! -!/ST3 CALL READNL ( NDSS, 'SDS3', STATUS ) -!/ST3 WRITE (NDSO,924) STATUS -!/ST3 WRITE (NDSO,925) SDSC1, WNMEANP, SDSDELTA1, & -!/ST3 SDSDELTA2 -!/ST3 SSDSC1 = SDSC1 -!/ST3 WWNMEANP = WNMEANP -!/ST3 FFXFM = FXFM3 * TPI -!/ST3 FFXPM = FXPM3 * GRAV / 28. -!/ST3 WWNMEANPTAIL = WNMEANPTAIL -!/ST3 DDELTA1 = SDSDELTA1 -!/ST3 DDELTA2 = SDSDELTA2 -! -!/ST4 CALL READNL ( NDSS, 'SDS4', STATUS ) -!/ST4 WRITE (NDSO,924) STATUS -!/ST4 WRITE (NDSO,925) SDSC2, SDSBCK, SDSCUM, WNMEANP -!/ST4 SSDSC(1) = REAL(SDSBCHOICE) -!/ST4 SSDSC(2) = SDSC2 -!/ST4 SSDSC(3) = SDSCUM -!/ST4 SSDSC(4) = SDSC4 -!/ST4 SSDSC(5) = SDSC5 -!/ST4 SSDSC(6) = SDSC6 -!/ST4 SSDSC(7) = WHITECAPWIDTH -!/ST4 SSDSC(8) = SDSSTRAIN ! Straining constant ... -!/ST4 SSDSC(9) = SDSL -!/ST4 SSDSC(10) = SDSSTRAINA*NTH/360. ! angle Aor enhanced straining -!/ST4 SSDSC(11) = SDSSTRAIN2 ! straining constant for directional part -!/ST4 SSDSC(12) = SDSBT -!/ST4 SSDSC(13) = SDSMWD -!/ST4 SSDSC(14) = SPMSS -!/ST4 SSDSC(15) = SDSMWPOW -!/ST4 SSDSC(16) = SDKOF -!/ST4 SSDSC(17) = WHITECAPDUR -!/ST4 SSDSC(18) = SDSFACMTF -!/ST4 SSDSC(19) = SDSNMTF -!/ST4 SSDSC(20) = SDSCUMP -!/ST4 SSDSC(21) = SDSNUW -! -!/ST4 SSDSBR = SDSBR -!/ST4 SSDSBRF1 = SDSBRF1 -!/ST4 SSDSBRFDF= SDSBRFDF -!/ST4 SSDSBM(0) = SDSBM0 -!/ST4 SSDSBM(1) = SDSBM1 -!/ST4 SSDSBM(2) = SDSBM2 -!/ST4 SSDSBM(3) = SDSBM3 -!/ST4 SSDSBM(4) = SDSBM4 -!/ST4 SSDSBT = SDSBT -!/ST4 SSDSISO = SDSISO -!/ST4 SSDSCOS = SDSCOS -!/ST4 SSDSP = SDSP -!/ST4 SSDSDTH = SDSDTH -!/ST4 WWNMEANP = WNMEANP -!/ST4 FFXFM = FXFM3 * TPI -!/ST4 FFXFA = FXFMAGE * TPI -!/ST4 FFXPM = FXPM3 * GRAV / 28. -!/ST4 WWNMEANPTAIL = WNMEANPTAIL -!/ST4 SSDSBCK = SDSBCK -!/ST4 SSDSABK = SDSABK -!/ST4 SSDSPBK = SDSPBK -!/ST4 SSDSBINT = SDSBINT -!/ST4 SSDSHCK = SDSHCK -! -!/ST6 CALL READNL ( NDSS, 'SDS6', STATUS ) -!/ST6 WRITE (NDSO,924) STATUS -!/ST6 SDS6ET = SDSET -!/ST6 SDS6A1 = SDSA1 -!/ST6 SDS6P1 = SDSP1 -!/ST6 SDS6A2 = SDSA2 -!/ST6 SDS6P2 = SDSP2 -!/ST6 J = 2 -!/ST6 IF (SDSET) J = 1 -!/ST6 WRITE (NDSO,925) YESXNO(J), YESXNO(3-J), SDS6A1, SDS6P1, SDS6A2, SDS6P2 -!/ST6 -!/ST6 CALL READNL ( NDSS, 'SWL6', STATUS ) -!/ST6 WRITE (NDSO,937) STATUS -!/ST6 J = 1 -!/ST6 SWL6S6 = SWLB1.GT.0.0 -!/ST6 IF (.NOT.SWL6S6) J = 2 -!/ST6 SWL6B1 = SWLB1 -!/ST6 SWL6CSTB1 = CSTB1 -!/ST6 IF (CSTB1) THEN -!/ST6 WRITE (NDSO,940) YESXNO(J), '(constant) ' ,SWL6B1 -!/ST6 ELSE -!/ST6 WRITE (NDSO,940) YESXNO(J), '(steepness dependent)' ,SWL6B1 -!/ST6 END IF -! -! 6.g Define Sbt. -! -!/BT0 WRITE (NDSO,926) -!/BT4 WRITE (NDSO,926) -! -!/BT1 GAMMA = -0.067 -! -!/BT1 CALL READNL ( NDSS, 'SBT1', STATUS ) -!/BT1 WRITE (NDSO,926) STATUS -!/BT1 WRITE (NDSO,927) GAMMA -!/BT1 SBTC1 = 2. * GAMMA / GRAV -! -!/BT4 SEDMAPD50=.FALSE. -!/BT4 SED_D50_UNIFORM=2.E-4 ! default grain size: medium sand 200 microns -!/BT4 RIPFAC1=0.4 ! A1 in Ardhuin et al. 2003 -!/BT4 RIPFAC2=-2.5 ! A2 in Ardhuin et al. 2003 -!/BT4 RIPFAC3=1.2 ! A3 in Ardhuin et al. 2003 -!/BT4 RIPFAC4=0.05 ! A4 in Ardhuin et al. 2003 -!/BT4 SIGDEPTH=0.05 -!/BT4 BOTROUGHMIN=0.01 -!/BT4 BOTROUGHFAC=1.00 -!/BT4 CALL READNL ( NDSS, 'SBT4', STATUS ) -!/BT4 WRITE (NDSO,926) STATUS -!/BT4 WRITE (NDSO,927) SEDMAPD50, SED_D50_UNIFORM, & -!/BT4 RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4,SIGDEPTH, & -!/BT4 BOTROUGHMIN, BOTROUGHFAC -!/BT4 SBTCX(1)=RIPFAC1 -!/BT4 SBTCX(2)=RIPFAC2 -!/BT4 SBTCX(3)=RIPFAC3 -!/BT4 SBTCX(4)=RIPFAC4 -!/BT4 SBTCX(5)=SIGDEPTH -!/BT4 SBTCX(6)=BOTROUGHMIN -!/BT4 SBTCX(7)=BOTROUGHFAC -! -! -! 6.h Define Sdb. -! -!/DB0 WRITE (NDSO,928) -! -!/DB1 BJALFA = 1. -!/DB1 BJGAM = 0.73 -!/DB1 BJFLAG = .TRUE. -! -!/DB1 CALL READNL ( NDSS, 'SDB1', STATUS ) -!/DB1 WRITE (NDSO,928) STATUS -!/DB1 BJALFA = MAX ( 0. , BJALFA ) -!/DB1 BJGAM = MAX ( 0. , BJGAM ) -!/DB1 WRITE (NDSO,929) BJALFA, BJGAM -!/DB1 IF ( BJFLAG ) THEN -!/DB1 WRITE (NDSO,*) ' Using Hmax/d ratio only.' -!/DB1 ELSE -!/DB1 WRITE (NDSO,*) & -!/DB1 ' Using Hmax/d in Miche style formulation.' -!/DB1 END IF -!/DB1 WRITE (NDSO,*) -!/DB1 SDBC1 = BJALFA -!/DB1 SDBC2 = BJGAM -!/DB1 FDONLY = BJFLAG -! -! -!/UOST UOSTFILELOCAL = 'obstructions_local.'//ADJUSTL(TRIM(GNAME))//'.in' -!/UOST UOSTFILESHADOW = 'obstructions_shadow.'//ADJUSTL(TRIM(GNAME))//'.in' -!/UOST UOSTFACTORLOCAL = 1 -!/UOST UOSTFACTORSHADOW = 1 -!/UOST CALL READNL ( NDSS, 'UOST', STATUS ) -!/UOST WRITE (NDSO,4500) STATUS -!/UOST WRITE (NDSO,4501) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW -! -! 6.i Define Str. -! -!/TR0 WRITE (NDSO,930) -! -! 6.j Define Sbs. -! -!/BS0 WRITE (NDSO,932) -!/BS1 WRITE (NDSO,932) -! -! 6.k Define Sxx and Sic. -! -!/IC1 WRITE (NDSO,935) -!/IC1 WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & -!/IC1 //'user-specified ki values.',' Required ' & -!/IC1 //'field input: ice parameter 1.' -! -!/IC2 WRITE (NDSO,935) -!/IC2 WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & -!/IC2 //'under-ice boundary layer method.',' Required ' & -!/IC2 //'field input: ice parameters 1 and 2.' -! -!/IC3 WRITE (NDSO,935) -!/IC3 WRITE(NDSO,'(A/A)')' Sice will be calculated using '& -!/IC3 //'Wang and Shen method.',' '& -!/IC3 //'Required field input: ice parameters 1, 2, 3 and 4.' -! -!/IC4 WRITE (NDSO,935) -!/IC4 WRITE(NDSO,'(A/A)')' Sice will be calculated using '& -!/IC4 //'Empirical method.',' '& -!/IC4 //'Required field input: ice parameters (varies).' -! -!/IC5 WRITE (NDSO,935) -!/IC5 WRITE(NDSO,'(A/A/)')' Sice will be calculated using '& -!/IC5 //'effective medium models.',' '& -!/IC5 //'Required field input: ice parameters 1, 2, 3 and 4.' -! -! 6.l Read unstructured data -! initialisation of logical related to unstructured grid - UGOBCAUTO = .TRUE. - UGBCCFL = .TRUE. - UGOBCDEPTH= -10. - UGOBCOK = .FALSE. - UGOBCFILE = 'unset' - EXPFSN = .TRUE. - EXPFSPSI = .FALSE. - EXPFSFCT = .FALSE. - IMPFSN = .FALSE. - IMPTOTAL = .FALSE. - EXPTOTAL = .FALSE. - IMPREFRACTION = .FALSE. - IMPFREQSHIFT = .FALSE. - IMPSOURCE = .FALSE. - SETUP_APPLY_WLV = .FALSE. - SOLVERTHR_SETUP=1E-14 - CRIT_DEP_SETUP=0.1 - JGS_TERMINATE_MAXITER = .TRUE. - JGS_TERMINATE_DIFFERENCE = .TRUE. - JGS_TERMINATE_NORM = .FALSE. - JGS_LIMITER = .FALSE. - JGS_BLOCK_GAUSS_SEIDEL = .TRUE. - JGS_USE_JACOBI = .TRUE. - JGS_MAXITER=100 - JGS_PMIN = 1 - JGS_DIFF_THR = 1.E-10 - JGS_NORM_THR = 1.E-20 - JGS_NLEVEL = 0 - JGS_SOURCE_NONLINEAR = .FALSE. -! read data from the unstructured devoted namelist - CALL READNL ( NDSS, 'UNST', STATUS ) - - B_JGS_USE_JACOBI = JGS_USE_JACOBI - B_JGS_TERMINATE_MAXITER = JGS_TERMINATE_MAXITER - B_JGS_TERMINATE_DIFFERENCE = JGS_TERMINATE_DIFFERENCE - B_JGS_TERMINATE_NORM = JGS_TERMINATE_NORM - B_JGS_LIMITER = JGS_LIMITER - B_JGS_BLOCK_GAUSS_SEIDEL = JGS_BLOCK_GAUSS_SEIDEL - B_JGS_MAXITER = JGS_MAXITER - B_JGS_PMIN = JGS_PMIN - B_JGS_DIFF_THR = JGS_DIFF_THR - B_JGS_NORM_THR = JGS_NORM_THR - B_JGS_NLEVEL = JGS_NLEVEL - B_JGS_SOURCE_NONLINEAR = JGS_SOURCE_NONLINEAR - - IF ((EXPFSN .eqv. .FALSE.).and.(EXPFSPSI .eqv. .FALSE.) & - .and.(EXPFSFCT .eqv. .FALSE.) & - .and.(IMPFSN .eqv. .FALSE.) & - .and.(EXPTOTAL .eqv. .FALSE.) & - .and.(IMPTOTAL .eqv. .FALSE.)) THEN - EXPFSN=.TRUE. ! This is the default scheme ... - END IF - nbSel=0 - - IF (EXPFSN) nbSel=nbSel+1 - IF (EXPFSPSI) nbSel=nbSel+1 - IF (EXPFSFCT) nbSel=nbSel+1 - IF (IMPFSN) nbSel=nbSel+1 - IF (IMPTOTAL) nbSel=nbSel+1 - IF (EXPTOTAL) nbSel=nbSel+1 - - IF (GTYPE .EQ. UNGTYPE) THEN - IF (nbSel .ne. 1) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN WW3_GRID:' - IF (nbSel .gt. 1) THEN - WRITE (NDSE,*) 'More than one scheme selected' - ELSE IF (nbSel .eq. 0) THEN - WRITE (NDSE,*) 'no scheme selected' - END IF - WRITE (NDSE,*)'Select only one of EXPFSN, EXPFSFCT, EXPFSPSI' - WRITE (NDSE,*)'IMPFSN, IMPTOTAL' - CALL EXTCDE ( 30 ) - END IF - END IF -! -! 6.m Select propagation scheme -! - WRITE (NDSO,950) -! - NRPROP = 0 - FLPROP = .TRUE. - PNAME = ' ' -!/PR0 PNAME = 'Not defined ' -!/PR0 NRPROP = NRPROP + 1 -!/PR0 FLPROP = .FALSE. -!/PR1 PNAME = 'First order upstream ' -!/PR1 NRPROP = NRPROP + 1 -!/UQ PNAME = '3rd order UQ' -!/UNO PNAME = '2nd order UNO' - J = LEN_TRIM(PNAME) -!/PR2 PNAME = PNAME(1:J)//' + GSE diffusion ' -!/PR2 NRPROP = NRPROP + 1 -!/PR3 PNAME = PNAME(1:J)//' + GSE averaging ' -!/PR3 NRPROP = NRPROP + 1 -! -!/SMC PNAME = 'UNO2 on SMC grid + diffusion ' -! - IF ( (FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. .NOT. FLPROP ) THEN - WRITE (NDSE,1030) - CALL EXTCDE ( 20 ) - END IF -! - IF ( .NOT.(FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. FLPROP ) THEN - WRITE (NDSE,1031) - END IF -! - IF ( NRPROP.EQ.0 ) THEN - WRITE (NDSE,1032) - CALL EXTCDE ( 21 ) - END IF -! - IF ( NRPROP .GT. 1 ) THEN - WRITE (NDSE,1033) NRPROP - CALL EXTCDE ( 22 ) - END IF -! -! 6.m Parameters for propagation scheme -! - WRITE (NDSO,951) PNAME -! - CFLTM = 0.7 -! -!/PR2 DTIME = 0. -!/PR2 LATMIN = 70. -! -!/SMC !! Default values of SMC grid parameters. JGLi06Apr2021 -!/SMC NCel = 1 -!/SMC NUFc = 1 -!/SMC NVFc = 1 -!/SMC NGLO = 1 -!/SMC NARC = 1 -!/SMC NBGL = 1 -!/SMC NBAC = 1 -!/SMC LvSMC = 1 -!/SMC MRFct = 1 -!/SMC ISHFT = 0 -!/SMC JEQT = 0 -!/SMC NBISMC = 0 -!/SMC CFLSM = 0.7 -!/SMC DTIMS = 360.0 -!/SMC RFMAXD = 36.0 -!/SMC UNO3 = .FALSE. -!/SMC AVERG = .TRUE. -!/SMC SEAWND = .FALSE. -!/SMC Arctic = .FALSE. -! -!/PR3 WDTHCG = 1.5 -!/PR3 WDTHTH = WDTHCG -! -!/PR1 CALL READNL ( NDSS, 'PRO1', STATUS ) -!/PR1 IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' -!/PR1 WRITE (NDSO,952) STATUS(1:18) -!/PR1 CFLTM = MAX ( 0. , CFLTM ) -!/PR1 WRITE (NDSO,953) CFLTM -! -!/PR2 CALL READNL ( NDSS, 'PRO2', STATUS ) -!/PR2 IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' -!/PR2 WRITE (NDSO,952) STATUS(1:18) -!/PR2 CFLTM = MAX ( 0. , CFLTM ) -!/PR2 DTIME = MAX ( 0. , DTIME ) -!/PR2 LATMIN = MIN ( 89. , ABS(LATMIN) ) -!/PR2 CLATMN = COS ( LATMIN * DERA ) -!/PR2 IF ( DTIME .EQ. 0. ) THEN -!/PR2 WRITE (NDSO,953) CFLTM, LATMIN -!/PR2 ELSE -!/PR2 WRITE (NDSO,954) CFLTM, DTIME/3600., LATMIN -!/PR2 END IF -!/PR2 DTME = DTIME -! -!/SMC CALL READNL ( NDSS, 'PSMC', STATUS ) -!/SMC IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' -!/SMC WRITE (NDSO,952) STATUS(1:18) -!/SMC CFLSM = MAX ( 0. , CFLSM ) -!/SMC DTIMS = MAX ( 0. , DTIMS ) -!/SMC RFMAXD = MIN ( 80.0, ABS(RFMAXD) ) -!/SMC Refran = RFMAXD * DERA -!/SMC !! Printing out SMC grid parameters. -!/SMC WRITE (NDSO,1950) -!/SMC WRITE (NDSO,1951) PNSMC -!/SMC WRITE (NDSO,1953) CFLSM, DTIMS/3600., RFMAXD -! -!/SMC FUNO3 = UNO3 -!/SMC FVERG = AVERG -!/SMC FSWND = SEAWND -!/SMC ARCTC = Arctic -!/SMC NBSMC = NBISMC -!/SMC IF( FUNO3 ) WRITE (NDSO,*) & -!/SMC " Advection use 3rd order UNO3 instead of UNO2 scheme." -!/SMC IF( FVERG ) WRITE (NDSO,*) & -!/SMC " Extra 1-2-1 average smoothing activated on SMC grid." -!/SMC IF( FSWND ) WRITE (NDSO,*) & -!/SMC " Sea-point only wind input is required for SMC grid. " -!/SMC IF( ARCTC ) WRITE (NDSO,*) & -!/SMC " Arctic polar part will be appended to this SMC grid." -!/SMC NRLv = LvSMC -!/SMC WRITE (NDSO,4001) NRLv -!/SMC WRITE (NDSO,4002) JEQT -!/SMC WRITE (NDSO,4302) ISHFT -!/SMC WRITE (NDSO,4003) NBSMC -! -!/PR3 CALL READNL ( NDSS, 'PRO3', STATUS ) -!/PR3 IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' - IF (GTYPE.NE.UNGTYPE) THEN -!/PR3 WRITE (NDSO,952) STATUS(1:18) -!/PR3 CFLTM = MAX ( 0. , CFLTM ) -!/PR3 WRITE (NDSO,953) CFLTM, WDTHCG -!/PR3 IF ( WDTHCG*(XFR-1.) .GT. 1. ) WRITE (NDSO,955) 1./(XFR-1.) -!/PR3 WRITE (NDSO,954) WDTHTH -!/PR3 IF ( WDTHTH*DTH .GT. 1. ) WRITE (NDSO,955) 1./DTH -!/PR3 WRITE (NDSO,*) - ENDIF -!/PR3 WDCG = WDTHCG -!/PR3 WDTH = WDTHTH -! - CTMAX = CFLTM -! -!/RTD ! Set/ read in rotation values - these will be written out -!/RTD ! later with the rest of the grid info -!/RTD ! Default is a non-rotated lat-lon grid -!/RTD PLAT = 90. -!/RTD PLON = -180. -!/RTD UNROT = .FALSE. -!/RTD CALL READNL ( NDSS, 'ROTD', STATUS ) -!/RTD PLON = MOD( PLON + 180., 360. ) - 180. -!/RTD ! Ensure that a grid with pole at the geographic North is standard lat-lon -!/RTD IF ( PLAT == 90. .AND. ( PLON /= -180. .OR. UNROT ) ) THEN -!/RTD WRITE( NDSE, 1052 ) -!/RTD CALL EXTCDE ( 33 ) -!/RTD ENDIF -!/RTD ! Default poles of output b. c. are non-rotated: -!/RTD BPLAT = 90. -!/RTD BPLON = -180. -!/RTD CALL READNL ( NDSS, 'ROTB', STATUS ) -!/RTD ! A b. c. dest. grid with pole at the geographic North must be non-rotated -!/RTD DO I=1,9 -!/RTD IF ( BPLAT(I) == 90. ) THEN -!/RTD ! Require BPLON(I) == -180., but don't blaim the user if BPLON(I) == 180. -!/RTD IF ( BPLON(I) == 180. ) BPLON(I) = -180. -!/RTD IF ( BPLON(I) == -180. ) CYCLE -!/RTD END IF -!/RTD IF ( BPLAT(I) < 90. ) CYCLE -!/RTD WRITE( NDSE, 1053 ) -!/RTD CALL EXTCDE ( 34 ) -!/RTD END DO -! -! 6.n Set miscellaneous parameters (ice, seeding, numerics ... ) -! - CICE0 = 0.5 - CICEN = 0.5 - LICE = 0. - ICEHFAC= 1.0 - ICEHMIN= 0.2 ! the 0.2 value is arbitrary and needs to be tuned. - ICEHINIT= 0.5 - ICESLN = 1.0 - ICEWIND= 1.0 - ICESNL = 1.0 - ICESDS = 1.0 - ICEHDISP= 0.6 ! Prevent from convergence crash in w3dispmd in the presence of ice, should be tuned - ICEDDISP= 80 - ICEFDISP= 2 - GSHIFT = 0.0D0 - PMOVE = 0.5 - XSEED = 1. - FLAGTR = 0 - XP = 0.15 - XR = 0.10 - XFILT = 0.05 - IHM = 100 - HSPM = 0.05 - WSM = 1.7 - WSC = 0.333 - FLC = .TRUE. - TRCKCMPR = .TRUE. - NOSW = 5 -! -! Gas fluxes -! - AIRCMIN = 2.0 ! cmin for whitecap coverage and entrained air - AIRGB = 0.2 ! volume of entrained air constant (Deike et al. 2017) -! -!/NCO/! NCEP operations retains first three swell systems. -!/NCO NOSW=3 - PTM = 1 ! Default to standard WW3 partitioning. C. Bunney - PTFC = 0.1 ! Part. method 5 cutoff freq default. C. Bunney - FMICHE = 1.6 - RWNDC = 1. - WCOR1 = 99. - WCOR2 = 0. - BTBET = 1.2 ! β for c / [U cos(θ - φ)] < β -! Variables for Space-Time Extremes -! Default negative values make w3iogomd switch off space-time extremes -! forces user to provide NAMELIST if wanting to compute STE parameters - STDX = -1. - STDY = -1. - STDT = -1. - ICEDISP = .FALSE. - CALTYPE = 'standard' -! Variables for 3D array output - E3D=0 - I1E3D=1 - I2E3D=NK - P2SF = 0 - I1P2SF = 1 - I2P2SF = 15 - US3D = 0 - I1US3D = 1 - I2US3D = NK - USSP=0 - IUSSP=1 - STK_WN(:)=0.0 - STK_WN(1)=TPI/100. !Set default decay of 100 m for Stokes drift - TH1MF=0 - I1TH1M=1 - I2TH1M=NK - STH1MF=0 - I1STH1M=1 - I2STH1M=NK - TH2MF=0 - I1TH2M=1 - I2TH2M=NK - STH2MF=0 - I1STH2M=1 - I2STH2M=NK -! - FACBERG=1. -!/IS0 WRITE (NDSO,944) -!/IS1 ISC1 = 1. -!/IS1 ISC2 = 0. -!/IS1 CALL READNL ( NDSS, 'SIS1', STATUS ) -!/IS1 WRITE (NDSO,945) STATUS -!/IS1 WRITE (NDSO,946) ISC1, ISC2 -!/IS1 IS1C1 = ISC1 -!/IS1 IS1C2 = ISC2 -!/IS2 ISC1 = 1. -!/IS2 IS2C2 = 0. ! 0.025 -!/IS2 IS2C3 = 0. ! 2.4253 -!/IS2 IS2CONC = 0. -!/IS2 IS2BACKSCAT = 1. -!/IS2 IS2BREAK = .FALSE. -!/IS2 IS2BREAKF = 3.6 -!/IS2 IS2FLEXSTR=6.00E+05 ! value used in Ardhuin et al. 2020 -!/IS2 IS2ISOSCAT=.TRUE. ! uses isotropic back-scatter -!/IS2 IS2DISP=.FALSE. !not dispersion only attenuation following Liu disp. eq. -!/IS2 IS2DUPDATE=.TRUE. -!/IS2 IS2FRAGILITY=0.9 -!/IS2 IS2DMIN=20 -!/IS2 IS2DAMP=0. -!/IS2 IS2CREEPB=0. -!/IS2 IS2CREEPC=0.4 ! This gives an impact of break-up over a wider freq. range -! ! compared to the 0.2 value in Boutin et al. 2018 -!/IS2 IS2CREEPD=0.5 -!/IS2 IS2CREEPN=3.0 -!/IS2 IS2BREAKE=1. -!/IS2 IS2WIM1=1. -!/IS2 IS2ANDISB=.TRUE. !anelastic instead of inelastic dissipation if IS2CREEPB>0 -!/IS2 IS2ANDISE=0.55 !energy of activation -!/IS2 IS2ANDISD=2.0E-9 !see Ardhuin et al. 2020 -!/IS2 IS2ANDISN=1. !dependency on stress. Equal to 1 normally? -!/IS2 CALL READNL ( NDSS, 'SIS2', STATUS ) -!/IS2 WRITE (NDSO,947) STATUS -!/IS2 WRITE (NDSO,2948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, IS2DUPDATE, IS2FLEXSTR, IS2DISP, & -!/IS2 IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, IS2C3, IS2CONC, IS2CREEPB,& -!/IS2 IS2CREEPC, IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, & -!/IS2 IS2ANDISB, IS2ANDISE, IS2ANDISD, IS2ANDISN -! -!/REF1 REFCOAST=0. -!/REF1 REFMAP=0. -!/REF1 REFMAPD=0. -!/REF1 REFRMAX=1. -!/REF1 REFFREQPOW=2. -!/REF1 REFFREQ=0. -!/REF1 REFCOSP_STRAIGHT=4. -!/REF1 REFSLOPE=0.22 -!/REF1 REFSUBGRID=0. -!/REF1 REFICEBERG=0. -!/REF1 REFUNSTSOURCE=0. -! -!/REF1 CALL READNL ( NDSS, 'REF1', STATUS ) -!/REF1 WRITE (NDSO,969) STATUS -! -!/IG1 IGMETHOD = 2 -!/IG1 IGADDOUTP= 0 -!/IG1 IGSOURCE = 2 -!/IG1 IGSTERMS = 0 -!/IG1 IGMAXFREQ=0.03 -!/IG1 IGSOURCEATBP = 0 -!/IG1 IGBCOVERWRITE = .TRUE. -!/IG1 IGSWELLMAX = .TRUE. -!/IG1 IGKDMIN = 1.1 -!/IG1 IGFIXEDDEPTH = 0. -!/IG1 IGEMPIRICAL = 0.00125 -! -!/IG1 CALL READNL ( NDSS, 'SIG1 ', STATUS ) -!/IG1 WRITE (NDSO,970) STATUS -! -!/IC2 IC2DISPER = .FALSE. -!/IC2 IC2TURB = 1. -!/IC2 IC2TURBS = 0. -!/IC2 IC2ROUGH = 0.01 -!/IC2 IC2REYNOLDS = 1.5E5 -!/IC2 IC2SMOOTH = 2E5 -!/IC2 IC2VISC = 1. -!/IC2 IC2DMAX = 0. -! -!/IC3 IC3MAXTHK = 100.0 -!/IC3 IC3MAXCNC = 100.0 -!/IC3 IC2TURB = 2.0 ! from run_test example by F.A. -!/IC3 IC2TURBS = 0. -!/IC3 IC2ROUGH = 0.02 ! from run_test example by F.A. (alt:0.1) -!/IC3 IC2REYNOLDS = 1.5E5 -!/IC3 IC2SMOOTH = 7.0E4 -!/IC3 IC2VISC = 2.0 -!/IC3 IC3CHENG = .TRUE. -!/IC3 USECGICE = .FALSE. -!/IC3 IC3HILIM = 100.0 -!/IC3 IC3KILIM = 100.0 -!/IC3 IC3HICE = -1.0 -!/IC3 IC3VISC = -2.0 -!/IC3 IC3DENS = -3.0 -!/IC3 IC3ELAS = -4.0 -!fixme: if USECGICE = .TRUE., don't allow use of IC3MAXTHK<100.0 - -!/IC4 IC4METHOD = 1 !switch for methods within IC4 -!/IC4 IC4KI=0.0 -!/IC4 IC4FC=0.0 -! -!/IC5 IC5MINIG = 1. -!/IC5 IC5MINWT = 0. -!/IC5 IC5MAXKRATIO = 1E9 -!/IC5 IC5MAXKI = 100. -!/IC5 IC5MINHW = 0. -!/IC5 IC5MAXITER = 100. -!/IC5 IC5RKICK = 0. -!/IC5 IC5KFILTER = 0.0025 -!/IC5 IC5VEMOD = 3. ! 1: EFS, 2: RP, 3: M2 (default) -! -!/IC2 CALL READNL ( NDSS, 'SIC2 ', STATUS ) -!/IC2 WRITE (NDSO,971) STATUS -! -!/IC3 CALL READNL ( NDSS, 'SIC3 ', STATUS ) -!/IC3 WRITE (NDSO,971) STATUS -! -!/IC4 CALL READNL ( NDSS, 'SIC4 ', STATUS ) -!/IC4 WRITE (NDSO,971) STATUS -! -!/IC5 CALL READNL ( NDSS, 'SIC5 ', STATUS ) -!/IC5 IC5VEMOD = MIN(MAX(1., IC5VEMOD), 3.) -!/IC5 WRITE (NDSO,971) STATUS -!/IC5 WRITE (NDSO,2971) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & -!/IC5 IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK, & -!/IC5 IC5KFILTER, IC5MSTR(NINT(IC5VEMOD)) -! - CALL READNL ( NDSS, 'OUTS', STATUS ) - WRITE (NDSO,4970) STATUS -! -! -! output of frequency spectra, th1m ... -! - E3DF(1,1) = E3D - E3DF(2,1) = MIN(MAX(1,I1E3D),NK) - E3DF(3,1) = MIN(MAX(1,I2E3D),NK) - E3DF(1,2) = TH1MF - E3DF(2,2) = MIN(MAX(1,I1TH1M),NK) - E3DF(3,2) = MIN(MAX(1,I2TH1M),NK) - E3DF(1,3) = STH1MF - E3DF(2,3) = MIN(MAX(1,I1STH1M),NK) - E3DF(3,3) = MIN(MAX(1,I2STH1M),NK) - E3DF(1,4) = TH2MF - E3DF(2,4) = MIN(MAX(1,I1TH2M),NK) - E3DF(3,4) = MIN(MAX(1,I2TH2M),NK) - E3DF(1,5) = STH2MF - E3DF(2,5) = MIN(MAX(1,I1STH2M),NK) - E3DF(3,5) = MIN(MAX(1,I2STH2M),NK) -! -! output of microseismic source spectra -! - P2MSF(1) = P2SF - P2MSF(2) = MIN(MAX(1,I1P2SF),NK) - P2MSF(3) = MIN(MAX(1,I2P2SF),NK) -! -! output of Stokes drift profile -! - US3DF(1) = US3D - US3DF(2) = MAX( 1 , MIN( NK, I1US3D) ) - US3DF(3) = MAX( 1 , MIN( NK, I2US3D) ) -! -! output of Stokes drift partitions -! - USSPF(1) = USSP - USSPF(2) = MAX( 1 , MIN(25, IUSSP ) ) - IF (IUSSP.GT.25) THEN - WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN ww3_grid:' - WRITE(NDSE,*) " Stokes drift partition outputs not " - WRITE(NDSE,*) " intended for use with more than 25 " - WRITE(NDSE,*) " partitions. Please reduce IUSSP " - WRITE(NDSE,*) " specified in ww3_grid.inp to proceed " - CALL EXTCDE( 31) - ENDIF - - DO J=1,USSPF(2) - USSP_WN(j) = STK_WN(J) - ENDDO - -! - WRITE (NDSO,4971) P2MSF(1:3) - WRITE (NDSO,4972) US3DF(1:3) - WRITE (NDSO,4973) E3DF(1:3,1) - WRITE (NDSO,4974) USSPF(1:2) - DO J=1,USSPF(2) - WRITE(NDSO,4975) J,USSP_WN(J) - ENDDO -! - CALL READNL ( NDSS, 'MISC', STATUS ) - WRITE (NDSO,960) STATUS -! - IF ( FLAGTR.LT.0 .OR. FLAGTR.GT.6 ) FLAGTR = 0 - CICEN = MIN ( 1. , MAX ( 0. , CICEN ) ) - ICESLN = MIN ( 1. , MAX ( 0. , ICESLN ) ) - ICEWIND = MIN ( 1. , MAX ( 0. , ICEWIND ) ) - ICESDS = MIN ( 1. , MAX ( 0. , ICESDS ) ) - ICESNL = MIN ( 1. , MAX ( 0. , ICESNL ) ) - FICEN = CICEN - GRIDSHIFT=GSHIFT - ICESCALES(1)=ICESLN - ICESCALES(2)=ICEWIND - ICESCALES(3)=ICESNL - ICESCALES(4)=ICESDS - CMPRTRCK=TRCKCMPR - CICE0 = MIN ( CICEN , MAX ( 0. , CICE0 ) ) - FICEL = LICE - IICEHMIN = ICEHMIN - IICEHFAC = ICEHFAC - IICEHINIT = ICEHINIT - IICEDISP= ICEDISP - IICEHDISP = ICEHDISP - IICEDDISP = ICEDDISP - IICEFDISP = ICEFDISP - PMOVE = MAX ( 0. , PMOVE ) - PFMOVE = PMOVE -! - BTBETA = MIN(MAX (1., BTBET), 2.) - AAIRCMIN = ALOG(GRAV/AIRCMIN/SIG(1))/ALOG(XFR)+1 ! goes from phase speed C=g/sig to index - AAIRGB = AIRGB -! -! Notes: Presently, if we select CICE0.ne.CICEN requires an obstruction -! grid, that is initialized with zeros as default. - IF ( FLAGTR .LT. 3 ) THEN - IF (CICE0.NE.CICEN) THEN - CICE0 = CICEN - IF (STATUS=='(user def. values) :') WRITE (NDSO,2961) - END IF - END IF -!/IC0 IF ( CICE0.EQ.CICEN .AND. FLAGTR.GE.3 ) FLAGTR = FLAGTR - 2 - WRITE (NDSO,961) CICE0, CICEN - WRITE (NDSO,8972) ICEWIND - FICE0 = CICE0 -! Variables for Space-Time Extremes - STEXU = STDX - IF ( STDY .LE. 0. ) THEN - STDY = STDX - END IF - STEYU = STDY - STEDU = STDT - IF ( STDX .GT. 0 ) THEN - WRITE (NDSO,1040) STDX - WRITE (NDSO,1041) STDY - ELSE - WRITE (NDSO,1042) - END IF - IF ( STDT .GT. 0 ) THEN - WRITE (NDSO,1043) STDT - ELSE - WRITE (NDSO,1044) - END IF -!/MGG WRITE (NDSO,962) PMOVE -! -!/SEED XSEED = MAX ( 1. , XSEED ) -!/SEED WRITE (NDSO,964) XSEED -!/SCRIP WRITE (NDSO,963) GSHIFT - WRITE (NDSO,1972) TRCKCMPR - FACSD = XSEED -!/RWND RWINDC = RWNDC -!/WCOR WWCOR(1) = WCOR1 -!/WCOR WWCOR(2) = WCOR2 -! - XP = MAX ( 1.E-6 , XP ) - XR = MAX ( 1.E-6 , XR ) - XREL = XR - XFILT = MAX ( 0. , XFILT ) - XFLT = XFILT - WRITE (NDSO,965) XP, XR, XFILT - FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 -! - IHMAX = MAX ( 50, IHM ) - HSPMIN = MAX ( 0.0001 , HSPM ) - WSMULT = MAX ( 1. , WSM ) - WSCUT = MIN ( 1.0001 , MAX ( 0. , WSC ) ) - FLCOMB = FLC - NOSWLL = MAX ( 1 , NOSW ) - PTMETH = PTM ! Partitioning method. Chris Bunney (Jan 2016) - PTFCUT = PTFC ! Freq cutoff for partitiong method 5 - PMNAM2 = "" - IF( PTMETH .EQ. 1 ) THEN - PMNAME = "WW3 default" - ELSE IF( PTMETH .EQ. 2 ) THEN - PMNAME = "Watershedding plus wind cut-off" - ELSE IF( PTMETH .EQ. 3 ) THEN - PMNAME = "Watershedding only" - WSCUT = 0.0 ! We don't want to classify by ws frac - PMNAM2 = "WSC set to 0.0" - ELSE IF( PTMETH .EQ. 4 ) THEN - PMNAME = "Wind speed cut-off only" - PMNAM2 = "WSC set to 0.0, NOSW set to 1" - WSCUT = 0.0 ! We don't want to classify by ws frac - NOSWLL = 1 ! Only ever one swell - ELSE IF( PTMETH .EQ. 5 ) THEN - WRITE(PMNAME, '("2-Band hi/low cutoff at ", F4.2,"Hz")') PTFCUT - PMNAM2 = "WSC set to 0.0, NOSW set to 1" - WSCUT = 0.0 ! We don't want to classify by ws frac - NOSWLL = 1 ! Only ever one swell - ELSE - WRITE( NDSE, * ) & - "*** Error - unknown partitioing method (PTM)! ***" - CALL EXIT(1) - ENDIF - - IF ( FLCOMB ) THEN - J = 1 - ELSE - J = 2 - END IF - WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J), NOSWLL - WRITE (NDSO,5971) PMNAME - IF( PMNAM2 .NE. "" ) WRITE (NDSO,5972) PMNAM2 -!! WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J) -! - FHMAX = MAX ( 0.01 , FMICHE ) - J = 2 -!/MLIM J = 1 - WRITE (NDSO,967) FHMAX, FHMAX/SQRT(2.), YESXNO(J) - IF ( FHMAX.LT.0.50 .AND. J.EQ.1 ) WRITE (NDST,968) -! - IF (TRIM(CALTYPE) .NE. 'standard' .AND. & - TRIM(CALTYPE) .NE. '360_day' .AND. & - TRIM(CALTYPE) .NE. '365_day' ) GOTO 2003 - WRITE (NDST,1973) CALTYPE - WRITE (NDSO,*) -! -! 6.x Read values for FLD stress calculation -! -!/FLD1 TAILTYPE = 0 -!/FLD1 TAILLEV = 0.006 -!/FLD1 TAILT1 = 1.25 -!/FLD1 TAILT2 = 3.00 -!/FLD2 TAILTYPE = 0 -!/FLD2 TAILLEV = 0.006 -!/FLD2 TAILT1 = 1.25 -!/FLD2 TAILT2 = 3.00 -! -!/FLD1 CALL READNL ( NDSS, 'FLD1', STATUS ) -!/FLD1 TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) -!/FLD1 TAIL_LEV = TAILLEV -!/FLD1 TAIL_ID = TAILTYPE -!/FLD1 TAIL_TRAN1 = TAILT1 -!/FLD1 TAIL_TRAN2 = TAILT2 -!/FLD2 CALL READNL ( NDSS, 'FLD2', STATUS ) -!/FLD2 TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) -!/FLD2 TAIL_LEV = TAILLEV -!/FLD2 TAIL_ID = TAILTYPE -!/FLD2 TAIL_TRAN1 = TAILT1 -!/FLD2 TAIL_TRAN2 = TAILT2 -! -! 6.o End of namelist processing -! - IF (FLGNML) THEN - CLOSE (NDSS) - ELSE - CLOSE (NDSS,STATUS='DELETE') - END IF -! - IF ( FLNMLO ) THEN - WRITE (NDSO,917) -!/FLX3 WRITE (NDSO,2810) CDMAX*1.E3, CTYPE -!/FLX4 WRITE (NDSO,2810) CDFAC -!/LN1 WRITE (NDSO,2820) CLIN, RFPM, RFHF -!/ST1 WRITE (NDSO,2920) CINP - IF ( .NOT. FLSTB2 ) THEN -!/ST2 WRITE (NDSO,2920) ZWND, SWELLF - ELSE -!/STAB2 WRITE (NDSO,2921) ZWND, SWELLF, STABSH, STABOF, & -!/STAB2 CNEG, CPOS, FNEG - END IF -! -!/ST3 WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & -!/ST3 SWELLF -!/ST4 WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & -!/ST4 TAUWSHELTER, SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, & -!/ST4 SWELLF5, SWELLF6, SWELLF7, Z0RAT, SINBR -!/ST6 WRITE (NDSO,2920) SINA0, SINWS, SINFC -!/NL1 WRITE (NDSO,2922) LAMBDA, NLPROP, KDCONV, KDMIN, & -!/NL1 SNLCS1, SNLCS2, SNLCS3 -!/NL2 WRITE (NDSO,2922) IQTYPE, TAILNL, NDEPTH -!/NL2 IF ( IQTYPE .EQ. 3 ) THEN -!/NL2 IF ( NDEPTH .EQ. 1 ) THEN -!/NL2 WRITE (NDSO,3923) DPTHNL(1) -!/NL2 ELSE -!/NL2 WRITE (NDSO,4923) DPTHNL(1) -!/NL2 END IF -!/NL2 WRITE (NDSO,5923) DPTHNL(2:NDEPTH-1) -!/NL2 WRITE (NDSO,6923) DPTHNL(NDEPTH) -!/NL2 END IF -!/NL3 WRITE (NDSO,2922) NQDEF, MSC, NSC, KDFD, KDFS -!/NL3 IF ( NQDEF .EQ. 1 ) THEN -!/NL3 WRITE (NDSO,3923) QPARMS(1:5) -!/NL3 ELSE -!/NL3 WRITE (NDSO,4923) QPARMS(1:5) -!/NL3 DO J=2, NQDEF-1 -!/NL3 WRITE (NDSO,5923) QPARMS((J-1)*5+1:J*5) -!/NL3 END DO -!/NL3 WRITE (NDSO,6923) QPARMS((NQDEF-1)*5+1:NQDEF*5) -!/NL3 END IF -!/NL4 WRITE (NDSO,2922) INDTSA, ALTLP -!/NL5 WRITE (NDSO,2922) QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5IPL, QI5PMX -!/NLS WRITE (NDSO,8922) A34, FHFC, DNM, FC1, FC2, FC3 -!/ST1 WRITE (NDSO,2924) CDIS, APM -!/ST2 WRITE (NDSO,2924) SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN -!/ST3 WRITE (NDSO,2924) SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & -!/ST3 SDSDELTA2 - -!/ST4 WRITE (NDSO,2924) SDSBCHOICE, SDSC2, SDSCUM, SDSC4, & -!/ST4 SDSC5, SDSC6, & -!/ST4 WNMEANP, FXPM3, FXFM3, FXFMAGE, & -!/ST4 SDSBINT, SDSBCK, SDSABK, SDSPBK, SDSHCK, & -!/ST4 SDSBR, SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & -!/ST4 SDSBT, SDSP, SDSISO, SDSCOS, SDSDTH, SDSBRF1, & -!/ST4 SDSBRFDF, SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & -!/ST4 SPMSS, SDKOF, SDSMWD, SDSFACMTF, SDSNMTF,SDSMWPOW,& -!/ST4 SDSCUMP, SDSNUW, WHITECAPWIDTH, WHITECAPDUR -!/ST6 WRITE (NDSO,2924) SDSET, SDSA1, SDSA2, SDSP1, SDSP2 -!/ST6 WRITE (NDSO,2937) SWLB1, CSTB1 -!/BT1 WRITE (NDSO,2926) GAMMA -!/BT4 WRITE (NDSO,2926) SEDMAPD50, SED_D50_UNIFORM, & -!/BT4 RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4, SIGDEPTH, & -!/BT4 BOTROUGHMIN, BOTROUGHFAC -!/DB1 IF ( BJFLAG ) THEN -!/DB1 WRITE (NDSO,2928) BJALFA, BJGAM, '.TRUE.' -!/DB1 ELSE -!/DB1 WRITE (NDSO,2928) BJALFA, BJGAM, '.FALSE.' -!/DB1 END IF -!/PR1 WRITE (NDSO,2953) CFLTM -!/PR2 WRITE (NDSO,2953) CFLTM, DTIME, LATMIN -!/SMC WRITE (NDSO,2954) CFLSM, DTIMS, Arctic, RFMAXD, UNO3, & -!/SMC AVERG, LvSMC, NBISMC, ISHFT, JEQT, SEAWND -!/PR3 WRITE (NDSO,2953) CFLTM, WDTHCG, WDTHTH -! - WRITE (NDSO,2956) UGBCCFL, UGOBCAUTO, UGOBCDEPTH,TRIM(UGOBCFILE), & - EXPFSN, EXPFSPSI, EXPFSFCT, IMPFSN, EXPTOTAL,& - IMPTOTAL, IMPREFRACTION, IMPFREQSHIFT, & - IMPSOURCE, SETUP_APPLY_WLV, & - JGS_TERMINATE_MAXITER, & - JGS_TERMINATE_DIFFERENCE, & - JGS_TERMINATE_NORM, & - JGS_LIMITER, & - JGS_USE_JACOBI, & - JGS_BLOCK_GAUSS_SEIDEL, & - JGS_MAXITER, & - JGS_PMIN, & - JGS_DIFF_THR, & - JGS_NORM_THR, & - JGS_NLEVEL, & - JGS_SOURCE_NONLINEAR -! - WRITE (NDSO,2976) P2SF, I1P2SF, I2P2SF, & - US3D, I1US3D, I2US3D, & - USSP, IUSSP, & - E3D, I1E3D, I2E3D, & - TH1MF, I1TH1M, I2TH1M, & - STH1MF, I1STH1M, I2STH1M, & - TH2MF, I1TH2M, I2TH2M, & - STH2MF, I1STH2M, I2STH2M -! -!/REF1 WRITE(NDSO,2986) REFCOAST, REFFREQ, REFSLOPE, REFMAP, & -!/REF1 REFMAPD, REFSUBGRID , REFRMAX, REFFREQPOW, & -!/REF1 REFICEBERG, REFCOSP_STRAIGHT, REFUNSTSOURCE -! -!/IG1 WRITE(NDSO,2977) IGMETHOD, IGADDOUTP, IGSOURCE, & -!/IG1 IGSTERMS, IGBCOVERWRITE, IGSWELLMAX, & -!/IG1 IGMAXFREQ, IGSOURCEATBP, IGKDMIN, & -!/IG1 IGFIXEDDEPTH, IGEMPIRICAL -! -!/IC2 WRITE(NDSO,2978) IC2DISPER, IC2TURB, IC2ROUGH, & -!/IC2 IC2REYNOLDS, IC2SMOOTH, IC2VISC, IC2TURBS, & -!/IC2 IC2DMAX -! -!/IC3 WRITE(NDSO,2979) IC3MAXTHK, IC3MAXCNC, IC2TURB, & -!/IC3 IC2ROUGH, IC2REYNOLDS, IC2SMOOTH, & -!/IC3 IC2VISC, IC2TURBS, IC3CHENG, & -!/IC3 USECGICE, IC3HILIM, IC3KILIM, & -!/IC3 IC3HICE, IC3VISC, IC3DENS, IC3ELAS -! -!/IC4 WRITE(NDSO,NML=SIC4) -! -!/IC5 WRITE(NDSO,2981) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & -!/IC5 IC5MAXKI, IC5MINHW, IC5MAXITER, & -!/IC5 IC5RKICK, IC5KFILTER, IC5VEMOD -! -!/IS1 WRITE (NDSO,2946) IS1C1, IS1C2 -! -!/IS2 WRITE (NDSO,948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & -!/IS2 IS2DUPDATE, IS2FLEXSTR, IS2DISP, IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, & -!/IS2 IS2C3, IS2CONC, IS2CREEPB, IS2CREEPC, IS2CREEPD, & -!/IS2 IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, IS2ANDISB, & -!/IS2 IS2ANDISE, IS2ANDISD, IS2ANDISN -! -!/UOST WRITE (NDSO, 4502) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW - -! - IF ( FLCOMB ) THEN - WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & - XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & - WSCUT, '.TRUE.', NOSWLL, FHMAX, & - RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & - STDX, STDY, STDT, ICEHMIN, ICEHFAC, & - ICEHINIT, ICEDISP, ICEHDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEDDISP,ICEFDISP, CALTYPE, TRCKCMPR, & - BTBETA - ELSE - WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & - XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & - WSCUT, '.FALSE.', NOSWLL, FHMAX, & - RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & - STDX, STDY, STDT, ICEHMIN, ICEHFAC, & - ICEHINIT, ICEDISP, ICEHDISP, & - ICESLN, ICEWIND, ICESNL, ICESDS, & - ICEDDISP, ICEFDISP, CALTYPE, TRCKCMPR,& - BTBETA - END IF -! -!/FLD1 WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD2 WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/RTD WRITE(NDSO,4991) PLAT, PLON, UNROT -!/RTD WRITE(NDSO,4992) BPLAT, BPLON -! - WRITE (NDSO,918) - END IF -! -! 6.p Set various other values ... -! ... Tail in integration --> scale factor for A to E conv -! - FTE = 0.25 * SIG(NK) * DTH * SIG(NK) - FTF = 0.20 * DTH * SIG(NK) - FTWN = 0.20 * SQRT(GRAV) * DTH * SIG(NK) - FTTR = FTF - FTWL = GRAV / 6. / SIG(NK) * DTH * SIG(NK) -!/ST3 STXFTF = 1/(FACHF-1.-WNMEANP*2) & -!/ST3 * SIG(NK)**(2+WNMEANP*2) * DTH -!/ST3 STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & -!/ST3 * SIG(NK)**(2+WNMEANPTAIL*2) * DTH -!/ST3 STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & -!/ST3 * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH -!/ST3 SSTXFTF = STXFTF -!/ST3 SSTXFTFTAIL = STXFTFTAIL -!/ST3 SSTXFTWN = STXFTWN -! -!/ST4 STXFTF = 1/(FACHF-1.-WNMEANP*2) & -!/ST4 * SIG(NK)**(2+WNMEANP*2) * DTH -!/ST4 STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & -!/ST4 * SIG(NK)**(2+WNMEANPTAIL*2) * DTH -!/ST4 STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & -!/ST4 * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH -!/ST4 SSTXFTF = STXFTF -!/ST4 SSTXFTFTAIL = STXFTFTAIL -!/ST4 SSTXFTWN = STXFTWN -! -! ... High frequency cut-off -! - FXFM = 2.5 -!/ST6 FXFM = SIN6FC - FXPM = 4.0 - FXPM = FXPM * GRAV / 28. - FXFM = FXFM * TPI - XFC = 3.0 -!/ST2 XFH = 2.0 -!/ST2 XF1 = 1.75 -!/ST2 XF2 = 2.5 -!/ST2 XFT = XF2 -! - FACTI1 = 1. / LOG(XFR) - FACTI2 = 1. - LOG(TPI*FR1) * FACTI1 -! -! Setting of FACHF moved to before !/NL2 set-up for consistency -! -!/NL2 FACHF = -TAILNL - FACHFA = XFR**(-FACHF-2) - FACHFE = XFR**(-FACHF) -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 7. Read and prepare the grid. -! 7.a Type of grid -! - IF (FLGNML) THEN - GSTRG=TRIM(NML_GRID%TYPE) - IF (TRIM(NML_GRID%COORD).EQ.'SPHE') FLAGLL=.TRUE. - IF (TRIM(NML_GRID%COORD).EQ.'CART') FLAGLL=.FALSE. - CSTRG=TRIM(NML_GRID%CLOS) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) GSTRG, FLAGLL, CSTRG - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - - SELECT CASE (TRIM(GSTRG)) - CASE ('RECT') - GTYPE = RLGTYPE - WRITE (NDSO,3000) 'rectilinear' - CASE ('CURV') - GTYPE = CLGTYPE - WRITE (NDSO,3000) 'curvilinear' - CASE ('UNST') - GTYPE = UNGTYPE - WRITE (NDSO,3000) 'unstructured' -!!Li Add SMC grid type option. JGLi12Oct2020 - CASE ('SMCG') - GTYPE = SMCTYPE - WRITE (NDSO,3000) 'SMC Grid' - CASE DEFAULT - WRITE (NDSE,1007) TRIM(GSTRG) - CALL EXTCDE ( 25 ) - END SELECT -! - IF ( FLAGLL ) THEN - FACTOR = 1. - WRITE (NDSO,3001) 'spherical' - ELSE - FACTOR = 1.E-3 - WRITE (NDSO,3001) 'Cartesian' - END IF -! -! Only process grid closure string for logically rectangular grids. -! Closure setting for unstructured grids is NONE. - ICLOSE = ICLOSE_NONE - IF ( GTYPE.NE.UNGTYPE ) THEN - SELECT CASE (TRIM(CSTRG)) - CASE ('NONE') - ICLOSE = ICLOSE_NONE - WRITE (NDSO,3002) 'none' - CASE ('SMPL') - ICLOSE = ICLOSE_SMPL - WRITE (NDSO,3002) 'simple' - CASE ('TRPL') - WRITE (NDSE,'(/2A)') ' *** WARNING WW3_GRID: TRIPOLE ', & - 'GRID CLOSURE IMPLEMENTATION IS INCOMPLETE ***' - ICLOSE = ICLOSE_TRPL - WRITE (NDSO,3002) 'tripole' - IF ( GTYPE.EQ.RLGTYPE ) THEN - WRITE (NDSE,1009) - CALL EXTCDE ( 25 ) - END IF - CASE DEFAULT - ! Check for old style GLOBAL input - SELECT CASE (TRIM(CSTRG)) - CASE ('T','t','.TRU','.tru') - ICLOSE = ICLOSE_SMPL - WRITE (NDSO,3002) 'simple' - WRITE (NDSE,1013) - CASE ('F','f','.FAL','.fal') - ICLOSE = ICLOSE_NONE - WRITE (NDSO,3002) 'none' - WRITE (NDSE,1013) - CASE DEFAULT - WRITE (NDSE,1012) TRIM(CSTRG) - CALL EXTCDE ( 25 ) - END SELECT - END SELECT - IF ( ICLOSE.NE.ICLOSE_NONE .AND. .NOT.FLAGLL ) THEN - WRITE (NDSE,1008) - CALL EXTCDE ( 25 ) - END IF - END IF !GTYPE.NE.UNGTYPE -! -! 7.b Size of grid -! - IF (FLGNML) THEN - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares domain info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - NX = NML_RECT%NX - NY = NML_RECT%NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - CASE ( CLGTYPE ) - NX = NML_CURV%NX - NY = NML_CURV%NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - CASE ( UNGTYPE ) - NY=1 - END SELECT - ELSE - IF ( GTYPE.NE.UNGTYPE) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NX, NY - NX = MAX ( 3 , NX ) - NY = MAX ( 3 , NY ) - WRITE (NDSO,3003) NX, NY - ELSE - NY =1 - END IF - END IF -! -! Propagation specific to unstructured grids -! - DO_CHANGE_WLV=.FALSE. - IF ( GTYPE.EQ.UNGTYPE) THEN - UNSTSCHEMES(:)=0 - IF (EXPFSN) UNSTSCHEMES(1)=1 - IF (EXPFSPSI) UNSTSCHEMES(2)=1 - IF (EXPFSFCT) UNSTSCHEMES(3)=1 - IF (IMPFSN) UNSTSCHEMES(4)=1 - UNSTSCHEME=-1 - DO IX=1,4 - IF (UNSTSCHEMES(IX).EQ.1) THEN - UNSTSCHEME=IX - EXIT - END IF - END DO - - FSBCCFL = UGBCCFL - SELECT CASE (UNSTSCHEME) - CASE (1) - FSN = EXPFSN - PNAME2 = 'N Explicit (Fluctuation Splitting) ' - CASE (2) - FSPSI = EXPFSPSI - PNAME2 = 'PSI Explicit (Fluctuation Splitting) ' - CASE (3) - FSFCT = EXPFSFCT - PNAME2 = ' Flux Corrected Transport Explicit' - CASE (4) - FSNIMP = IMPFSN - PNAME2 = 'N Implicit (Fluctuation Splitting) ' - END SELECT -! - IF (SUM(UNSTSCHEMES).GT.1) WRITE(NDSO,1035) - WRITE (NDSO,2951) PNAME2 - IF (IMPTOTAL) THEN - FSTOTALIMP = IMPTOTAL - PNAME2 = 'N Implicit (Fluctuation Splitting) for total implicit' - END IF - IF (EXPTOTAL) THEN - FSTOTALEXP = EXPTOTAL - PNAME2 = 'N Explicit (Fluctuation Splitting) for one exchange explicit DC HPCF ' - END IF - IF (IMPREFRACTION .and. IMPTOTAL .AND. FLCTH) THEN - FSREFRACTION = .TRUE. - PNAME2 = 'Refraction done implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSREFRACTION = .FALSE. - END IF - IF (IMPFREQSHIFT .and. IMPTOTAL .AND. FLCK) THEN - FSFREQSHIFT = .TRUE. - PNAME2 = 'Frequency shifting done implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSFREQSHIFT = .FALSE. - END IF - IF (IMPSOURCE .and. IMPTOTAL .AND. FLSOU) THEN - FSSOURCE = .TRUE. - PNAME2 = 'Source terms integrated implicitly' - WRITE (NDSO,2951) PNAME2 - ELSE - FSSOURCE = .FALSE. - END IF - IF (SETUP_APPLY_WLV) THEN - DO_CHANGE_WLV = SETUP_APPLY_WLV - PNAME2 = ' we change WLV' - WRITE (NDSO,2952) PNAME2 - END IF - SOLVERTHR_STP = SOLVERTHR_SETUP - CRIT_DEP_STP = CRIT_DEP_SETUP - END IF - -! -! 7.c Grid coordinates (branch here based on grid type) -! - IF ( GTYPE.NE.UNGTYPE) ALLOCATE ( XGRDIN(NX,NY), YGRDIN(NX,NY) ) - SELECT CASE ( GTYPE ) -! -! 7.c.1 Rectilinear grid -! -!!Li SMC grid shares domain info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) -! - IF (FLGNML) THEN - SX = NML_RECT%SX - SY = NML_RECT%SY - VSC = NML_RECT%SF - X0 = NML_RECT%X0 - Y0 = NML_RECT%Y0 - VSC0 = NML_RECT%SF0 - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) SX, SY, VSC - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) X0, Y0, VSC0 - END IF -! - VSC = MAX ( 1.E-7 , VSC ) - SX = SX / VSC - SY = SY / VSC - SX = MAX ( 1.E-7 , SX ) - SY = MAX ( 1.E-7 , SY ) - IF ( ICLOSE.EQ.ICLOSE_SMPL ) SX = 360. / REAL(NX) -! - VSC0 = MAX ( 1.E-7 , VSC0 ) - X0 = X0 / VSC0 - Y0 = Y0 / VSC0 -! - IF ( FLAGLL ) THEN - WRITE (NDSO,3004) FACTOR*SX, FACTOR*SY, & - FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & - FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) - ELSE - WRITE (NDSO,3005) FACTOR*SX, FACTOR*SY, & - FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & - FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) - END IF -! - DO IY=1, NY - DO IX=1, NX - XGRDIN(IX,IY) = X0 + REAL(IX-1)*SX - YGRDIN(IX,IY) = Y0 + REAL(IY-1)*SY - END DO - END DO -! -! 7.c.2 Curvilinear grid -! - CASE ( CLGTYPE ) -! -! 7.c.2.a Process x-coordinates -! - IF (FLGNML) THEN - NDSG = NML_CURV%XCOORD%IDF - VSC = NML_CURV%XCOORD%SF - VOF = NML_CURV%XCOORD%OFF - IDLA = NML_CURV%XCOORD%IDLA - IDFM = NML_CURV%XCOORD%IDFM - RFORM = TRIM(NML_CURV%XCOORD%FORMAT) - FROM = TRIM(NML_CURV%XCOORD%FROM) - FNAME = TRIM(NML_CURV%XCOORD%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & - IDLA, IDFM, RFORM, FROM, FNAME - END IF -! - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,3006) NDSG, VSC, VOF, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,3009) TRIM(FNAME) -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - IF (.NOT.FLGNML) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - END IF - ELSE - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF !IDFM - END IF !NDSG -! - CALL INA2R ( XGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF) -! -! 7.c.2.b Process y-coordinates -! - IF (FLGNML) THEN - NDSG = NML_CURV%YCOORD%IDF - VSC = NML_CURV%YCOORD%SF - VOF = NML_CURV%YCOORD%OFF - IDLA = NML_CURV%YCOORD%IDLA - IDFM = NML_CURV%YCOORD%IDFM - RFORM = TRIM(NML_CURV%YCOORD%FORMAT) - FROM = TRIM(NML_CURV%YCOORD%FROM) - FNAME = TRIM(NML_CURV%YCOORD%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & - IDLA, IDFM, RFORM, FROM, FNAME - END IF -! - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,3007) NDSG, VSC, VOF, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,3009) TRIM(FNAME) -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - IF (.NOT.FLGNML) THEN - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - END IF - ELSE - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF !IDFM - END IF !NDSG -! - CALL INA2R ( YGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, VOF) -! -! 7.c.2.c Check for obvious errors in grid definition or input -! -! ....... Check for inverted grid (can result from wrong IDLA) - IF ( (XGRDIN(2,1)-XGRDIN(1,1))*(YGRDIN(1,2)-YGRDIN(1,1)) .LT. & - (YGRDIN(2,1)-YGRDIN(1,1))*(XGRDIN(1,2)-XGRDIN(1,1)) ) THEN - WRITE (NDSE,1011) IDLA -!.........Notes: here, we are checking to make sure that the j axis is ~90 degrees -!................counter-clockwise from the i axis (the standard cartesian setup). -!................So, it is a check on the handedness of the grid. -!................We have confirmed for one case that a left-handed grid produces -!................errors in SCRIP. We have not confirmed that left-handed grids necessarily -!................produce errors in single-grid simulations, or that they necessarily -!................produce errors in all multi-grid simulations. -!................Note that transposing or flipping a grid will generally change the handedness. - CALL EXTCDE (25) - END IF -! -! 7.c.3 Unstructured grid -! - CASE ( UNGTYPE ) -! - MAXX = 0. - MAXY = 0. - DXYMAX = 0. - WRITE (NDSO,1150) - - IF (FLGNML) THEN - ZLIM = NML_GRID%ZLIM - DMIN = NML_GRID%DMIN - NDSG = NML_UNST%IDF - VSC = NML_UNST%SF - IDLA = NML_UNST%IDLA - IDFM = NML_UNST%IDFM - RFORM = TRIM(NML_UNST%FORMAT) - FROM = 'NAME' - FNAME = TRIM(NML_UNST%FILENAME) - UGOBCFILE = TRIM(NML_UNST%UGOBCFILE) - END IF - END SELECT !GTYPE -! -! 7.d Depth information for grid -! - IF (FLGNML) THEN - IF (GTYPE.NE.UNGTYPE) THEN - ZLIM = NML_GRID%ZLIM - DMIN = NML_GRID%DMIN - NDSG = NML_DEPTH%IDF - VSC = NML_DEPTH%SF - IDLA = NML_DEPTH%IDLA - IDFM = NML_DEPTH%IDFM - RFORM = TRIM(NML_DEPTH%FORMAT) - FROM = TRIM(NML_DEPTH%FROM) - FNAME = TRIM(NML_DEPTH%FILENAME) - END IF - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) ZLIM, DMIN, NDSG, VSC, IDLA, & - IDFM, RFORM, FROM, FNAME - END IF -! - DMIN = MAX ( 1.E-3 , DMIN ) - IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 -! - WRITE (NDSO,972) NDSG, ZLIM, DMIN, VSC, IDLA, IDFM - IF (IDFM.EQ.2) WRITE (NDSO,973) TRIM(RFORM) - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & - WRITE (NDSO,974) TRIM(FNAME) -! -! 7.e Read bottom depths -! - IF ( GTYPE.NE.UNGTYPE ) THEN -! -! Reading depths on structured grid -! - ALLOCATE ( ZBIN(NX,NY), OBSX(NX,NY), OBSY(NX,NY) ) -! -! Initialize subgrid obstructions with zeros. - ZBIN(:,:)=0. - OBSX(:,:)=0. - OBSY(:,:)=0. - -!Li Suspended for SMC grid, which uses depth stored in its cell array. -!Li JGLi15Oct2014 - IF( GTYPE .NE. SMCTYPE ) THEN -! - IF ( NDSG .EQ. NDSI ) THEN - IF ( IDFM .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSG - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE ! NDSG.NE.NDSI - IF ( IDFM .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & - FORM='UNFORMATTED',& - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSG, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF - END IF !( NDSG .EQ. NDSI ) -! - CALL INA2R ( ZBIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & - IDFM, RFORM, IDLA, VSC, 0.0) -! -!Li End of IF( GTYPE .NE. SMCTYPE ) block - ENDIF -! - ELSE -! -! Reading depths on unstructured grid (this also sets number of mesh points, NX) -! - CALL READMSH(NDSG,FNAME) - ALLOCATE(ZBIN(NX, NY),OBSX(NX,NY),OBSY(NX,NY)) - ZBIN(:,1) = VSC*XYB(:,3) -!/DEBUGSTP WRITE(740,*) 'VSC=', VSC -!/DEBUGSTP WRITE(740,*) 'Printing ZBIN 1' -!/DEBUGSTP DO IX=1,NX -!/DEBUGSTP WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) -!/DEBUGSTP END DO -! -! subgrid obstructions are not yet handled in unstructured grids -! - OBSX(:,:)=0. - OBSY(:,:)=0. - - END IF -! -! 7.f Set up temporary map -! - ALLOCATE ( TMPSTA(NY,NX), TMPMAP(NY,NX) ) - TMPSTA = 0 -! -!/DEBUGSTP WRITE(740,*) 'Printing ZBIN 2' -!/DEBUGSTP DO IX=1,NX -!/DEBUGSTP WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) -!/DEBUGSTP END DO - IF (GTYPE .EQ. UNGTYPE) THEN - TMPSTA = 1 - ELSE - DO IY=1, NY - DO IX=1, NX - IF ( ZBIN(IX,IY) .LE. ZLIM ) TMPSTA(IY,IX) = 1 - END DO - END DO - ENDIF -! -!Li Suspended for SMC grid. JGLi15Oct2014 - IF( GTYPE .NE. SMCTYPE ) THEN -! -! 7.g Subgrid information -! - TRFLAG = FLAGTR - IF ( TRFLAG.GT.6 .OR. TRFLAG.LT.0 ) TRFLAG = 0 -! - IF ( TRFLAG .EQ. 0 ) THEN - WRITE (NDSO,976) 'Not available.' - ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN - WRITE (NDSO,976) 'In between grid points.' - ELSE - WRITE (NDSO,976) 'At grid points.' - END IF -! - IF ( TRFLAG .NE. 0 ) THEN -! -! 7.g.1 Info from input file -! - IF (FLGNML) THEN - NDSTR = NML_OBST%IDF - VSC = NML_OBST%SF - IDLA = NML_OBST%IDLA - IDFT = NML_OBST%IDFM - RFORM = TRIM(NML_OBST%FORMAT) - FROM = TRIM(NML_OBST%FROM) - TNAME = TRIM(NML_OBST%FILENAME) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & - FROM, TNAME - END IF -! - IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -! - WRITE (NDSO,977) NDSTR, VSC, IDLA, IDFT - IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM - IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -! -! 7.g.2 Open file and check if necessary -! - IF ( NDSTR .EQ. NDSI ) THEN - IF ( IDFT .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSTR - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE IF ( NDSTR .EQ. NDSG ) THEN - IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & - ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN - WRITE (NDSE,1005) IDFM, IDFT - CALL EXTCDE (24) - END IF - ELSE - IF ( IDFT .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - ELSE - OPEN (NDSTR, FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF - END IF -! -! 7.g.3 Read the data -! - CALL INA2R ( OBSX, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFT, RFORM, IDLA, VSC, 0.0) -! - IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -! - CALL INA2R ( OBSY, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & - IDFT, RFORM, IDLA, VSC, 0.0) -! -! 7.g.4 Limit -! - DO IX=1, NX - DO IY=1, NY - OBSX(IX,IY) = MAX( 0. , MIN(1.,OBSX(IX,IY)) ) - OBSY(IX,IY) = MAX( 0. , MIN(1.,OBSY(IX,IY)) ) - END DO - END DO -! - WRITE (NDSO,*) -! - END IF ! TRFLAG -! -!Li End of IF( GTYPE .NE. SMCTYPE ) block - END IF -! -!/RTD ! 7.h Calculate rotation angles for configs with rotated pole -!/RTD PoLon = PLON -!/RTD PoLat = PLAT -!/RTD FLAGUNR = UNROT -!/RTD ! Default values PLON=-180, PLAT=90, UNROT=.FALSE. for standard lat-lon -!/RTD -!/RTD ALLOCATE( AnglDin(NX,NY) ) -!/RTD ! For standard lat-lon the rotation angles are zero -!/RTD IF ( PoLat == 90. ) THEN -!/RTD AnglDin = 0. -!/RTD ELSE -!/RTD ALLOCATE(StdLat(NX,NY), StdLon(NX,NY)) -!/RTD -!/RTD ! Calculate rotation angles; (StdLon/Lat are returned, but not used) -!/RTD ! The regular grid X/YGRDIN are used as equatorial lon and lat -!/RTD CALL W3EQTOLL( YGRDIN, XGRDIN, StdLat, StdLon, AnglDin, & -!/RTD PoLat, PoLon, NX*NY ) -!/RTD -!/RTD ! Clean up -!/RTD DEALLOCATE( StdLat, StdLon ) -!/RTD END IF -!/RTD ! Write out rotation information -!/RTD WRITE (NDSO,4203) PoLat, PoLon -!/RTD WRITE (NDSO,4200) -!/RTD WRITE (NDSO,4201) ( IX, IX=1,NX,NX/3) -!/RTD WRITE (NDSO,4202) 1,(AnglDin(IX, 1), IX=1,NX,NX/3) -!/RTD WRITE (NDSO,4202) NY,(AnglDin(IX,NY), IX=1,NX,NX/3) -!/RTD IF ( FLAGUNR ) WRITE (NDSO,4204) -!/RTD WRITE (NDSO,*) ' ' -!/RTD -! -!/SMC !! 7.i Read SMC grid cell and face integer arrays. -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC -!/SMC !! Overwrite 2 parameters for SMC grid. JGLi03Mar2021 -!/SMC DTMS = DTIMS -!/SMC CTMAX = CFLSM -! -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%MCELS%IDF -!/SMC IDLA = NML_SMC%MCELS%IDLA -!/SMC IDFM = NML_SMC%MCELS%IDFM -!/SMC RFORM = TRIM(NML_SMC%MCELS%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%MCELS%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC ALLOCATE ( NLvCelsk( 0:NRLv ) ) -!/SMC READ (NDSTR,*) NLvCelsk -!/SMC NCel=NLvCelsk(0) -!/SMC NGLO=NCel -!/SMC WRITE (NDSO,4004) NCel, NLvCelsk -!/SMC -!/SMC ALLOCATE ( IJKCelin( 5, NCel) ) -!/SMC CALL INA2I ( IJKCelin, 5, NCel, 1, 5, 1, NCel, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index JEQT -!/SMC IJKCelin( 2, :) = IJKCelin( 2, :) + JEQT -!/SMC !!Li Offset to change i-index = 0 to regular grid index ISHFT -!/SMC IJKCelin( 1, :) = IJKCelin( 1, :) + ISHFT -!/SMC -!/SMC WRITE (NDSO,4005) TNAME -!/SMC WRITE (NDSO,4006) 1,(IJKCelin(ix, 1), ix=1,5) -!/SMC WRITE (NDSO,4006) NCel,(IJKCelin(ix, NCel), ix=1,5) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%ISIDE%IDF -!/SMC IDLA = NML_SMC%ISIDE%IDLA -!/SMC IDFM = NML_SMC%ISIDE%IDFM -!/SMC RFORM = TRIM(NML_SMC%ISIDE%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%ISIDE%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC ALLOCATE ( NLvUFcsk( 0:NRLv ) ) -!/SMC READ (NDSTR,*) NLvUFcsk -!/SMC NUFc = NLvUFcsk(0) -!/SMC NGUI = NUFc -!/SMC WRITE (NDSO,4007) NUFc, NLvUFcsk -!/SMC -!/SMC ALLOCATE ( IJKUFcin( 7, NUFc) ) -!/SMC CALL INA2I ( IJKUFcin, 7, NUFc, 1, 7, 1, NUFc, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index -!/SMC IJKUFcin( 2, :) = IJKUFcin( 2, :) + JEQT -!/SMC IJKUFcin( 1, :) = IJKUFcin( 1, :) + ISHFT -!/SMC -!/SMC WRITE (NDSO,4008) TNAME -!/SMC WRITE (NDSO,4009) 1,(IJKUFcin(ix, 1), ix=1,7) -!/SMC WRITE (NDSO,4009) NUFc,(IJKUFcin(ix, NUFc), ix=1,7) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%JSIDE%IDF -!/SMC IDLA = NML_SMC%JSIDE%IDLA -!/SMC IDFM = NML_SMC%JSIDE%IDFM -!/SMC RFORM = TRIM(NML_SMC%JSIDE%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%JSIDE%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC ALLOCATE ( NLvVFcsk( 0:NRLv ) ) -!/SMC READ (NDSTR,*) NLvVFcsk -!/SMC NVFc= NLvVFcsk(0) -!/SMC NGVJ= NVFc -!/SMC WRITE (NDSO,4010) NVFc, NLvVFcsk -!/SMC -!/SMC ALLOCATE ( IJKVFcin( 8, NVFc) ) -!/SMC CALL INA2I ( IJKVFcin, 8, NVFc, 1, 8, 1, NVFc, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index -!/SMC IJKVFcin( 2, :) = IJKVFcin( 2, :) + JEQT -!/SMC IJKVFcin( 1, :) = IJKVFcin( 1, :) + ISHFT -!/SMC -!/SMC WRITE (NDSO,4011) TNAME -!/SMC WRITE (NDSO,4012) 1,(IJKVFcin(ix, 1), ix=1,8) -!/SMC WRITE (NDSO,4012) NVFc,(IJKVFcin(ix, NVFc), ix=1,8) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC !!Li Subgrid obstruction for each SMCels. JGLi15Oct2014 -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%SUBTR%IDF -!/SMC IDLA = NML_SMC%SUBTR%IDLA -!/SMC IDFM = NML_SMC%SUBTR%IDFM -!/SMC RFORM = TRIM(NML_SMC%SUBTR%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%SUBTR%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC READ (NDSTR,*) NCObst, JObs -!/SMC WRITE (NDSO,4110) NCObst, JObs -!/SMC -!/SMC ALLOCATE ( IJKObstr( JObs, NCObst) ) -!/SMC CALL INA2I ( IJKObstr, JObs, NCObst, 1, JObs, 1, NCObst, NDSTR, NDST, & -!/SMC NDSE, IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC -!/SMC WRITE (NDSO,4111) TNAME -!/SMC WRITE (NDSO,4012) 1, (IJKObstr(ix, 1), ix=1,JObs) -!/SMC WRITE (NDSO,4012) NCObst, (IJKObstr(ix, NCObst), ix=1,JObs) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC !!Li Bounary cell sequential numbers are read only if NBISMC>0 -!/SMC IF( NBISMC .GT. 0 ) THEN -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%BUNDY%IDF -!/SMC IDLA = NML_SMC%BUNDY%IDLA -!/SMC IDFM = NML_SMC%BUNDY%IDFM -!/SMC RFORM = TRIM(NML_SMC%BUNDY%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%BUNDY%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC ALLOCATE ( NBICelin( NBISMC ) ) -!/SMC CALL INA2I ( NBICelin, 1, NBISMC, 1, 1, 1, NBISMC, NDSTR, NDST, & -!/SMC NDSE, IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC -!/SMC WRITE (NDSO,4013) TNAME -!/SMC WRITE (NDSO,4014) 1, NBICelin( 1) -!/SMC WRITE (NDSO,4014) NBISMC, NBICelin(NBISMC) -!/SMC WRITE (NDSO,*) ' ' -!/SMC ENDIF -!/SMC -! -!/SMC !! 7.j Read Arctic grid cell and boundary cell integer arrays. -!/SMC IF( ARCTC ) THEN -!/SMC -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%MBARC%IDF -!/SMC IDLA = NML_SMC%MBARC%IDLA -!/SMC IDFM = NML_SMC%MBARC%IDFM -!/SMC RFORM = TRIM(NML_SMC%MBARC%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%MBARC%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC READ (NDSTR,*) NARC, NBGL, NBAC -!/SMC WRITE (NDSO,4015) NARC, NBGL, NBAC -!/SMC -!/SMC ALLOCATE ( IJKCelAC( 5, NARC) ) -!/SMC CALL INA2I ( IJKCelAC, 5, NARC, 1, 5, 1, NARC, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index JEQT -!/SMC IJKCelAC( 2, :) = IJKCelAC( 2, :) + JEQT -!/SMC IJKCelAC( 1, :) = IJKCelAC( 1, :) + ISHFT -!/SMC -!/SMC WRITE (NDSO,4016) TNAME -!/SMC WRITE (NDSO,4006) 1,(IJKCelAC(ix, 1), ix=1,5) -!/SMC WRITE (NDSO,4006) NARC,(IJKCelAC(ix, NARC), ix=1,5) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%AISID%IDF -!/SMC IDLA = NML_SMC%AISID%IDLA -!/SMC IDFM = NML_SMC%AISID%IDFM -!/SMC RFORM = TRIM(NML_SMC%AISID%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%AISID%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC READ (NDSTR,*) NAUI -!/SMC WRITE (NDSO,4017) NAUI -!/SMC -!/SMC ALLOCATE ( IJKUFcAC( 7, NAUI) ) -!/SMC CALL INA2I ( IJKUFcAC, 7, NAUI, 1, 7, 1, NAUI, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index -!/SMC IJKUFcAC( 2, :) = IJKUFcAC( 2, :) + JEQT -!/SMC IJKUFcAC( 1, :) = IJKUFcAC( 1, :) + ISHFT -!/SMC !!Li Offset Arctic cell sequential numbers by global cell number NGLO -!/SMC DO IP=1, NAUI -!/SMC DO IX=4,7 -!/SMC IF( IJKUFcAC(IX,IP) > 0 ) IJKUFcAC(IX,IP) = IJKUFcAC(IX,IP) + NGLO -!/SMC ENDDO -!/SMC ENDDO -!/SMC -!/SMC WRITE (NDSO,4018) TNAME -!/SMC WRITE (NDSO,4009) 1,(IJKUFcAC(ix, 1), ix=1,7) -!/SMC WRITE (NDSO,4009) NAUI,(IJKUFcAC(ix, NAUI), ix=1,7) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC IF (FLGNML) THEN -!/SMC NDSTR = NML_SMC%AJSID%IDF -!/SMC IDLA = NML_SMC%AJSID%IDLA -!/SMC IDFM = NML_SMC%AJSID%IDFM -!/SMC RFORM = TRIM(NML_SMC%AJSID%FORMAT) -!/SMC TNAME = TRIM(NML_SMC%AJSID%FILENAME) -!/SMC ELSE -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME -!/SMC END IF -!/SMC OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/SMC FORM='FORMATTED',STATUS='OLD',ERR=2000) -!/SMC READ (NDSTR,*) NAVJ -!/SMC WRITE (NDSO,4019) NAVJ -!/SMC -!/SMC ALLOCATE ( IJKVFcAC( 8, NAVJ) ) -!/SMC CALL INA2I ( IJKVFcAC, 8, NAVJ, 1, 8, 1, NAVJ, NDSTR, NDST, NDSE, & -!/SMC IDFM, RFORM, IDLA, 1, 0) -!/SMC CLOSE(NDSTR) -!/SMC !!Li Offset to change Equator index = 0 to regular grid index -!/SMC IJKVFcAC( 2, :) = IJKVFcAC( 2, :) + JEQT -!/SMC IJKVFcAC( 1, :) = IJKVFcAC( 1, :) + ISHFT -!/SMC !!Li Offset Arctic cell sequential numbers by global cell number NGLO -!/SMC DO IP=1, NAVJ -!/SMC DO IY=4,7 -!/SMC IF( IJKVFcAC(IY,IP) > 0 ) IJKVFcAC(IY,IP) = IJKVFcAC(IY,IP) + NGLO -!/SMC ENDDO -!/SMC ENDDO -!/SMC -!/SMC WRITE (NDSO,4020) TNAME -!/SMC WRITE (NDSO,4012) 1,(IJKVFcAC(ix, 1), ix=1,8) -!/SMC WRITE (NDSO,4012) NAVJ,(IJKVFcAC(ix, NAVJ), ix=1,8) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC !!Li Reset total cell and face numbers -!/SMC NCel = NGLO + NARC -!/SMC NUFc = NGUI + NAUI -!/SMC NVFc = NGVJ + NAVJ -!/SMC !!Li Also append Arctic part into base level sub-loops -!/SMC NLvCelsk(NRLv)=NLvCelsk(NRLv)+NARC -!/SMC NLvUFcsk(NRLv)=NLvUFcsk(NRLv)+NAUI -!/SMC NLvVFcsk(NRLv)=NLvVFcsk(NRLv)+NAVJ -!/SMC !!Li Reset NBAC to total number of boundary cells. -!/SMC NBAC = NBGL + NBAC -!/SMC -!/SMC ENDIF !! ARCTC section. -!/SMC -!/SMC ENDIF !! GTYPE .EQ. SMCTYPE -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 8. Finalize status maps -! 8.a Defines open boundary conditions for UNST grids -! - J = LEN_TRIM(UGOBCFILE) - IF (GTYPE.EQ.UNGTYPE.AND.UGOBCFILE(:J).NE.'unset') & - CALL READMSHOBC(NDSG,UGOBCFILE,TMPSTA,UGOBCOK) - IF ((GTYPE.EQ.UNGTYPE).AND.UGOBCAUTO.AND.(.NOT.UGOBCOK)) & - CALL UG_GETOPENBOUNDARY(TMPSTA,ZBIN,UGOBCDEPTH) -!/DEBUGSTP WRITE(740,*) 'Printing ZBIN 4' -!/DEBUGSTP DO IX=1,NX -!/DEBUGSTP WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) -!/DEBUGSTP END DO -! -! 8.b Determine where to get the data -! - IF (FLGNML) THEN - NDSTR = NML_MASK%IDF - IDLA = NML_MASK%IDLA - IDFT = NML_MASK%IDFM - RFORM = TRIM(NML_MASK%FORMAT) - FROM = TRIM(NML_MASK%FROM) - TNAME = TRIM(NML_MASK%FILENAME) - IF (TNAME.EQ.'unset' .OR. TNAME.EQ.'UNSET') FROM='PART' - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFT, RFORM, & - FROM, TNAME - END IF -! -! ... Data to be read in parts -! -!/DEBUGGRID WRITE(740+IAPROC,*) 'FROM=', TRIM(FROM) - IF ( FROM .EQ. 'PART' ) THEN -! -! 8.b Update TMPSTA with input boundary data (ILOOP=1) -! and excluded points (ILOOP=2) -! - IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN - WRITE(NDSE,*)'PROGRAM W3GRID STATUS MAP CALCULATION IS '// & - 'NOT TESTED FOR TRIPOLE GRIDS FOR CASE WHERE USER OPTS '// & - 'TO READ DATA IN PARTS. STOPPING NOW (107).' - CALL EXTCDE ( 107 ) - END IF -!/DEBUGGRID nbCase1=0 -!/DEBUGGRID nbCase2=0 -!/DEBUGGRID nbCase3=0 -!/DEBUGGRID nbCase4=0 -!/DEBUGGRID nbCase5=0 -!/DEBUGGRID nbCase6=0 -!/DEBUGGRID nbCase7=0 -!/DEBUGGRID nbCase8=0 - DO ILOOP=1, 2 -! - I = 1 - IF ( ILOOP .EQ. 1 ) THEN - WRITE (NDSO,979) 'boundary points' - NSTAT = 2 - ELSE - WRITE (NDSO,979) 'excluded points' - NSTAT = -1 - END IF - FIRST = .TRUE. -! - DO - IF (FLGNML) THEN - ! inbound points - IF (ILOOP.EQ.1) THEN - IF (NML_INBND_COUNT%N_POINT.GT.0 .AND. I.LE.NML_INBND_COUNT%N_POINT) THEN - IX = NML_INBND_POINT(I)%X_INDEX - IY = NML_INBND_POINT(I)%Y_INDEX - CONNCT = NML_INBND_POINT(I)%CONNECT - I=I+1 - ELSE - EXIT - END IF - ! excluded points - ELSE IF (ILOOP.EQ.2) THEN - IF (NML_EXCL_COUNT%N_POINT.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_POINT) THEN - IX = NML_EXCL_POINT(I)%X_INDEX - IY = NML_EXCL_POINT(I)%Y_INDEX - CONNCT = NML_EXCL_POINT(I)%CONNECT - I=I+1 - ELSE - EXIT - END IF - END IF - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) IX, IY, CONNCT - END IF -!/DEBUGGRID WRITE(740+IAPROC,*) 'read IX=', IX -!/DEBUGGRID WRITE(740+IAPROC,*) 'read IY=', IY -!/DEBUGGRID WRITE(740+IAPROC,*) 'read CONNCT=', CONNCT - -! -! ... Check if last point reached. -! - IF (IX.EQ.0 .AND. IY.EQ.0) EXIT -! -! ... Check if point in grid. -! - IF (GTYPE.EQ.UNGTYPE.AND.(UGOBCAUTO.OR.UGOBCOK)) CYCLE - IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN - WRITE (NDSO,981) - WRITE (NDSO,*) ' ', IX, IY - CYCLE - END IF -! -! ... Check if intermediate points are to be added. -! -!/DEBUGGRID WRITE(740+IAPROC,*) 'CONNCT=', CONNCT -!/DEBUGGRID WRITE(740+IAPROC,*) 'FIRST=', FIRST - IF ( CONNCT .AND. .NOT.FIRST ) THEN - IDX = IX - IXO - IDY = IY - IYO - IF ( IDX.EQ.0 .OR. IDY.EQ.0 .OR. & - ABS(IDX).EQ.ABS(IDY) ) THEN - NBA = MAX ( MAX(ABS(IDX),ABS(IDY))-1 , 0 ) - IF (IDX.NE.0) IDX = SIGN(1,IDX) - IF (IDY.NE.0) IDY = SIGN(1,IDY) - IX = IXO - IY = IYO - DO IBA=1, NBA - IX = IX + IDX - IY = IY + IDY - IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN - TMPSTA(IY,IX) = NSTAT - ELSE - WRITE(NDSO,*) 'WARNING: POINT (',IX,',',IY, & - ') CANNOT BE GIVEN THE STATUS ',NSTAT - END IF - END DO - IX = IX + IDX - IY = IY + IDY - ELSE - WRITE (NDSO,982) - WRITE (NDSO,*) ' ', IX , IY - WRITE (NDSO,*) ' ', IXO, IYO - END IF - END IF -! -! ... Check if point itself is to be added -! - IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN -!/DEBUGGRID nbCase2=nbCase2+1 - TMPSTA(IY,IX) = NSTAT - END IF -! -! ... Save data of previous point -! - IXO = IX - IYO = IY - FIRST = .FALSE. -! -! ... Branch back to read. -! - END DO -! -! 8.c Final processing excluded points -! - IF ( ILOOP .EQ. 2 ) THEN -! - I = 1 - DO - IF (FLGNML) THEN - ! excluded bodies - IF (NML_EXCL_COUNT%N_BODY.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_BODY) THEN - IX = NML_EXCL_BODY(I)%X_INDEX - IY = NML_EXCL_BODY(I)%Y_INDEX - I=I+1 - ELSE - EXIT - END IF - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - READ (NDSI,*,END=2001,ERR=2002) IX, IY - END IF -! -! ... Check if last point reached. -! - IF (IX.EQ.0 .AND. IY.EQ.0) EXIT -! -! ... Check if point in grid. -! - IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN - WRITE (NDSO,981) - WRITE (NDSO,*) ' ', IX, IY - CYCLE - END IF -! -! ... Check if point already excluded -! - IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN - WRITE (NDSO,1981) - WRITE (NDSO,*) ' ', IX, IY - CYCLE - END IF -! -! ... Search for points to exclude -! - TMPMAP = TMPSTA - J = 1 - IX1 = IX - IY1 = IY -! - JJ = TMPSTA(IY,IX) -!/DEBUGGRID nbCase3=nbCase3 + 1 - TMPSTA(IY,IX) = NSTAT - DO - NBT = 0 - DO IX=MAX(1,IX1-J), MIN(IX1+J,NX) - DO IY=MAX(1,IY1-J), MIN(IY1+J,NY) - IF ( TMPSTA(IY,IX) .EQ. JJ ) THEN - IF (IX.GT.1) THEN - IF (TMPSTA(IY ,IX-1).EQ.NSTAT & - .AND. TMPMAP(IY ,IX-1).EQ.JJ ) THEN -!/DEBUGGRID nbCase4=nbCase4 + 1 - TMPSTA(IY,IX) = NSTAT - END IF - END IF - IF (IX.LT.NX) THEN - IF (TMPSTA(IY ,IX+1).EQ.NSTAT & - .AND. TMPMAP(IY ,IX+1).EQ.JJ ) THEN -!/DEBUGGRID nbCase5=nbCase5 + 1 - TMPSTA(IY,IX) = NSTAT - END IF - END IF - IF (IY.LT.NY) THEN - IF (TMPSTA(IY+1,IX ).EQ.NSTAT & - .AND. TMPMAP(IY+1,IX ).EQ.JJ ) THEN -!/DEBUGGRID nbCase6=nbCase6 + 1 - TMPSTA(IY,IX) = NSTAT - END IF - END IF - IF (IY.GT.1) THEN - IF (TMPSTA(IY-1,IX ).EQ.NSTAT & - .AND. TMPMAP(IY-1,IX ).EQ.JJ ) THEN -!/DEBUGGRID nbCase7=nbCase7 + 1 - TMPSTA(IY,IX) = NSTAT - END IF - END IF - IF (TMPSTA(IY,IX).EQ.NSTAT) NBT = NBT + 1 - END IF - END DO - END DO -! - IF ( NBT .NE. 0 ) THEN - J = J + 1 - ELSE - EXIT - END IF - END DO - END DO -! -! ... Outer boundary excluded points -! - IF ( GTYPE.NE.UNGTYPE ) THEN - - DO IX=1, NX - IF ( TMPSTA( 1,IX) .EQ. 1 ) TMPSTA( 1,IX) = NSTAT - IF ( TMPSTA(NY,IX) .EQ. 1 ) TMPSTA(NY,IX) = NSTAT - END DO -! - IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN - DO IY=2, NY-1 - IF ( TMPSTA(IY, 1) .EQ. 1 ) TMPSTA(IY, 1) = NSTAT - IF ( TMPSTA(IY,NX) .EQ. 1 ) TMPSTA(IY,NX) = NSTAT - END DO - END IF - - END IF ! GTYPE -! - END IF ! ILOOP .EQ. 2 -! -! ... Branch back input / excluded points ( ILOOP in 8.b ) -! - END DO -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase1=', nbCase1 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase2=', nbCase2 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase3=', nbCase3 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase4=', nbCase4 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase5=', nbCase5 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase6=', nbCase6 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase7=', nbCase7 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbCase8=', nbCase8 -!/DEBUGGRID nbTMPSTA0=0 -!/DEBUGGRID nbTMPSTA1=0 -!/DEBUGGRID nbTMPSTA2=0 -!/DEBUGGRID DO IX=1,NX -!/DEBUGGRID DO IY=1,NY -!/DEBUGGRID WRITE(740+IAPROC,*) 'IX/IY/TMPSTA=', IX, IY, TMPSTA(IY,IX) -!/DEBUGGRID IF (TMPSTA(IY,IX) .eq. 0) nbTMPSTA0=nbTMPSTA0+1 -!/DEBUGGRID IF (TMPSTA(IY,IX) .eq. 1) nbTMPSTA1=nbTMPSTA1+1 -!/DEBUGGRID IF (TMPSTA(IY,IX) .eq. 2) nbTMPSTA2=nbTMPSTA2+1 -!/DEBUGGRID END DO -!/DEBUGGRID END DO -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbTMPSTA0=', nbTMPSTA0 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbTMPSTA1=', nbTMPSTA1 -!/DEBUGGRID WRITE(740+IAPROC,*) 'nbTMPSTA2=', nbTMPSTA2 -!/DEBUGGRID FLUSH(740+IAPROC) -! - ELSE ! FROM .EQ. PART -! -! 8.d Read the map from file instead -! - NSTAT = -1 - IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 - IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 - -!!Li Suspended for SMC grid though the file input line in ww3_grid.inp -!!Li is kept to divert the program into this block. JGLi15Oct2014 -!!Li - IF( GTYPE .NE. SMCTYPE ) THEN -!!Li -! - WRITE (NDSO,978) NDSTR, IDLA, IDFT - IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM - IF (FROM.EQ.'NAME') WRITE (NDSO,974) TNAME -! - IF ( NDSTR .EQ. NDSI ) THEN - IF ( IDFT .EQ. 3 ) THEN - WRITE (NDSE,1004) NDSTR - CALL EXTCDE (23) - ELSE - CALL NEXTLN ( COMSTR , NDSI , NDSE ) - END IF - ELSE - IF ( IDFT .EQ. 3 ) THEN - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & - IOSTAT=IERR) - ELSE - OPEN (NDSTR, FORM='UNFORMATTED', & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - ELSE - IF (FROM.EQ.'NAME') THEN - OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - ELSE - OPEN (NDSTR, & - STATUS='OLD',ERR=2000,IOSTAT=IERR) - END IF - END IF - END IF -! - ALLOCATE ( READMP(NX,NY) ) - CALL INA2I ( READMP, NX, NY, 1, NX, 1, NY, NDSTR, NDST, & - NDSE, IDFT, RFORM, IDLA, 1, 0 ) -! - IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN - DO IY=2, NY-1 - IF ( READMP( 1,IY) .EQ. 1 ) READMP( 1,IY) = 3 - IF ( READMP(NX,IY) .EQ. 1 ) READMP(NX,IY) = 3 - END DO - END IF -! - DO IX=1, NX - IF ( READMP(IX, 1) .EQ. 1 ) READMP(IX, 1) = 3 - IF ( READMP(IX,NY) .EQ. 1 .AND. ICLOSE .NE. ICLOSE_TRPL) & - READMP(IX,NY) = 3 - END DO -! - DO IY=1, NY - DO IX=1, NX - IF ( READMP(IX,IY) .EQ. 3 ) THEN - TMPSTA(IY,IX) = NSTAT - ELSE - TMPSTA(IY,IX) = READMP(IX,IY) - ! force to dry the sea points over zlim - IF ( ZBIN(IX,IY) .GT. ZLIM ) TMPSTA(IY,IX) = 0 - END IF - END DO - END DO - DEALLOCATE ( READMP ) -!!Li - ENDIF !! GTYPE .NE. SMCTYPE -! - END IF !FROM .NE. 'PART' -! -! 8.e Get NSEA and other counters -! - NSEA = 0 - NLAND = 0 - NBI = 0 - NBT = 0 -! - DO IX=1, NX - DO IY=1, NY - IF ( TMPSTA(IY,IX) .GT. 0 ) NSEA = NSEA + 1 - IF ( TMPSTA(IY,IX) .EQ. 0 ) NLAND = NLAND + 1 - IF ( TMPSTA(IY,IX) .LT. 0 ) NBT = NBT + 1 - IF ( TMPSTA(IY,IX) .EQ. 2 ) NBI = NBI + 1 - END DO - END DO -! -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC !Li Moved before FLBPI is defined with NBI value. JGLi05Jun2015 -!/SMC !Li Overwrite NSEA with NCel for SMC grid. -!/SMC NSEA = NCel -!/SMC !Li Use input NBI number for SMC grid because merged -!/SMC !Li cells are over-counted by model. -!/SMC NBI = NBISMC -!/SMC !Li No land points are used in SMC grid. JGLi26Feb2016 -!/SMC NLAND = 0 -!/SMC ENDIF !! GTYPE .EQ. SMCTYPE -! - WRITE (NDSO,980) - FLBPI = NBI .GT. 0 - IF ( .NOT. FLBPI ) THEN - WRITE (NDSO,985) - ELSE - WRITE (NDSO,986) NBI -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO, 987) -!/O1 ELSE -!/O1 WRITE (NDSO,1987) -!/O1 END IF -!/O1 IBI = 1 -!/O1 DO IY=1, NY -!/O1 DO IX=1, NX -!/O1 IF (GTYPE.NE.UNGTYPE) THEN -!/O1 X = FACTOR * ( XGRDIN(IX,IY) ) -!/O1 Y = FACTOR * ( YGRDIN(IX,IY) ) -!/O1 ELSE -!/O1 X = FACTOR * XYB(IX,1) -!/O1 Y = FACTOR * XYB(IX,2) -!/O1 END IF -!/O1 IF ( TMPSTA(IY,IX).EQ.2 ) THEN -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO, 988) IBI, IX, IY, X, Y -!/O1 ELSE -!/O1 WRITE (NDSO,1988) IBI, IX, IY, X, Y -!/O1 END IF -!/O1 IBI = IBI + 1 -!/O1 END IF -!/O1 END DO -!/O1 END DO - END IF -! - WRITE (NDSO,1980) - IF ( NBT .EQ. 0 ) THEN - WRITE (NDSO,1985) - ELSE - WRITE (NDSO,1986) NBT - END IF -! -! 8.f Set up all maps -! - CALL W3DIMX ( 1, NX, NY, NSEA, NDSE, NDST & -!/SMC , NCel, NUFc, NVFc, NRLv, NBSMC & -!/SMC , NARC, NBAC, NSPEC & - ) -!/SMC WRITE (NDSO,4021) NCel -! -! 8.g Activation of reflections and scattering - FFACBERG=FACBERG -!/REF1 REFPARS(1)=REFCOAST -!/REF1 REFPARS(2)=REFSUBGRID -!/REF1 REFPARS(3)=REFUNSTSOURCE -!/REF1 REFPARS(4)=REFICEBERG -!/REF1 REFPARS(6)=REFFREQ -!/REF1 REFPARS(7)=REFSLOPE -!/REF1 REFPARS(8)=REFCOSP_STRAIGHT -!/REF1 REFPARS(9)=REFRMAX -!/REF1 REFPARS(10)=REFFREQPOW -!/REF1 IF (GTYPE.EQ.UNGTYPE) REFPARS(2:5)=0. -!/REF1 IF (REFMAP.EQ.0) THEN -!/REF1 REFLC(3,:)=REFPARS(7) -!/REF1 END IF - - - IF (GTYPE.NE.UNGTYPE) THEN - DO IY=1, NY - DO IX=1, NX - XGRD(IY,IX) = XGRDIN(IX,IY) - YGRD(IY,IX) = YGRDIN(IX,IY) - END DO - END DO - DEALLOCATE ( XGRDIN, YGRDIN ) - CALL W3GNTX ( 1, 6, 6 ) - ELSE -! -!FA: This distinction between structured and unstructured -! should be removed when XYB is replaced by XGRD and YGRD -! - DO IX=1, NX - XGRD(:,IX) = XYB(IX,1) - YGRD(:,IX) = XYB(IX,2) - END DO - END IF ! GTYPE -! -!/SMC !!Li Shelter MAPSTA LLG definition for SMC -!/SMC IF( GTYPE .NE. SMCTYPE ) THEN -! - MAPSTA = TMPSTA - MAPFS = 0 -! -!/T ALLOCATE ( MAPOUT(NX,NY) ) -!/T MAPOUT = 0 -! -!/T IX3 = 1 + NX/60 -!/T IY3 = 1 + NY/60 -!/T CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 1, 0., & -!/T 1, NX, IX3, 1, NY, IY3, 'Zb', 'm') -! -!/DEBUGSTP WRITE(740,*) 'Printing ZBIN 5' -!/DEBUGSTP DO IX=1,NX -!/DEBUGSTP WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) -!/DEBUGSTP END DO - TRNX = 0. - TRNY = 0. -! - ISEA = 0 - DO IY=1, NY - DO IX=1, NX - IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN - MAPSTA(IY,IX) = 0 - MAPST2(IY,IX) = 1 - TMPSTA(IY,IX) = 3 - ELSE - MAPSTA(IY,IX) = TMPSTA(IY,IX) - MAPST2(IY,IX) = 0 - END IF - IF ( MAPSTA(IY,IX) .NE. 0 ) THEN - ISEA = ISEA + 1 - MAPFS (IY,IX) = ISEA - ZB(ISEA) = ZBIN(IX,IY) -!/T MAPOUT(IX,IY) = 1 - MAPSF(ISEA,1) = IX - MAPSF(ISEA,2) = IY - IF ( FLAGLL ) THEN - Y = YGRD(IY,IX) - CLATS(ISEA) = COS(Y*DERA) - CLATIS(ISEA) = 1. / CLATS(ISEA) - CTHG0S(ISEA) = - TAN(DERA*Y) / RADIUS - ELSE - CLATS(ISEA) = 1. - CLATIS(ISEA) = 1. - CTHG0S(ISEA) = 0. - END IF - END IF - -!/ ------------------------------------------------------------------- / - -! notes: Oct 22 2012: I moved the following "if-then" statement from -! inside the "IF ( MAPSTA(IY,IX) .NE. 0 )" statement to outside that -! statement. This is needed since later on, ATRNX is computed from -! TRNX(ix-1) , TRNX(ix) etc. which causes boundary effects if the -! MAPSTA=0 values are set to TRNX=0 - - IF ( TRFLAG .NE. 0 ) THEN - TRNX(IY,IX) = 1. - OBSX(IX,IY) - TRNY(IY,IX) = 1. - OBSY(IX,IY) - END IF - - END DO - END DO -!/DEBUGSTP DO ISEA=1,NSEA -!/DEBUGSTP WRITE(740,*) 'ISEA,ZB=', ISEA, ZB(ISEA) -!/DEBUGSTP END DO -!/DEBUGSTP FLUSH(740) -! -!/SMC !!Li SMC grid definition of mapping arrays. -!/SMC ELSE -! -!/SMC !!Li Pass refined level cell and face counts to NLv*(NRLv) -!/SMC NLvCel(0)=0 -!/SMC NLvUFc(0)=0 -!/SMC NLvVFc(0)=0 -!/SMC DO IP = 1, NRLv -!/SMC NLvCel(IP)=NLvCelsk(IP) + NLvCel(IP-1) -!/SMC NLvUFc(IP)=NLvUFcsk(IP) + NLvUFc(IP-1) -!/SMC NLvVFc(IP)=NLvVFcsk(IP) + NLvVFc(IP-1) -!/SMC ENDDO -!/SMC WRITE (NDSO,4022) NLvCel -!/SMC WRITE (NDSO,4023) NLvUFc -!/SMC WRITE (NDSO,4024) NLvVFc -!/SMC -!/SMC !Li Redefine MAPSF MAPFS MAPSTA MAPST2 CLATS and ZB for SMC Grid, -!/SMC !Li using SMC grid cell array and assuming NSEA=NCel. -!/SMC MAPSTA = 0 -!/SMC MAPST2 = 1 -!/SMC MAPFS = 0 -!/SMC -!/SMC !Li Pass input SMC arrays to newly declared grid arrays. -!/SMC WRITE (NDSO,4025) NCel -!/SMC IJKCel(:, 1:NGLO)=IJKCelin(:, 1:NGLO) -!/SMC IJKUFc(:, 1:NGUI)=IJKUFcin(:, 1:NGUI) -!/SMC IJKVFc(:, 1:NGVJ)=IJKVFcin(:, 1:NGVJ) -!/SMC !Li Append Arctic part -!/SMC IF( ARCTC ) THEN -!/SMC IJKCel(:, NGLO+1:NCel)=IJKCelAC(:, 1:NARC) -!/SMC IJKUFc(:, NGUI+1:NUFc)=IJKUFcAC(:, 1:NAUI) -!/SMC IJKVFc(:, NGVJ+1:NVFc)=IJKVFcAC(:, 1:NAVJ) -!/SMC ENDIF !! ARCTC -!/SMC -!/SMC WRITE (NDSO,4026) -!/SMC WRITE (NDSO,4006) 1,(IJKCel(ix, 1), ix=1,5) -!/SMC JJ=NCel -!/SMC WRITE (NDSO,4006) JJ,(IJKCel(ix, JJ), ix=1,5) -!/SMC WRITE (NDSO,*) ' ' -!/SMC WRITE (NDSO,4027) -!/SMC WRITE (NDSO,4009) 1,(IJKUFc(ix, 1), ix=1,7) -!/SMC JJ=NUFc -!/SMC WRITE (NDSO,4009) JJ,(IJKUFc(ix, JJ), ix=1,7) -!/SMC WRITE (NDSO,*) ' ' -!/SMC WRITE (NDSO,4028) -!/SMC WRITE (NDSO,4012) 1,(IJKVFc(ix, 1), ix=1,8) -!/SMC JJ=NVFc -!/SMC WRITE (NDSO,4012) JJ,(IJKVFc(ix, JJ), ix=1,8) -!/SMC WRITE (NDSO,*) ' ' -!/SMC -!/SMC !Li Boundary -9 to 0 cells for cell x-size 2**n -!/SMC !Li Note the position indice for bounary cell are not used. -!/SMC IJKCel(1, -9:0)=0 -!/SMC !Li Use Equator Y index for boundary cells. JGLi04Apr2011 -!/SMC !Li IJKCel(2, -9:0)=0 -!/SMC IJKCel(2, -9:0)=JEQT -!/SMC IJKCel(3, 0)=1 -!/SMC IJKCel(4, 0)=1 -!/SMC !Li Use minimum 10 m depth for boundary cells. -!/SMC !Li Y-size is restricted below base-cell value. -!/SMC !Li For refined boundary cells, its y-size is replaced with -!/SMC !Li the inner cell y-size for flux gradient. -!/SMC IJKCel(5, 0)=10 -!/SMC DO ip=1,9 -!/SMC IJKCel(3,-ip)=IJKCel(3,-ip+1)*2 -!/SMC IK=MIN(ip, NRLv-1) -!/SMC IJKCel(4,-ip)=2**IK -!/SMC IJKCel(5,-ip)=10 -!/SMC ENDDO -!/SMC WRITE (NDSO,4029) -!/SMC DO ip=0, -9, -1 -!/SMC WRITE (NDSO,4030) IJKCel(:,ip) -!/SMC ENDDO -!/SMC -!/SMC WRITE (NDSO,4031) NCel -!/SMC !Li Multi-resolution SMC grid requires rounding of x, y indices -!/SMC !Li by a factor MRFct. -!/SMC MRFct = 2**(NRLv - 1) -!/SMC WRITE (NDSO,4032) MRFct -!/SMC -!/SMC !Li Cosine for SMC uses refined latitude increment. -!/SMC SYMR = SY*DERA/FLOAT( MRFct ) -!/SMC !Li Reference y point for adjusted cell j=0 in radian. JGLi16Feb2016 -!/SMC YJ0R = ( Y0 - 0.5*SY )*DERA -!/SMC -!/SMC DO ISEA=1, NCel -!/SMC !Li There is no polar cell row so it is mapped to last row. -!/SMC IF( ARCTC .AND. (ISEA .EQ. NCel) ) THEN -!/SMC IX=1 -!/SMC IY=NY -!/SMC IK=1 -!/SMC JS=1 -!/SMC ELSE -!/SMC IX=IJKCel(1,ISEA)/MRFct + 1 -!/SMC IY=IJKCel(2,ISEA)/MRFct + 1 -!/SMC IK=MAX(1, IJKCel(3,ISEA)/MRFct) -!/SMC JS=MAX(1, IJKCel(4,ISEA)/MRFct) -!/SMC ENDIF -!/SMC -!/SMC ! Check that IX, IY are in the bound of [1,NX] and [1,NY] respec. -!/SMC IF ((IX+IK-1 .GT. NX) .OR. (IX .LE. 0)) THEN -!/SMC WRITE (NDSE,1014) ISEA, IX, IX+IK-1, NX -!/SMC CALL EXTCDE(65) -!/SMC END IF -!/SMC -!/SMC IF ((IY+JS-1 .GT. NY) .OR. (IY .LE. 0)) THEN -!/SMC WRITE (NDSE,1015) ISEA, IY, IY+JS-1, NY -!/SMC CALL EXTCDE(65) -!/SMC END IF -!/SMC -!/SMC !Li Minimum DMIN depth is used as well for SMC. -!/SMC ZB(ISEA)= - MAX( DMIN, FLOAT( IJKCel(5, ISEA) ) ) -!/SMC MAPFS(IY:IY+JS-1,IX:IX+IK-1) = ISEA -!/SMC MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 1 -!/SMC MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 -!/SMC MAPSF(ISEA,1) = IX -!/SMC MAPSF(ISEA,2) = IY -!/SMC MAPSF(ISEA,3) = IY + (IX -1)*NY -!/SMC -!/SMC !Li New variable CLATS to hold cosine latitude at cell centre. -!/SMC !Li Also added CLATIS and CTHG0S for version 4.08. -!/SMC !Li Use adjusted j-index to calculate cell centre y from YJ0R. -!/SMC Y = YJ0R + SYMR*( FLOAT(IJKCel(2,ISEA))+0.5*FLOAT(IJKCel(4,ISEA)) ) -!/SMC !Li Arctic polar cell does not need COS(LAT), set 1 row down. -!/SMC IF(Y .GE. HPI-0.1*SYMR) Y=HPI - SYMR*0.5*FLOAT( MRFct ) -!/SMC -!/SMC CLATS(ISEA) = COS( Y ) -!/SMC CLATIS(ISEA)= 1. / CLATS(ISEA) -!/SMC CTHG0S(ISEA)= - TAN( Y ) / RADIUS -!/SMC !!Li Sub-grid obstruction is set zero beyond NCObst cells. -!/SMC IF(ISEA .GT. NCObst) THEN -!/SMC TRNMX=1.0 -!/SMC TRNMY=1.0 -!/SMC ELSE -!/SMC !!Li Present obstruction is isotropic and in percentage. -!/SMC TRNMX=1.0 - IJKObstr(1, ISEA)*0.01 -!/SMC TRNMY=1.0 - IJKObstr(JObs, ISEA)*0.01 -!/SMC ENDIF -!/SMC CTRNX(ISEA) = MAX(0.11, TRNMX) -!/SMC CTRNY(ISEA) = MAX(0.11, TRNMY) -!/SMC END DO -!/SMC !!Li Transparency for boundary cells are 1.0 JGLi16Jan2012 -!/SMC CTRNX(-9:0) = 1.0 -!/SMC CTRNY(-9:0) = 1.0 -!/SMC !!Li Check range of MAPSF and MAPFS -!/SMC WRITE (NDSO,4033) MINVAL( MAPSF(:,1) ), MAXVAL( MAPSF(:,1) ) -!/SMC WRITE (NDSO,4034) MINVAL( MAPSF(:,2) ), MAXVAL( MAPSF(:,2) ) -!/SMC WRITE (NDSO,4035) MINVAL( MAPSF(:,3) ), MAXVAL( MAPSF(:,3) ) -!/SMC WRITE (NDSO,4036) MINVAL( MAPFS(:,:) ), MAXVAL( MAPFS(:,:) ) -!/SMC -!/SMC !Li New variable CLATF to hold cosine latitude at cell V face. -!/SMC DO IP = 1, NVFC -!/SMC ! CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP) - JEQT) ) -!/SMC !Li Use adjusted j-index to calculate cell face Y from YJ0R. -!/SMC CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP)) + YJ0R ) -!/SMC ENDDO -!/SMC IF(NBISMC .GT. 0) THEN -!/SMC !Li Save input boundary SMC list to ISMCBP(NBSMC) -!/SMC ISMCBP(1:NBISMC) = NBICelin(1:NBISMC) -!/SMC !Li Reset MAPSTA for boundary cells if any. -!/SMC DO IP=1, NBISMC -!/SMC ISEA = NBICelin(IP) -!/SMC IX=IJKCel(1,ISEA)/MRFct + 1 -!/SMC IY=IJKCel(2,ISEA)/MRFct + 1 -!/SMC IK=MAX(1, IJKCel(3,ISEA)/MRFct) -!/SMC JS=MAX(1, IJKCel(4,ISEA)/MRFct) -!/SMC MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 2 -!/SMC MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 -!/SMC ENDDO -!/SMC ENDIF -!/SMC -! -!/SMC !Li Define rotation angle for Arctic cells. -!/SMC IF( ARCTC ) THEN -!/SMC -!/SMC PoLonAC = 179.999 -!/SMC PoLatAC = 0.001 -!/SMC ALLOCATE( XLONAC(NARC),YLATAC(NARC),ELONAC(NARC),ELATAC(NARC) ) -!/SMC DO ISEA=NGLO+1, NCel -!/SMC !Li There is no polar cell row so it is mapped to last row. -!/SMC IF(ISEA .EQ. NCel) THEN -!/SMC IX=1 -!/SMC IY=NY -!/SMC IK=1 -!/SMC JS=1 -!/SMC ELSE -!/SMC IX=IJKCel(1,ISEA)/MRFct + 1 -!/SMC IY=IJKCel(2,ISEA)/MRFct + 1 -!/SMC IK=MAX(1, IJKCel(3,ISEA)/MRFct) -!/SMC JS=MAX(1, IJKCel(4,ISEA)/MRFct) -!/SMC ENDIF -!/SMC XLONAC(ISEA-NGLO)= X0 + REAL(IX-1+IK/2)*SX -!/SMC YLATAC(ISEA-NGLO)= Y0 + REAL(IY-1+JS/2)*SY -!/SMC ENDDO -!/SMC -!/SMC CALL W3LLTOEQ ( YLATAC, XLONAC, ELATAC, ELONAC, & -!/SMC & ANGARC, PoLatAC, PoLonAC, NARC ) -!/SMC -!/SMC WRITE (NDSO,4037) NARC -!/SMC WRITE (NDSO,4038) (ANGARC(ix), ix=1,NARC,NARC/8) -!/SMC -! -!/SMC !Li Mapping Arctic boundary cells with inner model cells -!/SMC DO IP=1, NBAC -!/SMC IX=IJKCel(1,IP+NGLO) -!/SMC IY=IJKCel(2,IP+NGLO) -!/SMC DO ISEA=1, NGLO -!/SMC IF( (IX .EQ. IJKCel(1,ISEA)) .AND. & -!/SMC & (IY .EQ. IJKCel(2,ISEA)) ) THEN -!/SMC ICLBAC(IP) = ISEA -!/SMC ENDIF -!/SMC ENDDO -!/SMC ENDDO -!/SMC WRITE (NDSO,4039) NBAC -!/SMC WRITE (NDSO,4040) (ICLBAC(ix), ix=1,NBAC,NBAC/8) -!/SMC -!/SMC !Li Redefine GCT term factor for Arctic part or the netative of -!/SMC !Li tangient of rotated latitude divided by radius. JGLi14Sep2015 -!/SMC DO ISEA=NGLO+1, NCel-1 -!/SMC CTHG0S(ISEA)= - TAN( ELATAC(ISEA-NGLO)*DERA ) / RADIUS -!/SMC ENDDO -!/SMC CTHG0S(NCel)=0.0 -!/SMC -!/SMC ENDIF !! ARCTC section. -! -!/SMC ENDIF !! (GTYPE .NE. SMCTYPE) ELSE SMCTYPE block. -! -!/RTD !Li Assign rotated grid angle for all sea points. JGLi01Feb2016 -!/RTD DO ISEA=1,NSEA -!/RTD IX = MAPSF(ISEA,1) -!/RTD IY = MAPSF(ISEA,2) -!/RTD AnglD(ISEA) = AnglDin(IX,IY) -!/RTD END DO -! -!/T CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 0, 0., & -!/T 1, NX, IX3, 1, NY, IY3, 'Sea points', 'm') -!/T DEALLOCATE ( MAPOUT ) -! - DO ISP=1, NSPEC+NTH - MAPWN(ISP) = 1 + (ISP-1)/NTH - MAPTH(ISP) = 1 + MOD(ISP-1,NTH) - END DO -! -!/O2 NMAP = 1 + (NX-1)/NCOL -!/O2 WRITE (NDSO,1100) NMAP -!/O2 DO IMAP=1, NMAP -!/O2 IX0 = 1 + (IMAP-1)*NCOL -!/O2 IXN = MIN ( NX , IMAP*NCOL ) -!/O2 DO IY=NY,1,-1 -!/O2 WRITE (NDSO,1101) (TMPSTA(IY,IX),IX=IX0,IXN) -!/O2 END DO -!/O2 WRITE (NDSO,*) ' ' -!/O2 END DO -!/O2 WRITE (NDSO,1102) - -!/O2a OPEN (NDSM,FILE=TRIM(FNMPRE)//'mask.ww3') -!/O2a DO IY=1, NY -!/O2a WRITE (NDSM,998) MIN(1,MAPSTA(IY,:)) -!/O2a END DO -!/O2a CLOSE (NDSM) -! -!/O2b IF ( TRFLAG .GT. 0 ) THEN -!/O2b NMAPB = 1 + (NX-1)/NCOL -!/O2b WRITE (NDSO,1103) 'X', NMAPB -!/O2b DO IMAPB=1, NMAPB -!/O2b IX0 = 1 + (IMAPB-1)*NCOL -!/O2b IXN = MIN ( NX , IMAPB*NCOL ) -!/O2b DO IY=NY,1,-1 -!/O2b WRITE (NDSO,1101) (NINT(10.*OBSX(IX,IY)),IX=IX0,IXN) -!/O2b END DO -!/O2b WRITE (NDSO,*) ' ' -!/O2b END DO -!/O2b WRITE (NDSO,1104) -!/O2b WRITE (NDSO,1103) 'Y', NMAPB -!/O2b DO IMAPB=1, NMAPB -!/O2b IX0 = 1 + (IMAPB-1)*NCOL -!/O2b IXN = MIN ( NX , IMAPB*NCOL ) -!/O2b DO IY=NY,1,-1 -!/O2b WRITE (NDSO,1101) (NINT(10.*OBSY(IX,IY)),IX=IX0,IXN) -!/O2b END DO -!/O2b WRITE (NDSO,*) ' ' -!/O2b END DO -!/O2b WRITE (NDSO,1104) -!/O2b END IF -! -!/O2c OPEN (NDSM,FILE=TRIM(FNMPRE)//'mapsta.ww3', RECL=2*NX*NY*50+1) -!/O2c DO IY=NY,1, -1 -!/O2c DO IX=1,NX -!/O2c DO I=1,50 -!/O2c WRITE (NDSM,1998,ADVANCE='NO') (TMPSTA(IY,IX)) -!/O2c END DO -!/O2c END DO -!/O2c END DO -!/O2c CLOSE (NDSM) -! - -!/IG1 IGPARS(1)=IGMETHOD -!/IG1 IGPARS(2)=IGADDOUTP -!/IG1 IGPARS(3)=IGSOURCE -!/IG1 IGPARS(4)=0 -!/IG1 IF (IGBCOVERWRITE) IGPARS(4)=IGPARS(4)+1 -!/IG1 IF (IGSWELLMAX) IGPARS(4)=IGPARS(4)+2 -!/IG1 IGPARS(5)=1 -!/IG1 DO IK=1,NK -!/IG1 IF (SIG(IK)*TPIINV.LT.IGMAXFREQ) IGPARS(5)=IK -!/IG1 END DO -!/IG1 IGMINDEP=MINVAL(ZB*(-1.)-2) ! -2 / +2 is there for water level changes -!/IG1 IGMAXDEP=MAXVAL(ZB*(-1.)+2) -!/IG1 IF (IGSOURCEATBP.EQ.1) IGMINDEP=1. ! should use true minimum depth ... -!/IG1 IGPARS(6)=1+NINT(LOG(MAX(IGMAXDEP,1.0)/MAX(IGMINDEP,1.0))/LOG(1.1)) -!/IG1 IGPARS(7)=MAX(IGMINDEP,1.0) -!/IG1 IGPARS(8)=IGSOURCEATBP -!/IG1 IGPARS(9)=IGKDMIN -!/IG1 IGPARS(10)=IGFIXEDDEPTH -!/IG1 IGPARS(11)=IGEMPIRICAL**2 -!/IG1 IGPARS(12)=IGSTERMS -! -!/IC2 IC2PARS(:)=0. -!/IC2 IF (IC2DISPER) IC2PARS(1)=1. -!/IC2 IC2PARS(2)=IC2TURB -!/IC2 IC2PARS(3)=IC2ROUGH -!/IC2 IC2PARS(4)=IC2REYNOLDS -!/IC2 IC2PARS(5)=IC2SMOOTH -!/IC2 IC2PARS(6)=IC2VISC -!/IC2 IC2PARS(7)=IC2TURBS -!/IC2 IC2PARS(8)=IC2DMAX -! -!/IC3 IC3PARS(:)=0. -!/IC3 IC3PARS(1)=IC3MAXTHK -!/IC3 IC3PARS(2)=IC2TURB -!/IC3 IC3PARS(3)=IC2ROUGH -!/IC3 IC3PARS(4)=IC2REYNOLDS -!/IC3 IC3PARS(5)=IC2SMOOTH -!/IC3 IC3PARS(6)=IC2VISC -!/IC3 IC3PARS(7)=IC2TURBS -!/IC3 IC3PARS(8)=IC3MAXCNC -!/IC3 IF (IC3CHENG) IC3PARS(9)=1.0 -!/IC3 IC3PARS(10)=IC3HILIM -!/IC3 IC3PARS(11)=IC3KILIM -!/IC3 IF (USECGICE) IC3PARS(12)=1.0 -!/IC3 IC3PARS(13)=IC3HICE -!/IC3 IC3PARS(14)=IC3VISC -!/IC3 IC3PARS(15)=IC3DENS -!/IC3 IC3PARS(16)=IC3ELAS -! -!/IC4 IC4PARS(1)=IC4METHOD -!/IC4 IC4_KI=IC4KI -!/IC4 IC4_FC=IC4FC -! -!/IC5 IC5PARS(:)=0. -!/IC5 IC5PARS(1)=IC5MINIG -!/IC5 IC5PARS(2)=IC5MINWT -!/IC5 IC5PARS(3)=IC5MAXKRATIO -!/IC5 IC5PARS(4)=IC5MAXKI -!/IC5 IC5PARS(5)=IC5MINHW -!/IC5 IC5PARS(6)=IC5MAXITER -!/IC5 IC5PARS(7)=IC5RKICK -!/IC5 IC5PARS(8)=IC5KFILTER -!/IC5 IC5PARS(9)=IC5VEMOD -! -!/IS2 IS2PARS(1) = ISC1 -!/IS2 IS2PARS(2) = IS2BACKSCAT -!/IS2 IS2PARS(3)=0. -!/IS2 IF (IS2BREAK) IS2PARS(3)=1. -!/IS2 IS2PARS(4)=IS2C2 -!/IS2 IS2PARS(5)=IS2C3 -!/IS2 IS2PARS(6)=0. -!/IS2 IF (IS2DISP) IS2PARS(6)=1. -!/IS2 IS2PARS(7)=IS2DAMP -!/IS2 IS2PARS(8)=IS2FRAGILITY -!/IS2 IS2PARS(9)=IS2DMIN -!/IS2 IS2PARS(10)=0. -!/IS2 IF (IS2DUPDATE) IS2PARS(10)=1. -!/IS2 IS2PARS(11)=IS2CONC -!/IS2 IS2PARS(12)=ABS(IS2CREEPB) -!/IS2 IS2PARS(13)=IS2CREEPC -!/IS2 IS2PARS(14)=IS2CREEPD -!/IS2 IS2PARS(15)=IS2CREEPN -!/IS2 IS2PARS(16)=IS2BREAKE -!/IS2 IS2PARS(17)=IS2BREAKF -!/IS2 IS2PARS(18)=IS2WIM1 -!/IS2 IS2PARS(19)=IS2FLEXSTR -!/IS2 IS2PARS(20)=0. -!/IS2 IF (IS2ISOSCAT) IS2PARS(20)=1. -!/IS2 IS2PARS(21)=IS2ANDISD -!/IS2 IS2PARS(22)=IS2ANDISN -!/IS2 IS2PARS(23)=0. -!/IS2 IF (IS2ANDISB) IS2PARS(23)=1. -!/IS2 IS2PARS(24)=IS2ANDISE -! -! 9.d Estimates shoreline direction for reflection -! and shoreline treatment in general for UNST grids. -! NB: this is updated with moving water levels in W3ULEV -! AR: this is not anymore needed and will be deleted ... -! - IF (GTYPE.EQ.UNGTYPE) THEN - CALL SETUGIOBP -!/REF1 ELSE -!/REF1 CALL W3SETREF - END IF -!/REF1! -!/REF1! 9.a Reads shoreline slope (whith REF1 switch only) -!/REF1! -!/REF1 ALLOCATE ( REFD(NX,NY), REFD2(NX,NY), REFS(NX,NY) ) -!/REF1 IF (REFMAP.EQ.0) THEN -!/REF1 REFS(:,:)=1. -!/REF1 ELSE -!/REF1! -!/REF1! 9.b Info from input file -!/REF1! -!/REF1 IF (FLGNML) THEN -!/REF1 NDSTR = NML_SLOPE%IDF -!/REF1 VSC = NML_SLOPE%SF -!/REF1 IDLA = NML_SLOPE%IDLA -!/REF1 IDFT = NML_SLOPE%IDFM -!/REF1 RFORM = TRIM(NML_SLOPE%FORMAT) -!/REF1 FROM = TRIM(NML_SLOPE%FROM) -!/REF1 TNAME = TRIM(NML_SLOPE%FILENAME) -!/REF1 ELSE -!/REF1 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/REF1 READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & -!/REF1 FROM, TNAME -!/REF1 END IF -!/REF1! -!/REF1 IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. -!/REF1 IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 -!/REF1 IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -!/REF1! -!/REF1 WRITE (NDSO,1977) NDSTR, VSC, IDLA, IDFT -!/REF1 IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM -!/REF1 IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -!/REF1! -!/REF1! 9;c Open file and check if necessary -!/REF1! -!/REF1 IF ( NDSTR .EQ. NDSI ) THEN -!/REF1 IF ( IDFT .EQ. 3 ) THEN -!/REF1 WRITE (NDSE,1004) NDSTR -!/REF1 CALL EXTCDE (23) -!/REF1 ELSE -!/REF1 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/REF1 END IF -!/REF1 ELSE IF ( NDSTR .EQ. NDSG ) THEN -!/REF1 IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & -!/REF1 ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN -!/REF1 WRITE (NDSE,1005) IDFM, IDFT -!/REF1 CALL EXTCDE (24) -!/REF1 END IF -!/REF1 ELSE -!/REF1 IF ( IDFT .EQ. 3 ) THEN -!/REF1 IF (FROM.EQ.'NAME') THEN -!/REF1 OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/REF1 FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & -!/REF1 IOSTAT=IERR) -!/REF1 ELSE -!/REF1 OPEN (NDSTR, FORM='UNFORMATTED', & -!/REF1 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/REF1 END IF -!/REF1 ELSE -!/REF1 IF (FROM.EQ.'NAME') THEN -!/REF1 OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/REF1 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/REF1 ELSE -!/REF1 OPEN (NDSTR, & -!/REF1 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/REF1 END IF !end of (FROM.EQ.'NAME') -!/REF1 END IF !end of ( IDFT .EQ. 3 ) -!/REF1 END IF !end of ( NDSTR .EQ. NDSG ) -!/REF1! -!/REF1! 9.d Read the data -!/REF1! -!/REF1! CALL INA2R ( REFD, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -!/REF1! IDFM, RFORM, IDLA, VSC, 0.0) -!/REF1! -!/REF1 IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/REF1! -!/REF1! CALL INA2R ( REFD2, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -!/REF1! IDFM, RFORM, IDLA, VSC, 0.0) -!/REF1 CALL INA2R ( REFS, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -!/REF1 IDFM, RFORM, IDLA, VSC, 0.0) -!/REF1 DO ISEA=1,NSEA -!/REF1 IX = MAPSF(ISEA,1) -!/REF1 IY = MAPSF(ISEA,2) -!/REF1 REFLC(3,ISEA) = REFS(IX,IY)*REFMAP -!/REF1 END DO -! -!/REF1 NMAPB = 1 + (NX-1)/NCOL -!/REF1 WRITE (NDSO,1105) NMAPB -!/T!/REF1 WRITE(NDSO,*) 'Maximum slope for reflection:',MAXVAL(REFS*REFMAP) -! -!/REF1 DO IMAPB=1, NMAPB -!/REF1 IX0 = 1 + (IMAPB-1)*NCOL -!/REF1 IXN = MIN ( NX , IMAPB*NCOL ) -!/T!/REF1 DO IY=NY,1,-1 -!/T!/REF1 WRITE (NDSO,1101) (NINT(100.*REFS(IX,IY)*REFMAP),IX=IX0,IXN) -!/T!/REF1 END DO -!/REF1 WRITE (NDSO,*) ' ' -!/REF1 END DO -!/REF1 WRITE (NDSO,1106) -!/REF1! -!/REF1 WRITE (NDSO,*) -!/REF1! -!/REF1 END IF !end of (REFMAP.EQ.0) -! - DEALLOCATE ( ZBIN, TMPSTA, TMPMAP ) -!/RTD DEALLOCATE ( AnglDin ) -! -! 9.e Reads bottom information from file -! -!/BT4 ALLOCATE ( SED_D50FILE(NX,NY)) -!/BT4 IF ( SEDMAPD50 ) THEN -!/BT4 -!/BT4! -!/BT4! 9.e.1 Info from input file -!/BT4! -!/BT4 IF (FLGNML) THEN -!/BT4 NDSTR = NML_SED%IDF -!/BT4 VSC = NML_SED%SF -!/BT4 IDLA = NML_SED%IDLA -!/BT4 IDFT = NML_SED%IDFM -!/BT4 RFORM = TRIM(NML_SED%FORMAT) -!/BT4 FROM = TRIM(NML_SED%FROM) -!/BT4 TNAME = TRIM(NML_SED%FILENAME) -!/BT4 ELSE -!/BT4 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/BT4 READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & -!/BT4 FROM, TNAME -!/BT4 END IF -!/BT4! -!/BT4 IF ( ABS(VSC) .LT. 1.E-7 ) THEN -!/BT4 VSC = 1. -!/BT4 ELSE -!/BT4! WARNING TO BE ADDED ... -!/BT4 END IF -!/BT4 IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 -!/BT4 IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 -!/BT4! -!/BT4 WRITE (NDSO,1978) NDSTR, VSC, IDLA, IDFT -!/BT4 IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM -!/BT4 IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME -!/BT4! -!/BT4! 9.e.2 Open file and check if necessary -!/BT4! -!/BT4 IF ( NDSTR .EQ. NDSI ) THEN -!/BT4 IF ( IDFT .EQ. 3 ) THEN -!/BT4 WRITE (NDSE,1004) NDSTR -!/BT4 CALL EXTCDE (23) -!/BT4 ELSE -!/BT4 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/BT4 END IF -!/BT4 ELSE IF ( NDSTR .EQ. NDSG ) THEN -!/BT4 IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & -!/BT4 ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN -!/BT4 WRITE (NDSE,1005) IDFM, IDFT -!/BT4 CALL EXTCDE (24) -!/BT4 END IF -!/BT4 ELSE -!/BT4 IF ( IDFT .EQ. 3 ) THEN -!/BT4 IF (FROM.EQ.'NAME') THEN -!/BT4 OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/BT4 FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & -!/BT4 IOSTAT=IERR) -!/BT4 ELSE -!/BT4 OPEN (NDSTR, FORM='UNFORMATTED', & -!/BT4 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/BT4 END IF -!/BT4 ELSE -!/BT4 IF (FROM.EQ.'NAME') THEN -!/BT4 OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & -!/BT4 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/BT4 ELSE -!/BT4 OPEN (NDSTR, & -!/BT4 STATUS='OLD',ERR=2000,IOSTAT=IERR) -!/BT4 END IF -!/BT4 END IF -!/BT4 END IF -!/BT4! -!/BT4! 9.e.3 Read the data -!/BT4! -!/BT4 CALL INA2R ( SED_D50FILE, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & -!/BT4 IDFM, RFORM, IDLA, VSC, VOF) -!/BT4! -!/BT4 IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/BT4! -!/BT4 WRITE (NDSO,*) 'Min and Max values of grain sizes:',MINVAL(SED_D50FILE), MAXVAL(SED_D50FILE) -!/BT4 WRITE (NDSO,*) -!/BT4! -!/BT4 ELSE -!/BT4 SED_D50FILE(:,:)=SED_D50_UNIFORM -!/BT4 END IF -!/BT4! -!/BT4 DO IY=1, NY -!/BT4 DO IX=1, NX -!/BT4 ISEA = MAPFS (IY,IX) -!/BT4 SED_D50(ISEA) = SED_D50FILE(IX,IY) -!/BT4 SED_D50(ISEA) = MAX(SED_D50(ISEA),1E-5) -!/BT4 ! Critical Shields number, Soulsby, R.L. and R J S W Whitehouse -!/BT4 ! Threshold of sed. motion in coastal environments, Proc. Pacific Coasts and -!/BT4 ! ports, 1997 conference, Christchurch, p149-154, University of Cantebury, NZ -!/BT4 SED_DSTAR=(GRAV*(SED_SG-1)/nu_water**2)**(0.333333)*SED_D50(ISEA) -!/BT4 SED_PSIC(ISEA)=0.3/(1+1.2*SED_DSTAR)+0.55*(1-exp(-0.02*SED_DSTAR)) - - -!/BT4 END DO -!/BT4 END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! 10. Prepare output boundary points. -! ILOOP = 1 to count NFBPO and NBO -! ILOOP = 2 to fill data arrays -! - WRITE (NDSO,990) - IF ( .NOT. FLGNML ) & - OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') -! - DO ILOOP = 1, 2 -! - IF ( ILOOP.EQ.2 ) CALL W3DMO5 ( 1, NDST, NDSE, 2 ) -! - I = 1 - NBOTOT = 0 - NFBPO = 0 - NBO(0) = 0 - NBO2(0)= 0 - FIRST = .TRUE. - IF ( .NOT. FLGNML ) THEN - REWIND (NDSS) - IF ( ILOOP .EQ. 1 ) THEN - NDSI2 = NDSI - ELSE - NDSI2 = NDSS - END IF - END IF -! - DO - IF (FLGNML) THEN - ! outbound lines - IF (NML_OUTBND_COUNT%N_LINE.GT.0 .AND. I.LE.NML_OUTBND_COUNT%N_LINE) THEN - XO0 = NML_OUTBND_LINE(I)%X0 - YO0 = NML_OUTBND_LINE(I)%Y0 - DXO = NML_OUTBND_LINE(I)%DX - DYO = NML_OUTBND_LINE(I)%DY - NPO = NML_OUTBND_LINE(I)%NP - I=I+1 - ELSE - NPO=0 - END IF - ELSE - CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) - READ (NDSI2,*,END=2001,ERR=2002) XO0, YO0, DXO, DYO, NPO - END IF -! - IF ( .NOT. FLGNML .AND. ILOOP .EQ. 1 ) THEN - BACKSPACE (NDSI) - READ (NDSI,'(A)') LINE - WRITE (NDSS,'(A)') LINE - END IF -! -! ... Check if new file to be used -! - FIRST = FIRST .OR. NPO.LE.0 - NPO = ABS(NPO) -! -! ... Preparations for new output file including end check -! and output for last output file -! - IF ( FIRST ) THEN -! - FIRST = .FALSE. -! -!/RTD IF ( NPO.NE.0 ) THEN -!/RTD ! Destination pole lat, lon from namelist -!/RTD bPolat = BPLAT(NFBPO+1) -!/RTD bPolon = BPLON(NFBPO+1) -!/RTD END IF -!/RTD ! - IF ( NFBPO.GE.1 .AND. ILOOP.EQ.2 ) THEN - WRITE (NDSO,991) NFBPO, NBO(NFBPO) - NBO(NFBPO-1), & - NBO2(NFBPO) - NBO2(NFBPO-1) -!/RTD ! Print dest. Pole lat/lon if either the dest or present grid is rotated -!/RTD IF ( BPLAT(NFBPO) < 90. .OR. Polat < 90. ) & -!/RTD WRITE (NDSO,1991) BPLAT(NFBPO), BPLON(NFBPO) -!/RTD ! -!/O1 IF ( NBO(NFBPO) - NBO(NFBPO-1) .EQ. 1 ) THEN -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO,992) -!/O1 ELSE -!/O1 WRITE (NDSO,2992) -!/O1 END IF -!/O1 ELSE -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO,1992) -!/O1 ELSE -!/O1 WRITE (NDSO,3992) -!/O1 END IF -!/O1 END IF -!/O1 IP0 = NBO(NFBPO-1)+1 -!/O1 IPN = NBO(NFBPO) -!/O1 IPH = IP0 + (IPN-IP0-1)/2 -!/O1 IPI = IPH -IP0 + 1 + MOD(IPN-IP0+1,2) -!/O1 DO IP=IP0, IPH -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO,1993) IP-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IP), & -!/O1 FACTOR*YBPO(IP), & -!/O1 IP+IPI-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IP+IPI), & -!/O1 FACTOR*YBPO(IP+IPI) -!/O1 ELSE -!/O1 WRITE (NDSO,3993) IP-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IP), & -!/O1 FACTOR*YBPO(IP), & -!/O1 IP+IPI-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IP+IPI), & -!/O1 FACTOR*YBPO(IP+IPI) -!/O1 END IF -!/O1 END DO -!/O1 IF ( MOD(IPN-IP0+1,2) .EQ. 1 ) THEN -!/O1 IF ( FLAGLL ) THEN -!/O1 WRITE (NDSO, 993) IPH+1-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IPH+1), & -!/O1 FACTOR*YBPO(IPH+1) -!/O1 ELSE -!/O1 WRITE (NDSO,2993) IPH+1-NBO(NFBPO-1), & -!/O1 FACTOR*XBPO(IPH+1), & -!/O1 FACTOR*YBPO(IPH+1) -!/O1 END IF -!/O1 END IF -!/O1 WRITE (NDSO,*) - END IF -! - IF ( NPO .EQ. 0 ) EXIT -! - NFBPO = NFBPO + 1 - IF ( NFBPO .GT. 9 ) THEN - WRITE (NDSE,1006) - CALL EXTCDE ( 50 ) - END IF - NBO2(NFBPO) = NBO2(NFBPO-1) - NBO(NFBPO) = NBOTOT -! - END IF -! -! ... Loop over line segment - - - - - - - - - - - - - - - - - - - - - -! -!/RTD ! If either base or destination grid is rotated lat-lon -!/RTD IF ( allocated(BDYLON) .eqv. .TRUE. ) THEN -!/RTD deallocate( BDYLON, BDYLAT ) -!/RTD IF ( bPolat < 90. .OR. Polat < 90. ) & -!/RTD deallocate( ELatbdy, ELonbdy, Anglbdy ) -!/RTD END IF -!/RTD allocate( BDYLON(NPO), BDYLAT(NPO)) -!/RTD IF ( bPolat < 90. .OR. Polat < 90. ) & -!/RTD allocate( ELatbdy(NPO), ELonbdy(NPO), Anglbdy(NPO) ) -!/RTD ! -!/T WRITE (NDST,9090) -! - DO IP=1, NPO -! - XO = XO0 + REAL(IP-1)*DXO - YO = YO0 + REAL(IP-1)*DYO -!/RTD ! -!/RTD ! Boundary points are specified in coordinates of the destination grid -!/RTD ! -!/RTD ! Collect the line segment points into arrays -!/RTD BDYLON(IP) = XO -!/RTD BDYLAT(IP) = YO -!/RTD ! Close the loop before calculating rotated lat-lon coordinates. -!/RTD END DO -!/RTD -!/RTD ! Create one or two sets of the segment points: -!/RTD ! 1. (BDYLAT, BDYLON) in standard lat-lon coordinates, -!/RTD ! 2. Also (ELatbdy, ELonbdy) in case the base grid is rotated -!/RTD -!/RTD IF ( bPolat < 90. ) THEN -!/RTD ! The destination grid is rotated (std->rot or rot->rot) -!/RTD ! Change BDYLAT, BDYLON to their standard lat-lon positions -!/RTD ! Let ELatbdy,ELonbdy contain the rotated lat-lon coordinates -!/RTD ELatbdy(:) = BDYLAT(:) -!/RTD ELonbdy(:) = BDYLON(:) -!/RTD CALL W3EQTOLL ( ELatbdy, ELonbdy, BDYLAT, BDYLON, & -!/RTD & Anglbdy, bPolat, bPolon, NPO ) -!/RTD ! Let the standard longitudes BDYLON be within the range [-180.,180.[ -!/RTD ! or [0., 360.[ depending on the grid pole -!/RTD IF ( Polon < -90. .OR. Polon > 90. ) THEN -!/RTD BDYLON(:) = MOD( BDYLON(:) + 180., 360. ) - 180. -!/RTD ELSE -!/RTD BDYLON(:) = MOD( BDYLON(:) + 360., 360. ) -!/RTD END IF -!/RTD END IF ! bPolat < 90. -!/RTD ! From now, BDYLAT, BDYLON are defined in standard lat-lon coordinates -!/RTD ! -!/RTD IF ( Polat < 90. ) THEN -!/RTD ! The base grid is rotated (rot->std or rot->rot) -!/RTD ! Find lat-lon in coordinates of the rotated base grid -!/RTD CALL W3LLTOEQ ( BDYLAT, BDYLON, ELatbdy, ELonbdy, & -!/RTD & Anglbdy, Polat, Polon, NPO ) -!/RTD END IF -!/RTD ! -!/RTD ! Take up again the loop over the line segment points -!/RTD DO IP=1, NPO -!/RTD IF ( Polat < 90. ) THEN -!/RTD ! The base grid is rotated (rot->std, rot->rot) -!/RTD ! (The std. lat-lon values BDYLAT, BDYLON go to YBPO, XBPO) -!/RTD XO = ELonbdy(IP) -!/RTD YO = ELatbdy(IP) -!/RTD ELSE -!/RTD ! The base grid is standard geographic (std->rot or std->std) -!/RTD XO = BDYLON(IP) -!/RTD YO = BDYLAT(IP) -!/RTD END IF -! -! ... Compute bilinear remapping weights -! - INGRID = W3GRMP( GSU, XO, YO, IXR, IYR, RD ) -! -! Change cell-corners from counter-clockwise to column-major order - IX = IXR(3); IY = IYR(3); X = RD(3); - IXR(3) = IXR(4); IYR(3) = IYR(4); RD(3) = RD(4); - IXR(4) = IX ; IYR(4) = IY ; RD(4) = X ; -! -!/T WRITE (NDST,9091) FACTOR*XO, FACTOR*YO, & -!/T (IXR(J), IYR(J), RD(J), J=1,4) -! -! ... Check if point in grid -! - IF ( INGRID ) THEN -! -! ... Check if point not on land -! - IF ( ( MAPSTA(IYR(1),IXR(1)).GT.0 .AND. & - RD(1).GT.0.05 ) .OR. & - ( MAPSTA(IYR(2),IXR(2)).GT.0 .AND. & - RD(2).GT.0.05 ) .OR. & - ( MAPSTA(IYR(3),IXR(3)).GT.0 .AND. & - RD(3).GT.0.05 ) .OR. & - ( MAPSTA(IYR(4),IXR(4)).GT.0 .AND. & - RD(4).GT.0.05 ) ) THEN -! -! ... Check storage and store coordinates -! - NBOTOT = NBOTOT + 1 - IF ( ILOOP .EQ. 1 ) CYCLE -! -!/RTD ! BDYLAT, BDYLON contain Y0, X0, which are remapped to standard lat/lon. -!/RTD ! BDYLAT, BDYLON are stored in the mod_def file. -!/RTD IF ( Polat < 90. ) THEN -!/RTD XO = BDYLON(IP) -!/RTD YO = BDYLAT(IP) -!/RTD END IF - XBPO(NBOTOT) = XO - YBPO(NBOTOT) = YO -! -! ... Interpolation factors -! - RDTOT = 0. - DO J=1, 4 - IF ( MAPSTA(IYR(J),IXR(J)).GT.0 .AND. & - RD(J).GT.0.05 ) THEN - RDBPO(NBOTOT,J) = RD(J) - ELSE - RDBPO(NBOTOT,J) = 0. - END IF - RDTOT = RDTOT + RDBPO(NBOTOT,J) - END DO -! - DO J=1, 4 - RDBPO(NBOTOT,J) = RDBPO(NBOTOT,J) / RDTOT - END DO -! -!/T WRITE (NDST,9092) RDTOT, (RDBPO(NBOTOT,J),J=1,4) -! -! ... Determine sea and interpolation point counters -! - DO J=1, 4 - ISEAI(J) = MAPFS(IYR(J),IXR(J)) - END DO -! - DO J=1, 4 - IF ( ISEAI(J).EQ.0 .OR. RDBPO(NBOTOT,J).EQ. 0. ) THEN - IPBPO(NBOTOT,J) = 0 - ELSE - FLNEW = .TRUE. - DO IST=NBO2(NFBPO-1)+1, NBO2(NFBPO) - IF ( ISEAI(J) .EQ. ISBPO(IST) ) THEN - FLNEW = .FALSE. - IPBPO(NBOTOT,J) = IST - NBO2(NFBPO-1) - END IF - END DO - IF ( FLNEW ) THEN - NBO2(NFBPO) = NBO2(NFBPO) + 1 - IPBPO(NBOTOT,J) = NBO2(NFBPO) - NBO2(NFBPO-1) - ISBPO(NBO2(NFBPO)) = ISEAI(J) - END IF - END IF - END DO -! -!/T WRITE (NDST,9093) ISEAI, (IPBPO(NBOTOT,J),J=1,4) -! -! ... Error output -! - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSE,2995) FACTOR*XO, FACTOR*YO - ELSE - WRITE (NDSE,995) FACTOR*XO, FACTOR*YO - END IF - END IF - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSE,2994) FACTOR*XO, FACTOR*YO - ELSE - WRITE (NDSE,994) FACTOR*XO, FACTOR*YO - END IF - END IF -! - END DO -! - NBO(NFBPO) = NBOTOT -! -! ... Branch back to read. -! - END DO -! -! ... End of ILOOP loop -! - END DO -! - IF ( .NOT. FLGNML ) CLOSE ( NDSS, STATUS='DELETE' ) -! - FLBPO = NBOTOT .GT. 0 - IF ( .NOT. FLBPO ) THEN - WRITE (NDSO,996) - ELSE - WRITE (NDSO,997) NBOTOT, NBO2(NFBPO) - END IF -! -!/T0 WRITE (NDST,9095) -!/T0 DO IFILE=1, NFBPO -!/T0 DO IP=NBO2(IFILE-1)+1, NBO2(IFILE) -!/T0 WRITE (NDST,9096) IFILE, IP-NBO2(IFILE-1), ISBPO(IP) -!/T0 END DO -!/T0 END DO -! -!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!10. Write model definition file. -! - WRITE (NDSO,999) - CALL W3IOGR ( 'WRITE', NDSM ) -! - CLOSE (NDSM) -! - GOTO 2222 -! -! Escape locations read errors : -! - 2000 CONTINUE - WRITE (NDSE,1000) IERR - CALL EXTCDE ( 60 ) -! - 2001 CONTINUE - WRITE (NDSE,1001) - CALL EXTCDE ( 61 ) -! - 2002 CONTINUE - WRITE (NDSE,1002) IERR - CALL EXTCDE ( 62 ) -! - 2003 CONTINUE - WRITE (NDSE,1003) - CALL EXTCDE ( 64 ) -! - 2222 CONTINUE - IF ( GTYPE .NE. UNGTYPE) THEN - IF ( NX*NY .NE. NSEA ) THEN - WRITE (NDSO,9997) NX, NY, NX*NY, NSEA, & - 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT - ELSE - WRITE (NDSO,9998) NX, NY, NX*NY, NSEA, NBI, NLAND, NBT - END IF - ELSE IF ( GTYPE .EQ. UNGTYPE ) THEN - IF ( NX*NY .NE. NSEA ) THEN - WRITE (NDSO,9997) 0, 0, NX*NY, NSEA, & - 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT - ELSE - WRITE (NDSO,9998) 0, 0, NX*NY, NSEA, NBI, NLAND, NBT - END IF - ENDIF ! GTYPE .EQ. UNGTYPE - - WRITE (NDSO,9999) - -!/SCRIP GRID1_UNITS='degrees' ! the other option is radians...we don't use this -!/SCRIP GRID1_NAME='src' ! this is not used, except for netcdf output -!/SCRIP CALL GET_SCRIP_INFO(1, & -!/SCRIP & GRID1_CENTER_LON, GRID1_CENTER_LAT, & -!/SCRIP & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & -!/SCRIP & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) -!/SCRIP -!/SCRIP - -!/SCRIP IF (GTYPE .EQ. UNGTYPE) THEN -!/SCRIP GRID1_RANK=1 -!/SCRIP DEALLOCATE(GRID1_DIMS) -!/SCRIP ALLOCATE(GRID1_DIMS(GRID1_RANK)) -!/SCRIP GRID1_DIMS(1) = GRID1_SIZE -!/SCRIP ENDIF - -!/SCRIP DO I = 1,GRID1_SIZE -!/SCRIP IF (GRID1_CENTER_LON(I) < 0.0) THEN -!/SCRIP GRID1_CENTER_LON(I) = GRID1_CENTER_LON(I)+360.0 -!/SCRIP ENDIF -!/SCRIP DO J = 1,GRID1_CORNERS -!/SCRIP IF (GRID1_CORNER_LON(J,I) < 0.0) THEN -!/SCRIP GRID1_CORNER_LON(J,I) = GRID1_CORNER_LON(J,I)+360.0 -!/SCRIP ENDIF -!/SCRIP ENDDO -!/SCRIP ENDDO - -!/SCRIPNC IERR = NF90_CREATE(TRIM('scrip.nc'), NF90_NETCDF4, NCID) -!/SCRIPNC IERR = NF90_DEF_DIM(NCID, 'grid_size', GRID1_SIZE, grid_size_dimid) -!/SCRIPNC IERR = NF90_DEF_DIM(NCID, 'grid_corners', GRID1_CORNERS, grid_corners_dimid) -!/SCRIPNC IERR = NF90_DEF_DIM(NCID, 'grid_rank', GRID1_RANK, grid_rank_dimid) - -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_center_lat', NF90_DOUBLE, & -!/SCRIPNC (/grid_size_dimid/),grid_center_lat_varid) -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_center_lon', NF90_DOUBLE, & -!/SCRIPNC (/grid_size_dimid/),grid_center_lon_varid) -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_corner_lat', NF90_DOUBLE, & -!/SCRIPNC (/grid_corners_dimid,grid_size_dimid/), & -!/SCRIPNC grid_corner_lat_varid) -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_corner_lon', NF90_DOUBLE, & -!/SCRIPNC (/grid_corners_dimid,grid_size_dimid/), & -!/SCRIPNC grid_corner_lon_varid) -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_imask', NF90_INT, & -!/SCRIPNC (/grid_size_dimid/),grid_imask_varid) -!/SCRIPNC IERR = NF90_DEF_VAR(NCID, 'grid_dims', NF90_INT, & -!/SCRIPNC (/grid_rank_dimid/),grid_dims_varid) -!/SCRIPNC IERR = NF90_ENDDEF(NCID) - -!/SCRIP ALLOCATE(GRID1_IMASK(GRID1_DIMS(1))) -!/SCRIP GRID1_IMASK = 0 -!/SCRIP DO I = 1,GRID1_DIMS(1) -!/SCRIP IF (GRID1_MASK(I)) THEN -!/SCRIP GRID1_IMASK(I) = 1 -!/SCRIP ENDIF -!/SCRIP ENDDO - -!/SCRIPNC IERR = NF90_PUT_ATT(NCID,grid_center_lat_varid,'units',GRID1_UNITS) -!/SCRIPNC IERR = NF90_PUT_ATT(NCID,grid_center_lon_varid,'units',GRID1_UNITS) -!/SCRIPNC IERR = NF90_PUT_ATT(NCID,grid_corner_lat_varid,'units',GRID1_UNITS) -!/SCRIPNC IERR = NF90_PUT_ATT(NCID,grid_corner_lon_varid,'units',GRID1_UNITS) -!/SCRIPNC IERR = NF90_PUT_ATT(NCID,grid_imask_varid,'units','unitless') - -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_center_lat_varid,GRID1_CENTER_LAT) -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_center_lon_varid,GRID1_CENTER_LON) -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_corner_lat_varid,GRID1_CORNER_LAT) -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_corner_lon_varid,GRID1_CORNER_LON) -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_imask_varid,GRID1_IMASK) -!/SCRIPNC IERR = NF90_PUT_VAR(NCID,grid_dims_varid,GRID1_DIMS) -!/SCRIPNC IERR = NF90_CLOSE(NCID) - - -! -! Formats -! - 900 FORMAT (/15X,' *** WAVEWATCH III Grid preprocessor *** '/ & - 15X,'==============================================='/) - 901 FORMAT ( ' Comment character is ''',A,''''/) - 902 FORMAT ( ' Grid name : ',A/) - 903 FORMAT (/' Spectral discretization : '/ & - ' --------------------------------------------------'/ & - ' Number of directions :',I4/ & - ' Directional increment (deg.):',F6.1) - 904 FORMAT ( ' First direction (deg.):',F6.1) - 905 FORMAT ( ' Number of frequencies :',I4/ & - ' Frequency range (Hz) :',F9.4,'-',F6.4/ & - ' Increment factor :',F8.3/) -! - 910 FORMAT (/' Model definition :'/ & - ' --------------------------------------------------') - 911 FORMAT ( ' Dry run (no calculations) : ',A/ & - ' Propagation in X-direction : ',A/ & - ' Propagation in Y-direction : ',A/ & - ' Refraction : ',A/ & - ' Current-induced k-shift : ',A/ & - ' Source term calc. and int. : ',A/) - 912 FORMAT (/' Time steps : '/ & - ' --------------------------------------------------'/ & - ' Maximum global time step (s) :',F8.2/ & - ' Maximum CFL time step X-Y (s) :',F8.2/ & - ' Maximum CFL time step k-theta (s) :',F8.2/ & - ' Minimum source term time step (s) :',F8.2/) - 913 FORMAT (/ ' WARNING, TIME STEP LESS THAN 1 s, NITER:',I8 /) - 915 FORMAT ( ' Preprocessing namelists ...') - 916 FORMAT ( ' Preprocessing namelists finished.'/) - 917 FORMAT (/' Equivalent namelists ...'/) - 918 FORMAT (/' Equivalent namelists finished.'/) -! -!/FLX1 810 FORMAT (/' Stresses (Wu 1980)'/ & -!/FLX1 ' --------------------------------------------------'/) -!/FLX2 810 FORMAT (/' Stresses (T&C 96)'/ & -!/FLX2 ' --------------------------------------------------'/) -!/FLX3 810 FORMAT (/' Stresses (T&C 96 capped) ',A/ & -!/FLX3 ' --------------------------------------------------') -!/FLX4 810 FORMAT (/' Stresses (Hwang 2011) ',A/ & -!/FLX4 ' --------------------------------------------------') -!/FLX4 811 FORMAT ( ' drag coefficient scaling :',F8.2 /) -!/FLX4 2810 FORMAT ( ' &FLX4 CDFAC =',F6.3,' /') -!/FLX5 810 FORMAT (/' Direct use of stress from input'/ & -!/FLX5 ' --------------------------------------------------'/) -!/FLX3 811 FORMAT ( ' Max Cd * 10^3 :',F8.2/ & -!/FLX3 ' Cap type : ',A/) -!/FLX3 2810 FORMAT ( ' &FLX3 CDMAX =',F6.2,'E-3 , CTYPE = ',I1,' /') -! -!/LN0 820 FORMAT (/' Linear input not defined.'/) -!/SEED 820 FORMAT (/' Seeding as proxi for linear input.'/) -! -!/LN1 820 FORMAT (/' Linear input (C&M-R 82) ',A/ & -!/LN1 ' --------------------------------------------------') -!/LN1 821 FORMAT ( ' CLIN :',f8.2/ & -!/LN1 ' Factor for fPM in filter :',F8.2/ & -!/LN1 ' Factor for fh in filter :',F8.2/) -!/LN1 2820 FORMAT ( ' &SLN1 CLIN =',F6.1,', RFPM =',F6.2, & -!/LN1 ', RFHF =',F6.2,' /') -! -!/ST0 920 FORMAT (/' Wind input not defined.'/) -! -!/ST1 920 FORMAT (/' Wind input (WAM-3) ',A/ & -!/ST1 ' --------------------------------------------------') -!/ST1 921 FORMAT ( ' Cinp :',E10.3/) -!/ST1 2920 FORMAT ( ' &SIN1 CINP =',F7.3,' /') -! -!/ST2 920 FORMAT (/' Wind input (T&C 1996) ',A/ & -!/ST2 ' --------------------------------------------------') -!/ST2 921 FORMAT ( ' Height of input wind (m) :',F8.2/ & -!/ST2 ' Factor negative swell :',F9.3/) -!/STAB2 1921 FORMAT ( ' Effective wind mean factor :',F8.2/ & -!/STAB2 ' Stability par. offset :',F9.3/ & -!/STAB2 ' Stab. correction :',F9.3,F8.3/& -!/STAB2 ' Stab. correction stab. fac. :',F7.1,F9.1/) -!/ST2 2920 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,' /') -!/STAB2 2921 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,', STABSH =', & -!/STAB2 F6.3,', STABOF = ',E10.3,','/ & -!/STAB2 ' CNEG =',F7.3,', CPOS =',F7.3,', FNEG =',F7.1,' /') -! -!/ST3 920 FORMAT (/' Wind input (WAM 4+) ',A/ & -!/ST3 ' --------------------------------------------------') -!/ST3 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & -!/ST3 ' betamax :',F9.3/ & -!/ST3 ' power of cos. in wind input :',F9.3/ & -!/ST3 ' z0max :',F9.3/ & -!/ST3 ' zalp :',F9.3/ & -!/ST3 ' Height of input wind (m) :',F8.2/ & -!/ST3 ' swell attenuation factor :',F9.3/ ) -!/ST3 2920 FORMAT ( ' &SIN3 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & -!/ST3 F8.5,','/ & -!/ST3 ' SINTHP =',F8.5,', ZALP =',F8.5,','/ & -!/ST3 ' SWELLF =',F8.5,'R /'/) -! -!/ST4 920 FORMAT (/' Wind input (WAM 4+) ',A/ & -!/ST4 ' --------------------------------------------------') -!/ST4 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & -!/ST4 ' betamax :',F9.3/ & -!/ST4 ' power of cos. in wind input :',F9.3/ & -!/ST4 ' z0max :',F9.3/ & -!/ST4 ' zalp :',F9.3/ & -!/ST4 ' Height of input wind (m) :',F8.2/ & -!/ST4 ' wind stress sheltering :',F9.3/ & -!/ST4 ' swell attenuation param. :',I5/ & -!/ST4 ' swell attenuation factor :',F9.3/ & -!/ST4 ' swell attenuation factor2 :',F9.3/ & -!/ST4 ' swell attenuation factor3 :',F9.3/ & -!/ST4 ' critical Reynolds number :',F9.1/ & -!/ST4 ' swell attenuation factor5 :',F9.3/ & -!/ST4 ' swell attenuation factor6 :',F9.3/ & -!/ST4 ' swell attenuation factor7 :',F14.3/ & -!/ST4 ' ratio of z0 for orb. & mean :',F9.3/) -!/ST4 2920 FORMAT ( ' &SIN4 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & -!/ST4 F8.5,','/ & -!/ST4 ' SINTHP =',F8.5,', ZALP =',F8.5,', TAUWSHELTER =',F8.5, & -!/ST4 ', SWELLFPAR =',I2,','/ & -!/ST4 ' SWELLF =',F8.5,', SWELLF2 =',F8.5, & -!/ST4 ', SWELLF3 =',F8.5,', SWELLF4 =',F9.1,','/ & -!/ST4 ' SWELLF5 =',F8.5,', SWELLF6 =',F8.5, & -!/ST4 ', SWELLF7 =',F12.2,', Z0RAT =',F8.5,', SINBR =',F8.5,' /') -! -!/ST6 920 FORMAT (/' Wind input (Donelan et al, 2006) ',A/ & -!/ST6 ' --------------------------------------------------') -!/ST6 921 FORMAT ( ' negative wind input active : ',A/ & -!/ST6 ' attenuation factor : ',F6.2/ & -!/ST6 ' wind speed scaling factor : ',F6.2/ & -!/ST6 ' frequency cut-off factor : ',F6.2/) -!/ST6 2920 FORMAT ( ' &SIN6 SINA0 =', F6.3, ', SINWS =', F6.2, ', SINFC =', F6.2, ' /') -! -!/NL0 922 FORMAT (/' Nonlinear interactions not defined.'/) -! -!/NL1 922 FORMAT (/' Nonlinear interactions (DIA) ',A/ & -!/NL1 ' --------------------------------------------------') -!/NL1 923 FORMAT ( ' Lambda :',F8.2/ & -!/NL1 ' Prop. constant :',E10.3/ & -!/NL1 ' kd conversion factor :',F8.2/ & -!/NL1 ' minimum kd :',F8.2/ & -!/NL1 ' shallow water constants :',F8.2,2F6.2/) -!/NL1 2922 FORMAT ( ' &SNL1 LAMBDA =',F7.3,', NLPROP =',E10.3, & -!/NL1 ', KDCONV =',F7.3,', KDMIN =',F7.3,','/ & -!/NL1 ' SNLCS1 =',F7.3,', SNLCS2 =',F7.3, & -!/NL1 ', SNLCS3 = ',F7.3,' /') -! -!/NL2 922 FORMAT (/' Nonlinear interactions (WRT) ',A/ & -!/NL2 ' --------------------------------------------------') -!/NL2 923 FORMAT ( ' Deep/shallow options : ',A/ & -!/NL2 ' Power of h-f tail : ',F6.1) -!/NL2 1923 FORMAT ( ' Number of depths used : ',I4/ & -!/NL2 ' Depths (m) :',5F7.1) -!/NL2 2923 FORMAT ( ' ',5F7.1) -!/NL2 2922 FORMAT ( ' &SNL2 IQTYPE =',I2,', TAILNL =',F5.1,',', & -!/NL2 ' NDEPTH =',I3,' /') -!/NL2 3923 FORMAT ( ' &SNL2 DEPTHS =',F9.2,' /') -!/NL2 4923 FORMAT ( ' &ANL2 DEPTHS =',F9.2,' ,') -!/NL2 5923 FORMAT ( ' ',F9.2,' ,') -!/NL2 6923 FORMAT ( ' ',F9.2,' /') -! -!/NL3 922 FORMAT (/' Nonlinear interactions (GMD) ',A/ & -!/NL3 ' --------------------------------------------------') -!/NL3 923 FORMAT ( ' Powers in scaling functions : ',2F7.2/ & -!/NL3 ' Nondimension filter depths : ',2F7.2) -!/NL3 1923 FORMAT ( ' Number of quad. definitions : ',I4) -!/NL3 2923 FORMAT ( ' ',2F8.3,F6.1,2E12.4) -!/NL3 2922 FORMAT ( ' &SNL3 NQDEF =',I3,', MSC =',F6.2,', NSC =', & -!/NL3 F6.2,', KDFD =',F6.2,', KDFS =',F6.2,' /') -!/NL3 3923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & -!/NL3 ', ',E10.4,' /') -!/NL3 4923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & -!/NL3 ', ',E10.4,' ,') -!/NL3 5923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & -!/NL3 ', ',E10.4,' ,') -!/NL3 6923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & -!/NL3 ', ',E10.4,' /') -! -!/NL4 922 FORMAT (/' Nonlinear interactions (TSA) ',A/ & -!/NL4 ' --------------------------------------------------') -!/NL4 923 FORMAT ( ' Source term computation (1=TSA,0=FBI) : ',I2/ & -!/NL4 ' Alternate loops (1=no,2=yes) : ',I2/ & -!/NL4 ' (To speed up computation) ') -!/NL4 2922 FORMAT ( ' &SNL4 ITSA =',I2,', IALT =',I2 ) -! -!/NL5 922 FORMAT(/' Nonlinear interactions (GKE) ',A/ & -!/NL5 ' --------------------------------------------------') -!/NL5 923 FORMAT ( ' Constant water depth (in meter) : ', F7.1/ & -!/NL5 ' Quasi-resonant quartets cut-off : ', F8.2/ & -!/NL5 ' Discretiz. of GKE (0:Con., 1:GS): ', I5/ & -!/NL5 ' GKE (0: GS13-JFM, 1: J03-JPO) : ', I5/ & -!/NL5 ' Interp (0: nearest, 1: bilinear): ', I5/ & -!/NL5 ' Mixing (0: no, N: N Tm, -1: b_T): ', I5/) -!/NL5 2922 FORMAT ( ' &SNL5 NL5DPT =', F7.1, ', NL5OML =', F5.2, & -!/NL5 ', NL5DIS =', I2.1, ', NL5KEV =', I2.1, & -!/NL5 ', NL5IPL =', I2.1, ', NL5PMX =', I5.1, ' /') -! -!/NLS 9922 FORMAT (/' HF filter based on Snl ',A/ & -!/NLS ' --------------------------------------------------') -!/NLS 9923 FORMAT ( ' a34 (lambda) :',F9.3,F9.4/ & -!/NLS ' Prop. constant :',E10.3/ & -!/NLS ' maximum relative change :',F9.3/ & -!/NLS ' filter constants :',F8.2,2F6.2/) -!/NLS 8922 FORMAT ( ' &SNLS A34 =',F6.3,', FHFC =',E11.4, & -!/NLS ', DNM =',F6.3,','/' FC1 =',F6.3, & -!/NLS ', FC2 =',F6.3,', FC3 =',F6.3,' /') -! -!/ST0 924 FORMAT (/' Dissipation not defined.'/) -! -!/ST1 924 FORMAT (/' Dissipation (WAM-3) ',A/ & -!/ST1 ' --------------------------------------------------') -!/ST1 925 FORMAT ( ' Cdis :',E10.3/ & -!/ST1 ' Apm :',E10.3/) -!/ST1 2924 FORMAT ( ' &SDS1 CDIS =',E12.4,', APM =',E11.4,' /') -! -!/ST2 924 FORMAT (/' Dissipation (T&C 1996) ',A/ & -!/ST2 ' --------------------------------------------------') -!/ST2 925 FORMAT ( ' High-frequency constants :',F8.2,E11.3,F6.2/ & -!/ST2 ' Low-frequency constants :',E11.3,F6.2/& -!/ST2 ' ',E11.3,F6.2/& -!/ST2 ' Minimum input peak freq. (-):',F10.4/ & -!/ST2 ' Minimum PHI :',F10.4/) -!/ST2 2924 FORMAT ( ' &SDS2 SDSA0 =',E10.3,', SDSA1 =',E10.3,', SDSA2 =', & -!/ST2 E10.3,', '/ & -!/ST2 ' SDSB0 =',E10.3,', SDSB1 =',E10.3,', ', & -!/ST2 'PHIMIN =',E10.3,' /') -! -!/ST3 924 FORMAT (/' Dissipation (WAM Cycle 4+) ',A/ & -!/ST3 ' --------------------------------------------------') -!/ST3 925 FORMAT ( ' SDSC1 :',1E11.3/ & -!/ST3 ' Power of k in mean k :',F8.2/ & -!/ST3 ' weights of k and k^2 :',F9.3,F6.3/) -!/ST3 2924 FORMAT ( ' &SDS3 SDSC1 =',E12.4,', WNMEANP =',F4.2, & -!/ST3 ', FXPM3 =', F4.2,',FXFM3 =',F4.2,', '/ & -!/ST3 ' SDSDELTA1 =', F5.2,', SDSDELTA2 =',F5.2, & -!/ST3 ' /') -! -!/ST4 924 FORMAT (/' Dissipation (Ardhuin / Filipot / Romero ) ',A/ & -!/ST4 ' --------------------------------------------------') -!/ST4 925 FORMAT ( ' SDSC2, SDSBCK, SDSCUM :',3E11.3/ & -!/ST4 ' Power of k in mean k :',F8.2/) - - -!/ST4 2924 FORMAT ( ' &SDS4 SDSBCHOICE = ',F3.1, & -!/ST4 ', SDSC2 =',E12.4,', SDSCUM =',F6.2,', '/ & -!/ST4 ' SDSC4 =',F6.2,', SDSC5 =',E12.4, & -!/ST4 ', SDSC6 =',E12.4,','/ & -!/ST4 ' WNMEANP =',F4.2,', FXPM3 =', F4.2, & -!/ST4 ', FXFM3 =',F4.1,', FXFMAGE =',F6.3, ', '/ & -!/ST4 ' SDSBINT =',E12.4,', SDSBCK =',E12.4, & -!/ST4 ', SDSABK =',F6.3,', SDSPBK =',F6.3,', '/ & -!/ST4 ' SDSHCK =',F5.2,', SDSBR = ',E12.4, & -!/ST4 ', SDSSTRAIN =',F5.1,', SDSSTRAINA =',F4.1, & -!/ST4 ', SDSSTRAIN2 =',F5.1,', '/ & -!/ST4 ' SDSBT =',F5.2,', SDSP =',F5.2, & -!/ST4 ', SDSISO =',I2, & -!/ST4 ', SDSCOS =',F3.1,', SDSDTH =',F5.1,', '/ & -!/ST4 ' SDSBRF1 = ',F5.2,', SDSBRFDF =',I2,', '/ & -!/ST4 ' SDSBM0 = ',F5.2, ', SDSBM1 =',F5.2, & -!/ST4 ', SDSBM2 =',F5.2,', SDSBM3 =',F5.2,', SDSBM4 =', & -!/ST4 F5.2,', '/, & -!/ST4 ' SPMSS = ',F5.2, ', SDKOF =',F5.2, & -!/ST4 ', SDSMWD =',F5.2,', SDSFACMTF =',F5.1,', '/ & -!/ST4 ' SDSMWPOW =',F3.1,', SDSNMTF =', F5.2, & -!/ST4 ', SDSCUMP =', F3.1,', SDSNUW =', E8.3,', '/, & -!/ST4 ' WHITECAPWIDTH =',F5.2, ' WHITECAPDUR =',F5.2,' /') -! -!/ST6 924 FORMAT (/' Dissipation (Rogers et al. 2012) ',A/ & -!/ST6 ' --------------------------------------------------') -!/ST6 925 FORMAT ( ' normalise by threshold spectral density : ',A/& -!/ST6 ' normalise by spectral density : ',A/& -!/ST6 ' coefficient and exponent for '/ & -!/ST6 ' inherent breaking term a1, L as in (21) : ',E9.3,I3/ & -!/ST6 ' cumulative breaking term a2, M as in (22) : ',E9.3,I3/ & -!/ST6 ' ') -!/ST6 2924 FORMAT ( ' &SDS6 SDSET = ',L,', SDSA1 = ',E9.3, & -!/ST6 ', SDSA2 = ',E9.3,', SDSP1 = ',I2,', SDSP1 = ', & -!/ST6 I2,' /' ) -!/ST6 -!/ST6 937 FORMAT (/' Swell dissipation ',A/ & -!/ST6 ' --------------------------------------------------') -!/ST6 940 FORMAT ( ' subroutine W3SWL6 activated : ',A/ & -!/ST6 ' coefficient b1 ',A, ' : ',E9.3/ ) -!/ST6 2937 FORMAT ( ' &SWL6 SWLB1 = ',E9.3,', CSTB1 = ',L,' /') -! -!/BT0 926 FORMAT (/' Bottom friction not defined.'/) -! -!/BT1 926 FORMAT (/' Bottom friction (JONSWAP) ',A/ & -!/BT1 ' --------------------------------------------------') -!/BT1 927 FORMAT ( ' gamma :',F8.4/) -!/BT1 2926 FORMAT ( ' &SBT1 GAMMA =',E12.4,' /') -! -!/BT4 926 FORMAT (/' Bottom friction (SHOWEX) ',A/ & -!/BT4 ' --------------------------------------------------') -!/BT4 927 FORMAT ( ' SEDMAPD50, SED_D50_UNIFORM :',L3,1X,F8.6/ & -!/BT4 ' RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4 :',4F8.4/ & -!/BT4 ' SIGDEPTH, BOTROUGHMIN, BOTROUGHFAC:',3F8.4/) -!/BT4 2926 FORMAT ( ' &SBT4 SEDMAPD50 =',L3,', SED_D50_UNIFORM =',F8.6,','/ & -!/BT4 ' RIPFAC1 =',F8.4,', RIPFAC2 =',F8.4, & -!/BT4 ', RIPFAC3 =',F8.4,', RIPFAC4 =',F8.4,','/ & -!/BT4 ' SIGDEPTH =',F8.4,', BOTROUGHMIN =',F8.4, & -!/BT4 ', BOTROUGHFAC =',F4.1,' /') -! -!/DB0 928 FORMAT (/' Surf breaking not defined.'/) -! -!/DB1 928 FORMAT (/' Surf breaking (B&J 1978) ',A/ & -!/DB1 ' --------------------------------------------------') -!/DB1 929 FORMAT ( ' alpha :',F8.3/ & -!/DB1 ' gamma :',F8.3) -!/DB1 2928 FORMAT ( ' &SDB1 BJALFA =',F7.3,', BJGAM =',F7.3, & -!/DB1 ', BJFLAG = ',A,' /') -! -!/TR0 930 FORMAT (/' Triad interactions not defined.'/) -! -!/BS0 932 FORMAT (/' Bottom scattering not defined.'/) -!/BS1 932 FORMAT (/' Experimental bottom scattering (F. Ardhuin).'/) -! -!/IC1 935 FORMAT (/' Dissipation via ice parameters (SIC1).'& -!/IC1 ,/' --------------------------------------------------') -! -!/IC2 935 FORMAT (/' Dissipation via ice parameters (SIC2).'& -!/IC2 ,/' --------------------------------------------------') -! -!/IC3 935 FORMAT (/' Dissipation via ice parameters (SIC3).'& -!/IC3 ,/' --------------------------------------------------') -! -!/IC4 935 FORMAT (/' Dissipation via ice parameters (SIC4).'& -!/IC4 ,/' --------------------------------------------------') -! -!/IC5 935 FORMAT (/' Dissipation via ice parameters (SIC5).'& -!/IC5 ,/' --------------------------------------------------') -! -!/IS0 944 FORMAT (/' Ice scattering not defined.'/) -!/IS1 945 FORMAT (/' Ice scattering ',A,/ & -!/IS1 ' --------------------------------------------------') -!/IS1 946 FORMAT (' Isotropic (linear function of ice concentration)'/& -!/IS1 ' slope : ',E10.3/ & -!/IS1 ' offset : ',E10.3) -!/IS1 2946 FORMAT ( ' &SIS1 ISC1 =',E9.3,', ISC2 =',E9.3) -!/IS2 947 FORMAT (/' Ice scattering ',A,/ & -!/IS2 ' --------------------------------------------------') -!/IS2 948 FORMAT (' IS2 Scattering ... '/& -!/IS2 ' scattering coefficient : ',E9.3/ & -!/IS2 ' 0: no back-scattering : ',E9.3/ & -!/IS2 ' TRUE: istropic back-scattering : ',L3/ & -!/IS2 ' TRUE: update of ICEDMAX : ',L3/ & -!/IS2 ' TRUE: keeps updated ICEDMAX : ',L3/ & -!/IS2 ' flexural strength : ',E9.3/ & -!/IS2 ' TRUE: uses Robinson-Palmer disp.: ',L3/ & -!/IS2 ' attenuation : ',F5.2/ & -!/IS2 ' fragility : ',F5.2/ & -!/IS2 ' minimum floe size in meters : ',F5.2/ & -!/IS2 ' pack scattering coef 1 : ',F5.2/ & -!/IS2 ' pack scattering coef 2 : ',F5.2/ & -!/IS2 ' scaling by concentration : ',F5.2/ & -!/IS2 ' creep B coefficient : ',E9.3/ & -!/IS2 ' creep C coefficient : ',F5.2/ & -!/IS2 ' creep D coefficient : ',F5.2/ & -!/IS2 ' creep N power : ',F5.2/ & -!/IS2 ' elastic energy factor : ',F5.2/ & -!/IS2 ' factor for ice breakup : ',F5.2/ & -!/IS2 ' IS2WIM1 : ',F5.2/ & -!/IS2 ' anelastic dissipation : ',L3/ & -!/IS2 ' energy of activation : ',F5.2/ & -!/IS2 ' anelastic coefficient : ',E11.3/ & -!/IS2 ' anelastic exponent : ',F5.2) -!/IS2 2948 FORMAT ( ' &SIS2 ISC1 =',E9.3,', IS2BACKSCAT =',E9.3, & -!/IS2 ', IS2ISOSCAT =',L3,', IS2BREAK =',L3, & -!/IS2 ', IS2DUPDATE =',L3,','/ & -!/IS2 ' IS2FLEXSTR =',E11.3,', IS2DISP =',L3, & -!/IS2 ', IS2DAMP =',F3.1, & -!/IS2 ', IS2FRAGILITY =',F4.2,', IS2DMIN =',F5.2,','/ & -!/IS2 ' IS2C2 =',F12.8,', IS2C3 =',F8.4, & -!/IS2 ', IS2CONC =',F5.1,', IS2CREEPB =',E11.3,','/ & -!/IS2 ' IS2CREEPC =',F5.2,', IS2CREEPD =',F5.2, & -!/IS2 ', IS2CREEPN =',F5.2,','/ & -!/IS2 ' IS2BREAKE =',F5.2, & -!/IS2 ', IS2BREAKF =',F5.2,', IS2WIM1 =',F5.2,','/ & -!/IS2 ', IS2ANDISB =',L3,', IS2ANDISE =',F5.2, & -!/IS2 ', IS2ANDISD =',E11.3,', IS2ANDISN=',F5.2, ' /') -!/UOST 4500 FORMAT (/' Unresolved Obstacles Source Term (UOST) ',A,/ & -!/UOST ' --------------------------------------------------') -!/UOST 4501 FORMAT (' local alpha-beta file: ',A, & -!/UOST ' shadow alpha-beta file: ',A,/ & -!/UOST ' local calibration factor: ',F5.2, & -!/UOST ' shadow calibration factor: ',F5.2) -!/UOST 4502 FORMAT (' &UOST UOSTFILELOCAL = ',A,', UOSTFILESHADOW = ',A,/ & -!/UOST ' UOSTFACTORLOCAL = ',F5.2', UOSTFACTORSHADOW = ',F5.2,' /') -! - 950 FORMAT (/' Propagation scheme : '/ & - ' --------------------------------------------------') - 951 FORMAT ( ' Type of scheme (structured) :',1X,A) - 2951 FORMAT ( ' Type of scheme(unstructured):',1X,A) - 2952 FORMAT ( ' wave setup computation:',1X,A) - 952 FORMAT ( ' ',1X,A) -!/PR1 953 FORMAT ( ' CFLmax depth refraction :',F9.3/) -!/PR1 2953 FORMAT ( ' &PRO1 CFLTM =',F5.2,' /') -! -!/PR2 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & -!/PR2 ' Effective swell age (h) : switched off'/ & -!/PR2 ' Cut-off latitude (degr.) :',F7.1/) -!/PR2 954 FORMAT ( ' CFLmax depth refraction :',F9.3/ & -!/PR2 ' Effective swell age (h) :',F8.2/ & -!/PR2 ' Cut-off latitude (degr.) :',F7.1/) -!/PR2 2953 FORMAT ( ' &PRO2 CFLTM =',F5.2,', DTIME =',F8.0, & -!/PR2 ', LATMIN =',F5.1,' /') -! -!/SMC 1950 FORMAT (/' SMC grid parameters : '/ & -!/SMC ' --------------------------------------------------') -!/SMC 1951 FORMAT ( ' Type of scheme (structured) :',1X,A) -!/SMC 1953 FORMAT ( ' Max propagation CFL number :',F9.3/ & -!/SMC ' Effective swell age (h) :',F8.2/ & -!/SMC ' Maximum refraction (degr.) :',F8.2/) -!/SMC 2954 FORMAT ( ' &PSMC CFLSM =',F5.2,', DTIMS =', F9.1/ & -!/SMC ' Arctic =',L5, ', RFMAXD =', F9.2/ & -!/SMC ' UNO3 =',L5, ', AVERG =',L5/ & -!/SMC ' LvSMC =',i5, ', NBISMC =',i9/ & -!/SMC ' ISHFT =',i5, ', JEQT =',i9/ & -!/SMC ' SEAWND =',L5, '/') -! -!/PR3 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & -!/PR3 ' Averaging area factor Cg :',F8.2) -!/PR3 954 FORMAT ( ' Averaging area factor theta :',F8.2) -!/PR3 955 FORMAT ( ' **** Internal maximum .GE.',F6.2,' ****') -!/PR3 2953 FORMAT ( ' &PRO3 CFLTM =',F5.2, & -!/PR3 ', WDTHCG = ',F4.2,', WDTHTH = ',F4.2,' /') -! - 2956 FORMAT ( ' &UNST UGBCCFL =',L3,', UGOBCAUTO =',L3, & - ', UGOBCDEPTH =', F8.3,', UGOBCFILE=',A,','/ & - ', EXPFSN =',L3,',EXPFSPSI =',L3, & - ', EXPFSFCT =', L3,',IMPFSN =',L3,',EXPTOTAL=',L3, & - ', IMPTOTAL=',L3,',IMPREFRACTION=', L3, & - ', IMPFREQSHIFT=', L3,', IMPSOURCE=', L3, & - ', SETUP_APPLY_WLV=', L3, & - ', JGS_TERMINATE_MAXITER=', L3, & - ', JGS_TERMINATE_DIFFERENCE=', L3, & - ', JGS_TERMINATE_NORM=', L3, & - ', JGS_LIMITER=', L3, & - ', JGS_USE_JACOBI=', L3, & - ', JGS_BLOCK_GAUSS_SEIDEL=', L3, & - ', JGS_MAXITER=', I5, & - ', JGS_PMIN=', F8.3, & - ', JGS_DIFF_THR=', F8.3, & - ', JGS_NORM_THR=', F8.3, & - ', JGS_NLEVEL=', I3, & - ', JGS_SOURCE_NONLINEAR=', L3 / ) -! - 960 FORMAT (/' Miscellaneous ',A/ & - ' --------------------------------------------------') - 2961 FORMAT ( ' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' CICE0.NE.CICEN requires FLAGTR>2'/ & - ' Parameters corrected: CICE0 = CICEN'/) - 2962 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID : User requests', & - 'CICE0=CICEN corresponding to discontinuous treatment of ', & - 'ice, so we will change FLAGTR') - 2963 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' Ice physics used, so we will change FLAGTR.') - 961 FORMAT ( ' Ice concentration cut-offs :',F8.2,F6.2) -!/MGG 962 FORMAT ( ' Moving grid GSE cor. power :',F8.2) -!/SCRIP 963 FORMAT( ' Grid offset for multi-grid w/SCRIP : ',E11.3) - 1972 FORMAT ( ' Compression of track output : ',L3) -!/SEED 964 FORMAT ( ' Xseed in seeding algorithm :',F8.2) - 965 FORMAT (/' Dynamic source term integration scheme :'/ & - ' Xp (-) :',F9.3/ & - ' Xr (-) :',F9.3/ & - ' Xfilt (-) :',F9.3) - 966 FORMAT (/' Wave field partitioning :'/ & - ' Levels (-) :',I5/ & - ' Minimum wave height (m) :',F9.3/ & - ' Wind area multiplier (-) :',F9.3/ & - ' Cut-off wind sea fract. (-) :',F9.3/ & - ' Combine wind seas : ',A/ & - ' Number of swells in fld out :',I5) - 967 FORMAT (/' Miche-style limiting wave height :'/ & - ' Hs,max/d factor (-) :',F9.3/ & - ' Hrms,max/d factor (-) :',F9.3/ & - ' Limiter activated : ',A) - 968 FORMAT ( ' *** FACTOR DANGEROUSLY LOW ***') - 1973 FORMAT (/' Calendar type : ',A) -! -!/REF1 969 FORMAT (/' Shoreline reflection ',A/ & -!/REF1 ' --------------------------------------------------') -! -!/IG1 970 FORMAT (/' Second order and infragravity waves ',A/ & -!/IG1 ' --------------------------------------------------') -! - 5971 FORMAT (' Partitioning method : ',A) - 5972 FORMAT (' Namelist options overridden : ',A) -! -!/IC2 971 FORMAT (/' Boundary layer below ice ',A/ & -!/IC2 ' --------------------------------------------------') -!/IC3 971 FORMAT (/' Visco-elastic ice layer ',A/ & -!/IC3 ' --------------------------------------------------') -!/IC4 971 FORMAT (/' Empirical wave-ice physics ',A/ & -!/IC4 ' --------------------------------------------------') -!/IC5 971 FORMAT (/' Effective medium ice model (SIC5) ',A/ & -!/IC5 ' --------------------------------------------------') -!/IC5 2971 FORMAT ( ' Min. Ice shear modulus G : ', E10.1/, & -!/IC5 ' Min. Wave period T : ', F7.2/, & -!/IC5 ' Max. Wavenumber Ratio (Ko/Kr): ', E10.1/, & -!/IC5 ' Max. Attenu. Rate (Ki) : ', E10.1/, & -!/IC5 ' Min. Water depth (d) : ', F5.0/, & -!/IC5 ' Max. # of Newton Iter. : ', F5.0/, & -!/IC5 ' Use Rand. Kick : ', F5.0/, & -!/IC5 ' Excluded Imag. Corridor : ', F9.4/, & -!/IC5 ' Selected ice model : ', A/) -! - 8972 FORMAT ( ' Wind input reduction factor in presence of ', & - /' ice :',F6.2, & - /' (0.0==> no reduction and 1.0==> no wind', & - /' input with 100% ice cover)') -! -! - 4970 FORMAT (/' Spectral output on full grid ',A/ & - ' --------------------------------------------------') - 4971 FORMAT ( ' Second order pressure at K=0:',3I4) - 4972 FORMAT ( ' Spectrum of Uss :',3I4) - 4973 FORMAT ( ' Frequency spectrum :',3I4) - 4974 FORMAT ( ' Partions of Uss :',2I4) - 4975 FORMAT ( ' Partition wavenumber #',I2,' : ',1F6.3) - -! - 4980 FORMAT (/' Coastal / iceberg reflection ',A/ & - ' --------------------------------------------------') - 4981 FORMAT ( ' Coefficient for shorelines :',F6.4) - 4989 FORMAT ( ' *** CURVLINEAR GRID: REFLECTION NOT IMPLEMENTED YET ***') - 2977 FORMAT ( ' &SIG1 IGMETHOD =',I2,', IGADDOUTP =',I2,', IGSOURCE =',I2, & - ', IGSTERMS = ',I2,', IGBCOVERWRITE =', L3,','/ & - ' IGSWELLMAX =', L3,', IGMAXFREQ =',F6.4, & - ', IGSOURCEATBP = ',I2,', IGKDMIN = ',F6.4,','/ & - ' IGFIXEDDEPTH = ',F6.2,', IGEMPIRICAL = ',F8.6,' /') -! - 2978 FORMAT ( ' &SIC2 IC2DISPER =',L3,', IC2TURB =',F6.2, & - ', IC2ROUGH =',F10.6,','/ & - ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & - ', IC2VISC =',F6.3,','/ & - ', IC2TURBS =',F8.2,', IC2DMAX =',F5.3,' /') -! - 2979 FORMAT ( ' &SIC3 IC3MAXTHK =',F6.2, ', IC3MAXCNC =',F6.2,','/ & - ' IC2TURB =',F8.2, & - ', IC2ROUGH =',F7.3,','/ & - ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & - ', IC2VISC =',F10.3,','/ & - ' IC2TURBS =',F8.2,', IC3CHENG =',L3, & - ', USECGICE =',L3,', IC3HILIM = ',F6.2,','/ & - ' IC3KILIM = ',E9.2,', IC3HICE = ',E9.2, & - ', IC3VISC = ',E9.2,','/ & - ' IC3DENS = ',E9.2,', IC3ELAS = ',E9.2,' /') -! - 2981 FORMAT ( ' &SIC5 IC5MINIG = ', E9.2, ', IC5MINWT = ', F5.2, & - ', IC5MAXKRATIO = ', E9.2, ','/ & - ' IC5MAXKI = ', E9.2, ', IC5MINHW = ', F4.0, & - ', IC5MAXITER = ', F4.0, ','/ & - ' IC5RKICK = ', F2.0, ', IC5KFILTER = ', F7.4, & - ', IC5VEMOD = ', F4.0, ' /') -! - 2966 FORMAT ( ' &MISC CICE0 =',F6.3,', CICEN =',F6.3, & - ', LICE = ',F8.1,', PMOVE =',F6.3,','/ & - ' XSEED =',F6.3,', FLAGTR = ', I1, & - ', XP =',F6.3,', XR =',F6.3,', XFILT =', F6.3 / & - ' IHM =',I5,', HSPM =',F6.3,', WSM =',F6.3, & - ', WSC =',F6.3,', FLC = ',A/ & - ' NOSW =',I3,', FMICHE =',F6.3,', RWNDC =' , & - F6.3,', WCOR1 =',F6.2,', WCOR2 =',F6.2,','/ & - ' FACBERG =',F4.1,', GSHIFT = ',E11.3, & - ', STDX = ' ,F7.2,', STDY =',F7.2,','/ & - ' STDT =', F8.2, & - ', ICEHMIN =',F5.2,', ICEHFAC =',F5.2,','/ & - ' ICEHINIT =',F5.2,', ICEDISP =',L3, & - ', ICEHDISP =',F5.2,','/ & - ' ICESLN = ',F6.2,', ICEWIND = ',F6.2, & - ', ICESNL = ',F6.2,', ICESDS = ',F5.2,','/ & - ' ICEDDISP = ',F5.2,', ICEFDISP = ',F5.2, & - ', CALTYPE = ',A8,' , TRCKCMPR = ', L3,','/ & - ' BTBET = ', F6.2, ' /') -! - 2976 FORMAT ( ' &OUTS P2SF =',I2,', I1P2SF =',I2,', I2P2SF =',I3,','/& - ' US3D =',I2,', I1US3D =',I3,', I2US3D =',I3,','/& - ' USSP =',I2,', IUSSP =',I3,','/& - ' E3D =',I2,', I1E3D =',I3,', I2E3D =',I3,','/& - ' TH1MF =',I2,', I1TH1M =',I3,', I2TH1M =',I3,','/& - ' STH1MF=',I2,', I1STH1M=',I3,', I2STH1M=',I3,','/& - ' TH2MF =',I2,', I1TH2M =',I3,', I2TH2M =',I3,','/& - ' STH2MF=',I2,', I1STH2M=',I3,', I2STH2M=',I3,' /') -! - 2986 FORMAT ( ' &REF1 REFCOAST =',F5.2,', REFFREQ =',F5.2,', REFSLOPE =',F5.3, & - ', REFMAP =',F4.1, ', REFMAPD =',F4.1, ', REFSUBGRID =',F5.2,','/ & - ' REFRMAX=',F5.2,', REFFREQPOW =',F5.2, & - ', REFICEBERG =',F5.2,', REFCOSP_STRAIGHT =',F4.1,' /') -! - 2987 FORMAT ( ' &FLD TAIL_ID =',I1,' TAIL_LEV =',F5.4,' TAILT1 =',F5.3,& - ' TAILT2 =',F5.3,' /') -!/RTD -!/RTD 4991 FORMAT ( ' &ROTD PLAT =', F6.2,', PLON =', F7.2,', UNROT =',L3,' /') -!/RTD 4992 FORMAT ( ' &ROTB BPLAT =',9(F6.1,",")/ & -!/RTD ' BPLON =',9(F6.1,","),' /') - - 3000 FORMAT (/' The spatial grid: '/ & - ' --------------------------------------------------'/ & - /' Grid type : ',A) - 3001 FORMAT ( ' Coordinate system : ',A) - 3002 FORMAT ( ' Index closure type : ',A) - 3003 FORMAT ( ' Dimensions : ',I6,I8) - 3004 FORMAT (/' Increments (deg.) :',2F10.4/ & - ' Longitude range (deg.) :',2F10.4/ & - ' Latitude range (deg.) :',2F10.4) - 3005 FORMAT ( ' Increments (km) :',2F8.2/ & - ' X range (km) :',2F8.2/ & - ' Y range (km) :',2F8.2) - 3006 FORMAT (/' X-coordinate unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Add offset :',E12.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 3007 FORMAT (/' Y-coordinate unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Add offset :',E12.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 3008 FORMAT ( ' Format : ',A) - 3009 FORMAT ( ' File name : ',A) -!/SMC 4001 FORMAT ( ' SMC refined levels NRLv = ',I8) -!/SMC 4002 FORMAT ( ' SMC Equator j shift no. = ',I8) -!/SMC 4302 FORMAT ( ' SMC I-index shift number = ',I8) -!/SMC 4003 FORMAT ( ' SMC input boundary no. = ',I8) -!/SMC 4004 FORMAT ( ' SMC NCel = ',6I9) -!/SMC 4005 FORMAT ( ' IJKCel(5,NCel) read from ', A) -!/SMC 4006 FORMAT (6I8) -!/SMC 4007 FORMAT ( ' SMC NUFc = ',6I9) -!/SMC 4008 FORMAT ( ' IJKUFc(7,NCel) read from ', A) -!/SMC 4009 FORMAT (8I8) -!/SMC 4010 FORMAT ( ' SMC NVFc = ',6I9) -!/SMC 4011 FORMAT ( ' IJKVFc(8,NCel) read from ', A) -!/SMC 4110 FORMAT ( ' SMC NCObsr = ',6I9) -!/SMC 4111 FORMAT ( ' IJKObstr(1,NCel) read from ', A) -!/SMC 4012 FORMAT (9I8) -!/SMC 4013 FORMAT ( ' NBICelin(NBISMC) read from ', A) -!/SMC 4014 FORMAT (2I8) -!/SMC 4015 FORMAT ( ' ARC NARC = ',6I9) -!/SMC 4016 FORMAT ( ' IJKCel(5,NARC) read from ', A) -!/SMC 4017 FORMAT ( ' ARC NAUI = ',6I9) -!/SMC 4018 FORMAT ( ' IJKUFc(7,NAUI) read from ', A) -!/SMC 4019 FORMAT ( ' ARC NAVJ = ',6I9) -!/SMC 4020 FORMAT ( ' IJKVFc(8,NAVJ) read from ', A) -!/SMC 4021 FORMAT ( ' Varables by W3DIMX NCel = ',I9) -!/SMC 4022 FORMAT ( ' Defined NLvCel ',6I9) -!/SMC 4023 FORMAT ( ' Defined NLvUFc ',6I9) -!/SMC 4024 FORMAT ( ' Defined NLvVFc ',6I9) -!/SMC 4025 FORMAT ( ' Define IJKCel from -9 to ',I9) -!/SMC 4026 FORMAT ( ' IJKCel(5,NCel) defined : ') -!/SMC 4027 FORMAT ( ' IJKUFc(7,NUFc) defined : ') -!/SMC 4028 FORMAT ( ' IJKVFc(8,NVFc) defined : ') -!/SMC 4029 FORMAT ( ' Boundary cells IJKCel(:,-9:0) : ') -!/SMC 4030 FORMAT (5I8) -!/SMC 4031 FORMAT ( ' Define MAPSF ... 1 to ',I9) -!/SMC 4032 FORMAT ( ' Multi-Resolution factor = ',I6) -!/SMC 4033 FORMAT ( ' Range of MAPSF(:,1) : ',2I9) -!/SMC 4034 FORMAT ( ' Range of MAPSF(:,2) : ',2I9) -!/SMC 4035 FORMAT ( ' Range of MAPSF(:,3) : ',2I9) -!/SMC 4036 FORMAT ( ' Range of MAPFS(:,:) : ',2I9) -!/SMC 4037 FORMAT ( ' Arctic AngArc defined as ',I6) -!/SMC 4038 FORMAT (9F8.2) -!/SMC 4039 FORMAT ( ' Arctic ICLBAC defined as ',I6) -!/SMC 4040 FORMAT (9I8) -!/RTD 4200 FORMAT ( ' AnglDin(NX,NY) defn checks : ') -!/RTD 4201 FORMAT ( ' JY/IX',4I8) -!/RTD 4202 FORMAT (I12,4F8.2) -!/RTD 4203 FORMAT ( ' Rotated pole lat/lon (deg.) : ',2F9.3) -!/RTD 4204 FORMAT ( ' Output dirns and x-y vectors will be set to True North') - 972 FORMAT (/' Bottom level unit :',I6/ & - ' Limiting depth (m) :',F8.2/ & - ' Minimum depth (m) :',F8.2/ & - ' Scale factor :',F8.2/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 973 FORMAT ( ' Format : ',A) - 974 FORMAT ( ' File name : ',A) - 976 FORMAT (/' Sub-grid information : ',A) - 977 FORMAT ( ' Obstructions unit :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 978 FORMAT (/' Mask information : From file.'/ & - ' Mask unit :',I6/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 1977 FORMAT ( ' Shoreline slope :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) - 1978 FORMAT ( ' Grain sizes :',I6/ & - ' Scale factor :',F10.4/ & - ' Layout indicator :',I6/ & - ' Format indicator :',I6) -! - 979 FORMAT ( ' Processing ',A) - 980 FORMAT (/' Input boundary points : '/ & - ' --------------------------------------------------') - 1980 FORMAT (/' Excluded points : '/ & - ' --------------------------------------------------') - 981 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED), IX, IY =') - 1981 FORMAT ( ' *** POINT ALREADY EXCLUDED (SKIPPED), IX, IY =') - 982 FORMAT ( ' *** CANNOT CONNECT POINTS, IX, IY =') - 985 FORMAT ( ' No boundary points.'/) - 986 FORMAT ( ' Number of boundary points :',I6/) - 1985 FORMAT ( ' No excluded points.'/) - 1986 FORMAT ( ' Number of excluded points :',I6/) - 987 FORMAT ( ' Nr.| IX | IY | Long. | Lat. '/ & - ' -----|-------|-------|---------|---------') - 1987 FORMAT ( ' Nr.| IX | IY | X | Y '/ & - ' -----|-------|-------|-----------|-----------') - 988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.2)) - 1988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.1,'E3')) - 989 FORMAT ( ' ') -! - 990 FORMAT (/' Output boundary points : '/ & - ' --------------------------------------------------') - 991 FORMAT ( ' File nest',I1,'.ww3 Number of points :',I6/ & - ' Number of spectra :',I6) - 1991 FORMAT ( ' Dest. grid Polat:',F6.2,', Polon:',F8.2) - 992 FORMAT (/' Nr.| Long. | Lat. '/ & - ' -----|---------|---------') - 1992 FORMAT (/' Nr.| Long. | Lat. ', & - ' Nr.| Long. | Lat. '/ & - ' -----|---------|---------', & - ' -----|---------|---------') - 993 FORMAT ( ' ',I4,2(' |',F8.2)) - 1993 FORMAT ( ' ',I4,2(' |',F8.2), & - ' ',I4,2(' |',F8.2)) - 994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2F10.5) - 995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2F10.5) - 2992 FORMAT (/' Nr.| X | Y '/ & - ' -----|-----------|-----------') - 3992 FORMAT (/' Nr.| X | Y ', & - ' Nr.| X | Y '/ & - ' -----|-----------|-----------', & - ' -----|-----------|-----------') - 2993 FORMAT ( ' ',I4,2(' |',F8.1,'E3')) - 3993 FORMAT ( ' ',I4,2(' |',F8.1,'E3'), & - ' ',I4,2(' |',F8.1,'E3')) - 2994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2(F8.1,'E3')) - 2995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2(F8.1,'E3')) - 996 FORMAT ( ' No boundary points.'/) - 997 FORMAT ( ' Number of boundary points :',I6/ & - ' Number of spectra :',I6/) -! -!/O2a 998 FORMAT (50I2) -!/O2c 1998 FORMAT (50I2) -! - 999 FORMAT (/' Writing model definition file ...'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' ERROR IN OPENING INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' PREMATURE END OF INPUT FILE'/) -! - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) -! - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' INVALID CALENDAR TYPE: SELECT ONE OF:', & - ' standard, 360_day, or 365_day '/) -! - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' CANNOT READ UNFORMATTED (IDFM = 3) FROM UNIT', & - I4,' (ww3_grid.inp)'/) -! - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & - ' BOTTOM AND OBSTRUCTION DATA FROM SAME FILE '/ & - ' BUT WITH INCOMPATIBLE FORMATS (',I1,',',I1,')'/) -! - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' TOO MANY NESTING OUTPUT FILES '/) -! - 1007 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' ILLEGAL GRID TYPE:',A4) -! - 1008 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' A CARTESIAN WITH CLOSURE IS NOT ALLOWED') -! - 1009 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' A RECTILINEAR TRIPOLE GRID IS NOT ALLOWED') -! - 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'// & - ' NO PROPAGATION + NO SOURCE TERMS = NO WAVE MODEL'// & - ' ( USE DRY RUN FLAG TO TEMPORARILY SWITCH OFF ', & - 'CALCULATIONS )'/) -! - 1011 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' LEFT-HANDED GRID -- POSSIBLE CAUSE IS WRONG '/ & - ' IDLA:',I4,' . THIS MAY PRODUCE ERRORS '/ & - ' (COMMENT THIS EXTCDE AT YOUR OWN RISK).') -! - 1012 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' ILLEGAL GRID CLOSURE TYPE:',A4) -! - 1013 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & - ' THE GLOBAL (LOGICAL) INPUT FLAG IS DEPRECATED'/ & - ' AND REPLACED WITH A STRING INDICATING THE TYPE'/ & - ' OF GRID INDEX CLOSURE (NONE, SMPL or TRPL).'/ & - ' *** PLEASE UPDATE YOUR GRID INPUT FILE ACCORDINGLY ***'/) -! -!/SMC 1014 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & -!/SMC ' SMC CELL LONGITUDE RANGE OUTSIDE BASE GRID RANGE:'/& -!/SMC ' ISEA =', I6, '; IX =', I4, ':', I4,'; NX =', I4/) -! -!/SMC 1015 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & -!/SMC ' SMC CELL LATITUDE RANGE OUTSIDE BASE GRID RANGE: '/& -!/SMC ' ISEA =', I6, '; IY =', I4, ':', I4,'; NY =', I4/) -! - 1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & - ' SOURCE TERMS REQUESTED BUT NOT SELECTED'/) - 1021 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' SOURCE TERMS SELECTED BUT NOT REQUESTED'/) - 1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/LNn OR SEED SWITCHES :',I3) - 1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/STn SWITCHES :',I3) - 1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/NLn SWITCHES :',I3) - 1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/BTn SWITCHES :',I3) - 1026 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/DBn SWITCHES :',I3) - 1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/TRn SWITCHES :',I3) - 1028 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/BSn SWITCHES :',I3) -! - 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' PROPAGATION REQUESTED BUT NO SCHEME SELECTED '/) - 1031 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' NO PROPAGATION REQUESTED BUT SCHEME SELECTED '/) - 1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' NO PROPAGATION SCHEME SELECTED ( use !/PR0 ) '/) - 1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' MULTIPLE PROPAGATION SCHEMES SELECTED :',I3/ & - ' CHECK !/PRn SWITCHES'/) - 1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/ICn SWITCHES :',I3) - 1035 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & - ' ONLY FIRST PROPAGATION SCHEME WILL BE USED: ') - 1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & - ' ILLEGAL NUMBER OF !/ISn SWITCHES :',I3) -!/RTD 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & -!/RTD ' WITH NAMELIST VALUE PLAT == 90, PLON MUST BE -180'/ & -!/RTD ' AND UNROT MUST BE .FALSE.' ) -! -!/RTD 1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & -!/RTD ' WITH NAMELIST VALUE BPLAT == 90, BPLON MUST BE -180') -! - 1040 FORMAT ( ' Space-time extremes DX :',F10.2) - 1041 FORMAT ( ' Space-time extremes DX :',F10.2) - 1042 FORMAT ( ' Space-time extremes DX-Y set to default 1000 m') - 1043 FORMAT ( ' Space-time extremes Dt :',F8.2) - 1044 FORMAT ( ' Space-time extremes Dt set to default 1200 s') -! - 1100 FORMAT (/' Status map, printed in',I6,' part(s) '/ & - ' -----------------------------------'/) - 1101 FORMAT (2X,180I2) - 1102 FORMAT ( ' Legend : '/ & - ' -----------------------------'/ & - ' 0 : Land point '/ & - ' 1 : Sea point '/ & - ' 2 : Active boundary point '/ & - ' 3 : Excluded point '/) - 1103 FORMAT (/' Obstruction map ',A1,', printed in',I6,' part(s) '/ & - ' ---------------------------------------------'/) - 1104 FORMAT ( ' Legend : '/ & - ' --------------------------------'/ & - ' fraction of obstruction * 10 '/) - - 1105 FORMAT (/' Shoreline slope, printed in',I6,' part(s) '/ & - ' ---------------------------------------------'/) - 1106 FORMAT ( ' Legend : '/ & - ' --------------------------------'/ & - ' Slope * 100'/) - - - 1150 FORMAT (/' Reading unstructured grid definition files ...'/) -! - 9997 FORMAT (/' Summary grid statistics : '/ & - ' --------------------------------------------------'/ & - ' Number of longitudes :',I10/ & - ' Number of latitudes :',I10/ & - ' Number of grid points :',I10/ & - ' Number of sea points :',I10,' (',F4.1,'%)'/& - ' Number of input b. points :',I10/ & - ' Number of land points :',I10/ & - ' Number of excluded points :',I10/) - 9998 FORMAT (/' Summary grid statistics : '/ & - ' --------------------------------------------------'/ & - ' Number of longitudes :',I10/ & - ' Number of latitudes :',I10/ & - ' Number of grid points :',I10/ & - ' Number of sea points :',I10,' (100%)'/ & - ' Number of input b. points :',I10/ & - ' Number of land points :',I10/ & - ' Number of excluded points :',I10/) - 9999 FORMAT (/' End of program '/ & - ' ========================================'/ & - ' WAVEWATCH III Grid preprocessor '/) -! -!/T 9090 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT DATA LINE SEG.') -!/T 9091 FORMAT ( ' ',2F8.2,4(2I4,F7.2)) -!/T 9092 FORMAT ( ' ',F7.2,2X,4F7.2) -!/T 9093 FORMAT ( ' ',4I7/ & -!/T ' ',4I7) -! -!/T0 9095 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT SPEC DATA ') -!/T0 9096 FORMAT ( ' ',I3,2I8) - - END SUBROUTINE -!/ -!/ Internal function READNL ------------------------------------------ / -!/ -!/ ------------------------------------------------------------------- / - SUBROUTINE READNL ( NDS, NAME, STATUS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 01-Jun-2013 | -!/ +-----------------------------------+ -!/ -! 1. Purpose : -! -! Read namelist info from file if namelist is found in file. -! -! 2. Method : -! -! Look for namelist with name NAME in unit NDS and read if found. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number used for search. -! NAME C*4 I Name of namelist. -! STATUS C*20 O Status at end of routine, -! '(default values) ' if no namelist found. -! '(user def. values)' if namelist read. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Program in which it is contained. -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS - CHARACTER, INTENT(IN) :: NAME*4 - CHARACTER, INTENT(OUT) :: STATUS*20 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IERR, I, J - CHARACTER :: LINE*80 -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'READNL') -! - REWIND (NDS) - STATUS = '(default values) : ' -! - DO - READ (NDS,'(A)',END=800,ERR=800,IOSTAT=IERR) LINE - DO I=1, 70 - IF ( LINE(I:I) .NE. ' ' ) THEN - IF ( LINE(I:I) .EQ. '&' ) THEN - IF ( LINE(I+1:I+4) .EQ. NAME ) THEN - BACKSPACE (NDS) - SELECT CASE(NAME) -!/FLD1 CASE('FLD1') -!/FLD1 READ (NDS,NML=FLD1,END=801,ERR=802,IOSTAT=J) -!/FLD2 CASE('FLD2') -!/FLD2 READ (NDS,NML=FLD2,END=801,ERR=802,IOSTAT=J) -!/FLX3 CASE('FLX3') -!/FLX3 READ (NDS,NML=FLX3,END=801,ERR=802,IOSTAT=J) -!/FLX4 CASE('FLX4') -!/FLX4 READ (NDS,NML=FLX4,END=801,ERR=802,IOSTAT=J) -!/LN1 CASE('SLN1') -!/LN1 READ (NDS,NML=SLN1,END=801,ERR=802,IOSTAT=J) -!/ST1 CASE('SIN1') -!/ST1 READ (NDS,NML=SIN1,END=801,ERR=802,IOSTAT=J) -!/ST2 CASE('SIN2') -!/ST2 READ (NDS,NML=SIN2,END=801,ERR=802,IOSTAT=J) -!/ST3 CASE('SIN3') -!/ST3 READ (NDS,NML=SIN3,END=801,ERR=802,IOSTAT=J) -!/ST4 CASE('SIN4') -!/ST4 READ (NDS,NML=SIN4,END=801,ERR=802,IOSTAT=J) -!/ST6 CASE('SIN6') -!/ST6 READ (NDS,NML=SIN6,END=801,ERR=802,IOSTAT=J) -!/NL1 CASE('SNL1') -!/NL1 READ (NDS,NML=SNL1,END=801,ERR=802,IOSTAT=J) -!/NL2 CASE('SNL2') -!/NL2 READ (NDS,NML=SNL2,END=801,ERR=802,IOSTAT=J) -!/NL2 CASE('ANL2') -!/NL2 IF ( NDEPTH .GT. 100 ) GOTO 804 -!/NL2 DEPTHS(1:NDEPTH) = DPTHNL -!/NL2 READ (NDS,NML=ANL2,END=801,ERR=802,IOSTAT=J) -!/NL2 DPTHNL = DEPTHS(1:NDEPTH) -!/NL3 CASE('SNL3') -!/NL3 READ (NDS,NML=SNL3,END=801,ERR=802,IOSTAT=J) -!/NL3 CASE('ANL3') -!/NL3 IF ( NQDEF .GT. 100 ) GOTO 804 -!/NL3 READ (NDS,NML=ANL3,END=801,ERR=802,IOSTAT=J) -!/NL4 CASE('SNL4') -!/NL4 READ (NDS,NML=SNL4,END=801,ERR=802,IOSTAT=J) -!/NL5 CASE('SNL5') -!/NL5 READ (NDS,NML=SNL5,END=801,ERR=802,IOSTAT=J) -!/NLS CASE('SNLS') -!/NLS READ (NDS,NML=SNLS,END=801,ERR=802,IOSTAT=J) -!/ST1 CASE('SDS1') -!/ST1 READ (NDS,NML=SDS1,END=801,ERR=802,IOSTAT=J) -!/ST2 CASE('SDS2') -!/ST2 READ (NDS,NML=SDS2,END=801,ERR=802,IOSTAT=J) -!/ST3 CASE('SDS3') -!/ST3 READ (NDS,NML=SDS3,END=801,ERR=802,IOSTAT=J) -!/ST4 CASE('SDS4') -!/ST4 READ (NDS,NML=SDS4,END=801,ERR=802,IOSTAT=J) -!/ST6 CASE('SDS6') -!/ST6 READ (NDS,NML=SDS6,END=801,ERR=802,IOSTAT=J) -!/ST6 CASE('SWL6') -!/ST6 READ (NDS,NML=SWL6,END=801,ERR=802,IOSTAT=J) -!/BT1 CASE('SBT1') -!/BT1 READ (NDS,NML=SBT1,END=801,ERR=802,IOSTAT=J) -!/BT4 CASE('SBT4') -!/BT4 READ (NDS,NML=SBT4,END=801,ERR=802,IOSTAT=J) -!/IS1 CASE('SIS1') -!/IS1 READ (NDS,NML=SIS1,END=801,ERR=802,IOSTAT=J) -!/IS2 CASE('SIS2') -!/IS2 READ (NDS,NML=SIS2,END=801,ERR=802,IOSTAT=J) -!/DB1 CASE('SDB1') -!/DB1 READ (NDS,NML=SDB1,END=801,ERR=802,IOSTAT=J) -!/UOST CASE('UOST') -!/UOST READ (NDS,NML=UOST,END=801,ERR=802,IOSTAT=J) -!/PR1 CASE('PRO1') -!/PR1 READ (NDS,NML=PRO1,END=801,ERR=802,IOSTAT=J) -!/PR2 CASE('PRO2') -!/PR2 READ (NDS,NML=PRO2,END=801,ERR=802,IOSTAT=J) -!/SMC CASE('PSMC') -!/SMC READ (NDS,NML=PSMC,END=801,ERR=802,IOSTAT=J) -!/PR3 CASE('PRO3') -!/PR3 READ (NDS,NML=PRO3,END=801,ERR=802,IOSTAT=J) -!/RTD CASE('ROTD') -!/RTD READ (NDS,NML=ROTD,END=801,ERR=802,IOSTAT=J) -!/RTD CASE('ROTB') -!/RTD READ (NDS,NML=ROTB,END=801,ERR=802,IOSTAT=J) -!/REF1 CASE('REF1') -!/REF1 READ (NDS,NML=REF1,END=801,ERR=802,IOSTAT=J) -!/IG1 CASE('SIG1') -!/IG1 READ (NDS,NML=SIG1,END=801,ERR=802,IOSTAT=J) -!/IC2 CASE('SIC2') -!/IC2 READ (NDS,NML=SIC2,END=801,ERR=802,IOSTAT=J) -!/IC3 CASE('SIC3') -!/IC3 READ (NDS,NML=SIC3,END=801,ERR=802,IOSTAT=J) -!/IC4 CASE('SIC4 ') -!/IC4 READ (NDS,NML=SIC4,END=801,ERR=802,IOSTAT=J) -!/IC5 CASE('SIC5 ') -!/IC5 READ (NDS,NML=SIC5,END=801,ERR=802,IOSTAT=J) - CASE('UNST') - READ (NDS,NML=UNST,END=801,ERR=802,IOSTAT=J) - CASE('OUTS') - READ (NDS,NML=OUTS,END=801,ERR=802,IOSTAT=J) - CASE('MISC') - READ (NDS,NML=MISC,END=801,ERR=802,IOSTAT=J) - CASE DEFAULT - GOTO 803 - END SELECT - STATUS = '(user def. values) :' - RETURN - END IF - ELSE - EXIT - END IF - ENDIF - END DO - END DO -! - 800 CONTINUE - RETURN -! - 801 CONTINUE - WRITE (NDSE,1001) NAME - CALL EXTCDE(1) - RETURN -! - 802 CONTINUE - WRITE (NDSE,1002) NAME, J - CALL EXTCDE(2) - RETURN -! - 803 CONTINUE - WRITE (NDSE,1003) NAME - CALL EXTCDE(3) - RETURN -! -!/NL2 804 CONTINUE -!/NL2 WRITE (NDSE,1004) NDEPTH -!/NL2 CALL EXTCDE(4) -!/NL2 RETURN -! -!/NL3 804 CONTINUE -!/NL3 WRITE (NDSE,1004) NQDEF -!/NL3 CALL EXTCDE(4) -!/NL3 RETURN -! -! Formats -! - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' PREMATURE END OF FILE IN READING ',A/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' ERROR IN READING ',A,' IOSTAT =',I8/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & - ' NAMELIST NAME ',A,' NOT RECOGNIZED'/) -!/NL2 1004 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & -!/NL2 ' TEMP DEPTH ARRAY TOO SMALL, .LE. ',I8/) -!/NL3 1004 FORMAT (/' *** WAVEWATCH-III ERROR IN READNL : '/ & -!/NL3 ' TEMP QPARMS ARRAY TOO SMALL, .LE. ',I8/) -!/ -!/ End of READNL ----------------------------------------------------- / -!/ - END SUBROUTINE -!/ -!/ End of W3GRID ----------------------------------------------------- / -!/ - END MODULE W3GRIDMD diff --git a/model/ftn/w3initmd.ftn b/model/ftn/w3initmd.ftn deleted file mode 100644 index 93a8e92a7..000000000 --- a/model/ftn/w3initmd.ftn +++ /dev/null @@ -1,4791 +0,0 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3INITMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) -!/ Multiple grid version. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Reset UST initialization. -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) -!/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) -!/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) -!/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) -!/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) -!/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) -!/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) -!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) -!/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) -!/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -!/ Note: Changes in version numbers not logged above. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! CRITOS R.P. Public Critical percentage of resources used -! for output to trigger warning. -! WWVER C*10 Public Model version number. -! SWITCHES C*256 Public switches taken from bin/switch -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3INIT Subr. Public Wave model initialization. -! W3MPII Subr. Public Initialize MPI data transpose. -! W3MPIO Subr. Public Initialize MPI output gathering. -! W3MPIP Subr. Public Initialize MPI point output gathering. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! !/MPIT Enable test output (MPI). -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - REAL, PARAMETER :: CRITOS = 15. - CHARACTER(LEN=10), PARAMETER :: WWVER = '7.13 ' - CHARACTER(LEN=512), PARAMETER :: SWITCHES = & - 'PUT_SW1' // & - 'PUT_SW2' // & - 'PUT_SW3' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & - , FLGRD, & - FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & - IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) - -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 -!/ 13-Sep-2009 : Add coupling option ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ -! 1. Purpose : -! -! Initialize WAVEWATCH III. -! -! 2. Method : -! -! Initialize data structure and wave fields from data files. -! Initialize grid from local and instantaneous data. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! FEXT Char I Extension of data files. -! MDS I.A. I Array with dataset numbers (see below), -! saved as NDS in W3ODATMD. -! 1: General output unit number ("log file"). -! 2: Error output unit number. -! 3: Test output unit number. -! 4: "screen", i.e., direct output location, -! can be the screen or the output file of -! the shell. -! 5: Model definition file unit number. -! 6: Restart file unit number. -! 7: Grid output file unit number. -! 8: Point output file unit number. -! 9: Input boundary data file unit number. -! 10: Output boundary data file unit number -! (first). -! 11: Track information file unit number. -! 12: Track output file unit number. -! MTRACE I.A. I Array with subroutine tracing information. -! 1: Output unit number for trace. -! 2: Maximum number of trace prints. -! ODAT I.A. I Output data, five parameters per output type -! 1-5 Data for OTYPE = 1; gridded fields. -! 1 YYYMMDD for first output. -! 2 HHMMSS for first output. -! 3 Output interval in seconds. -! 4 YYYMMDD for last output. -! 5 HHMMSS for last output. -! 6-10 Id. for OTYPE = 2; point output. -! 11-15 Id. for OTYPE = 3; track point output. -! 16-20 Id. for OTYPE = 4; restart files. -! 21-25 Id. for OTYPE = 5; boundary data. -! 31-35 Id. for OTYPE = 7; coupling data. -! 36-40 Id. for OTYPE = 8; second restart file -! FLGRD L.A. I Flags for gridded output. -! FLGR2 L.A. I Flags for coupling output. -! NPT Int. I Number of output points -! X/YPT R.A. I Coordinates of output points. -! PNAMES C.A. I Output point names. -! IPRT I.A. I Partitioning grid info. -! PRTFRM I.A. I Partitioning format flag. -! MPI_COMM Int. I MPI communicator to be used for model. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to data structure. -! W3SETW Subr. W3WDATMD Point to data structure. -! W3DIMW Subr. Id. Set array sizes in data structure. -! W3SETA Subr. W3ADATMD Point to data structure. -! W3DIMA Subr. Id. Set array sizes in data structure. -! W3SETI Subr. W3IDATMD Point to data structure. -! W3DIMI Subr. Id. Set array sizes in data structure. -! W3SETO Subr. W3ODATMD Point to data structure. -! W3DMO5 Subr. Id. Set array sizes in data structure. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WWDATE Subr. Id. System date. -! WWTIME Subr. Id. System time. -! DSEC21 Func. W3TIMEMD Compute time difference. -! TICK21 Func. Id. Advance the clock. -! STME21 Func. Id. Print the time readable. -! PRTBLK Func. W3ARRYMD Print plot of array. -! W3IOGR Subr. W3IOGRMD Read/write model definition file. -! W3IORS Subr. W3IORSMD Read/write restart file. -! W3IOPP Subr. W3IOPOMD Preprocess point output. -! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK -! Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! On opening of log file only. Other error messages are generated -! by W3IOGR and W3IORS. -! -! 7. Remarks : -! -! - The log file is called 'log.FEXT', where FEXT is passed to -! the routine. -! - The test output file is called 'test.FEXT' in shared memory -! version or testNNN.FEXT in distributed memory version. -! - A water level and ice coverage are transferred with the -! restart file. To assure consistency within the model, the -! water level and ice coverage are re-evaluated at the 0th -! time step in the actual wave model routine. -! - When running regtests in cases where disk is non-local -! (i.e. NFS used), there can be a huge improvment in compute -! time by using /var/tmp/ for log files. -! See commented line at "OPEN (MDS(1),FILE=..." -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1. Set-up of idata structures and I/O. -! a Point to proper data structures. -! b Number of processors and processor number. -! c Open files. -! d Dataset unit numbers -! e Subroutine tracing -! f Initial and test outputs -! 2. Model definition. -! a Read model definition file ( W3IOGR ) -! b Save MAPSTA. -! c MPP preparation -! 3. Model initialization. -! a Read restart file. ( W3IORS ) -! b Compare grid and restart MAPSTA. -! c Initialize with winds if requested (set flag). -! d Initialize calm conditions if requested. -! e Preparations for prop. scheme. -! 4. Set-up output times. -! a Unpack ODAT. -! b Check if output available. -! c Get first time per output and overall. -! d Prepare point output ( W3IOPP ) -! 5. Define wavenumber grid. -! a Calculate depth. -! b Fill wavenumber and group velocity arrays. -! 6. Initialize arrays. -! 7. Write info to log file. -! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/MEMCHECK USE MallocInfo_m -!/ - USE W3GDATMD, ONLY: W3SETG, RSTYPE - USE W3WDATMD, ONLY: W3SETW, W3DIMW - USE W3ADATMD, ONLY: W3SETA, W3DIMA -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS - USE W3IDATMD, ONLY: W3SETI, W3DIMI - USE W3ODATMD, ONLY: W3SETO, W3DMO5 - USE W3IOGOMD, ONLY: W3FLGRDUPDT - USE W3IOGRMD, ONLY: W3IOGR - USE W3IORSMD, ONLY: W3IORS - USE W3IOPOMD, ONLY: W3IOPP - USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME -!/S USE W3SERVMD, ONLY: STRACE - USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 - USE W3ARRYMD, ONLY: PRTBLK -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS, & - MAPSF, FLAGLL, & - ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX, & - FLCK, NK, NTH, NSPEC, SIG, GNAME -!/PDLIB USE W3GDATMD, ONLY : FLCTH - USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA - USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC, & - NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR, & - NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, & - NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST, & - FLOUT, FLOGRD, FLBPO, NOPTS, PTNME, & - PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI, & - OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN, & - IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE,& - FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 -!/NL5 USE W3ODATMD, ONLY: TOSNL5 - USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, & - UA, UD, U10, U10D, AS -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP - USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& - FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & - FLIC4, FLIC5 - USE W3DISPMD, ONLY: WAVNU1, WAVNU3 - USE W3PARALL, ONLY : AC_tot - USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM -!/PDLIB USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA -!/PDLIB use yowNodepool, only: npa -!/PDLIB use yowRankModule, only : rank - USE W3GDATMD, ONLY: GTYPE, UNGTYPE -!/PDLIB USE PDLIB_W3PROFSMD, ONLY : PDLIB_MAPSTA_INIT, VA_SETUP_IOBPD -!/PDLIB USE PDLIB_W3PROFSMD, ONLY : BLOCK_SOLVER_INIT, PDLIB_STYLE_INIT -!/PDLIB use yowDatapool, only: istatus -!/SETUP USE W3WAVSET, ONLY : PREPARATION_FD_SCHEME -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP -!/SETUP USE W3GDATMD, ONLY : DO_CHANGE_WLV - USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP - USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA -!/TIMINGS USE W3PARALL, ONLY: PRINT_MY_TIME -!/PDLIB!/DEBUGCOH USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS -!/PDLIB!/DEBUGINIT USE PDLIB_W3PROFSMD, ONLY: PRINT_WN_STATISTIC -!/UOST USE W3UOSTMD, ONLY: UOST_SETGRID -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MDS(13), MTRACE(2), & - ODAT(40),NPT, IPRT(6),& - MPI_COMM - LOGICAL, INTENT(IN) :: IsMulti - REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) - LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP),& - FLGR2(NOGRP,NGRPP), FLG2(NOGRP),& - PRTFRM - CHARACTER, INTENT(IN) :: FEXT*(*) - CHARACTER(LEN=40), INTENT(IN) :: PNAMES(NPT) - LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) - INTEGER :: NSEALout, NSEALMout -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: IRANK, I, ISTAT - INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC, & - NTTARG, IK, IP, ITH, IX, IY, & - J, J0, TOUT(2), TLST(2), ISEA, IS, & - K, I1, I2, JSEA, NTTMAX -!/DIST INTEGER :: ISTEP, ISP, IW -!/MPI INTEGER :: IERR_MPI, BGROUP, LGROUP -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: NX0, NXN -!/T INTEGER, ALLOCATABLE :: MAPOUT(:,:) -!/MPI INTEGER, ALLOCATABLE :: TMPRNK(:) - INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) -!/T INTEGER, SAVE :: NXS = 49 - REAL :: DTTST, DEPTH, FRACOS - REAL :: FACTOR - REAL :: WLVeff -!/T REAL, ALLOCATABLE :: XOUT(:,:) - LOGICAL :: OPENED - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=10) :: STDATE - INTEGER :: ISPROC -!/DIST CHARACTER(LEN=12) :: FORMAT - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: LFILE, TFILE -!/PDLIB INTEGER :: IScal(1), IPROC -!/ -!/ ------------------------------------------------------------------- / -! -! 1. Set-up of data structures and I/O ----------------------------- / -! 1.a Point to proper data structures. -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 1") - - CALL W3SETO ( IMOD, MDS(2), MDS(3) ) - CALL W3SETG ( IMOD, MDS(2), MDS(3) ) - CALL W3SETW ( IMOD, MDS(2), MDS(3) ) - CALL W3SETA ( IMOD, MDS(2), MDS(3) ) - CALL W3SETI ( IMOD, MDS(2), MDS(3) ) -!/UOST CALL UOST_SETGRID(IMOD) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 2") -!/DEBUGINIT WRITE(740+IAPROC,*) 'Beginning of W3INIT' -!/DEBUGINIT WRITE(740+IAPROC,*) ' FLGR2(10,1)=', FLGR2(10,1) -!/DEBUGINIT WRITE(740+IAPROC,*) ' FLGR2(10,2)=', FLGR2(10,2) -!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("Case 2") - - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! -! 1.b Number of processors and processor number. -! Overwrite some initializations from W3ODATMD. -! -! ******************************************************* -! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** -! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** -! ******************************************************* -! -!/SHRD NTPROC = 1 -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 -!/SHRD IOSTYP = 1 -! -!/MPI MPI_COMM_WAVE = MPI_COMM -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) -!/MPI NAPROC = NTPROC -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 3") - IF ( IOSTYP .LE. 1 ) THEN -! - NAPFLD = MAX(1,NAPROC-1) - NAPPNT = MAX(1,NAPROC-2) - NAPTRK = MAX(1,NAPROC-5) - NAPRST = NAPROC - NAPBPT = MAX(1,NAPROC-3) - NAPPRT = MAX(1,NAPROC-4) -! - ELSE -! - NAPPNT = NAPROC - IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) - NAPFLD = NAPROC - NAPRST = NAPROC - NAPBPT = NAPROC - NAPTRK = NAPROC - NAPPRT = NAPROC -! - IF ( IOSTYP .EQ. 2 ) THEN - NAPROC = MAX(1,NAPROC-1) - ELSE IF ( IOSTYP .EQ. 3 ) THEN -! -! For field or coupling output -! - IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN - NAPFLD = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(13).GT.0 ) THEN - NAPTRK = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(28).GT.0 ) THEN - NAPPRT = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC - IF ( ODAT(18).GT.0 ) NAPRST = NAPROC - IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC - IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & - ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) - END IF - END IF -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 4") - FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) - IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) & - WRITE (NDSE,8002) FRACOS -! -!/MPI IF ( NAPROC .EQ. NTPROC ) THEN -!/MPI MPI_COMM_WCMP = MPI_COMM_WAVE -!/MPI ELSE -!/MPI CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) -!/MPI ALLOCATE ( TMPRNK(NAPROC) ) -!/MPI DO J=1, NAPROC -!/MPI TMPRNK(J) = J - 1 -!/MPI END DO -!/MPI CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & -!/MPI IERR_MPI ) -!/MPI CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & -!/MPI MPI_COMM_WCMP, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) -!/MPI DEALLOCATE ( TMPRNK ) -!/MPI END IF -!!!/PDLIB CALL W3SETG(IMOD, NDSE, NDST) -! - LPDLIB = .FALSE. -!/PDLIB LPDLIB = .TRUE. - IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'IMPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'EXPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - END IF -! -! 1.c Open files without unpacking MDS ,,, -! - IE = LEN_TRIM(FEXT) - LFILE = 'log.' // FEXT(:IE) - IFL = LEN_TRIM(LFILE) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 5") -!/SHRD TFILE = 'test.' // FEXT(:IE) -!/DIST IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) -!/DIST IW = MAX ( 3 , MIN ( 9 , IW ) ) -!/DIST WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & -!/DIST '(A4,I', IW, '.', IW, ',2A)' -!/DIST WRITE (TFILE,FORMAT) 'test', & -!/DIST OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) - IFT = LEN_TRIM(TFILE) - J = LEN_TRIM(FNMPRE) -! - IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & -!/DEBUGINIT WRITE(*,*) '1: w3initmd f=', TRIM(FNMPRE(:J)//LFILE(:IFL)) - OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) -! - IF ( MDS(3).NE.MDS(1) .AND. MDS(3).NE.MDS(4) .AND. TSTOUT ) THEN - INQUIRE (MDS(3),OPENED=OPENED) -!/DEBUGINIT WRITE(*,*) '2: w3initmd f=', TRIM(FNMPRE(:J)//TFILE(:IFT)) - IF ( .NOT. OPENED ) OPEN & - (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) - END IF -! -! 1.d Dataset unit numbers -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 6") - NDS = MDS - NDSO = NDS(1) - NDSE = NDS(2) - NDST = NDS(3) - SCREEN = NDS(4) -! -! 1.e Subroutine tracing -! - CALL ITRACE ( MTRACE(1), MTRACE(2) ) -! -! 1.f Initial and test outputs -! -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 7") - - IF ( IAPROC .EQ. NAPLOG ) THEN - CALL WWDATE ( STDATE ) - CALL WWTIME ( STTIME ) - WRITE (NDSO,900) WWVER, STDATE, STTIME - END IF - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2a' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/S CALL STRACE (IENT, 'W3INIT') -!/T WRITE(NDST,9000) IMOD, FEXT(:IE) -!/T WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & -!/T NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT -!/T WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN -!/T WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) -! -! 2. Model defintition ---------------------------------------------- / -! 2.a Read model defintition file -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 8") - CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) -!/PDLIB IF (GTYPE .ne. UNGTYPE) THEN -!/SETUP CALL PREPARATION_FD_SCHEME(IMOD) -!/PDLIB ELSE -!/PDLIB!/DEBUGINIT WRITE(*,*) 'Before PDLIB_STYLE_INIT, IMOD=', IMOD -!/PDLIB CALL PDLIB_STYLE_INIT(IMOD) -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'After PDLIB_STYLE_INIT' -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) -!/PDLIB!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("After PDLIB_STYLE_INIT") - -!/PDLIB!/DEBUGINIT WRITE(*,*) 'After PDLIB_STYLE_INIT, IMOD=', IMOD -!/PDLIB CALL SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) -!/PDLIB END IF -! Update of output parameter flags based on mod_def parameters (for 3D arrays) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before W3FLGRDUPDT' -!/DEBUGINIT FLUSH(740+IAPROC) - CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 9") -!/TIMINGS CALL PRINT_MY_TIME("After W3FLGRDUPDT") - - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF - IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) -! -! 2.b Save MAPSTA -! - ALLOCATE ( MAPTST(NY,NX) ) - MAPTST = MAPSTA - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2b' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! -! 2.c MPP preparation -! 2.c.1 Set simple counters and variables -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 10") - CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) - NSEAL=NSEALout - NSEALM=NSEALMout - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2c' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEAL=', NSEAL -!/DEBUGINIT WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM -!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSPEC=', NSPEC -!/DEBUGINIT FLUSH(740+IAPROC) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 11") - -!/DIST IF ( NSEA .LT. NAPROC ) GOTO 820 -!/DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -!/DIST IF ( NSPEC .LT. NAPROC ) GOTO 821 -!/DIST END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before PDLIB related allocations' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'After test 1' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB IF (FSNIMP .or. FSTOTALIMP) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before BLOCK_SOLVER_INIT' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB CALL BLOCK_SOLVER_INIT() -!/DEBUGINIT WRITE(740+IAPROC,*) 'After BLOCK_SOLVER_INIT' -!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("After BLOCK_SOLVER_INIT") -!/PDLIB ELSE IF (FSTOTALEXP) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before AC_tot allocation' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB allocate(AC_tot(NSPEC, npa), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After AC_tot allocation' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB ENDIF -!/PDLIB END IF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2d' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 12") -! -! -! 2.c.2 Allocate arrays -! - IF ( IAPROC .LE. NAPROC ) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 1' -!/DEBUGINIT FLUSH(740+IAPROC) - CALL W3DIMW ( IMOD, NDSE, NDST ) - ELSE -!/DEBUGINIT WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 2' -!/DEBUGINIT FLUSH(740+IAPROC) - CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL -!/DEBUGINIT WRITE(740+IAPROC,*) ' maxval(UST)=', maxval(UST) -!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("After W3DIMW") - CALL W3DIMA ( IMOD, NDSE, NDST ) - CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 13") -!/TIMINGS CALL PRINT_MY_TIME("After W3DIMI") - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! 2.c.3 Calculated expected number of prop. calls per processor -! - NTTOT = 0 - DO IK=1, NK - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - NTTOT = NTTOT + NTLOC*NTH - END DO - NTTARG = 1 + (NTTOT-1)/NAPROC - NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) - NTTMAX = NTTARG + 5 -! -! 2.c.4 Initialize IAPPRO -! - IAPPRO = 1 - ALLOCATE ( NT(NSPEC) ) - NT = NTTOT -!/DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -! -!/DIST DO -! -! 2.c.5 First sweep filling IAPPRO -! -!/DIST DO IP=1, NAPROC -!/DIST ISTEP = IP -!/DIST ISP = 0 -!/DIST NT(IP) = 0 -!/DIST DO J=1, 1+NSPEC/NAPROC -!/DIST ISP = ISP + ISTEP -!/DIST IF ( MOD(J,2) .EQ. 1 ) THEN -!/DIST ISTEP = 2*(NAPROC-IP) + 1 -!/DIST ELSE -!/DIST ISTEP = 2*IP - 1 -!/DIST END IF -!/DIST IF ( ISP .LE. NSPEC ) THEN -!/DIST IK = 1 + (ISP-1)/NTH -!/DIST NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) -!/DIST IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN -!/DIST IAPPRO(ISP) = IP -!/DIST NT(IP) = NT(IP) + NTLOC -!/DIST ELSE -!/DIST IAPPRO(ISP) = -1 -!/DIST END IF -!/DIST END IF -!/DIST END DO -!/DIST END DO -! -! 2.c.6 Second sweep filling IAPPRO -! -!/DIST DO IP=1, NAPROC -!/DIST IF ( NT(IP) .LT. NTTARG ) THEN -!/DIST DO ISP=1, NSPEC -!/DIST IF ( IAPPRO(ISP) .EQ. -1 ) THEN -!/DIST IK = 1 + (ISP-1)/NTH -!/DIST NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) -!/DIST IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN -!/DIST IAPPRO(ISP) = IP -!/DIST NT(IP) = NT(IP) + NTLOC -!/DIST END IF -!/DIST END IF -!/DIST END DO -!/DIST END IF -!/DIST END DO -! -! 2.c.7 Check if all served -! -!/DIST IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN -!/DIST EXIT -!/DIST ELSE -!/DIST NTTARG = NTTARG + 1 -!/DIST IF ( NTTARG .GE. NTTMAX ) EXIT -!/DIST IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) -!/DIST END IF -! -!/DIST END DO -!/DIST END IF -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 14") -!/TIMINGS CALL PRINT_MY_TIME("After Case 14") -! 2.c.8 Test output -! -!/T WRITE (NDST,9020) -!/T DO IP=1, NAPROC -!/T WRITE (NDST,9021) IP, NT(IP), NTTARG -!/T END DO -! -!/T WRITE (NDST,9025) -!/T DO IK=NK, 1, -1 -!/T WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) -!/T IF ( NTH .GT. 24 ) WRITE (NDST,9027) & -!/T (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) -!/T END DO -! -! 2.c.9 Test if any spectral points are left out -! -!/DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -!/DIST DO ISP=1, NSPEC -!/DIST IF ( IAPPRO(ISP) .EQ. -1. ) GOTO 829 -!/DIST END DO -!/DIST END IF -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) - DEALLOCATE ( NT ) -! -! 3. Model initialization ------------------------------------------- / -! 3.a Read restart file -! - VA(:,:) = 0. -!/DEBUGMPI CALL TEST_MPI_STATUS("Case 15") -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.0' -!/DEBUGINIT WRITE(740+IAPROC,*) ' 1: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) -!/DEBUGINIT WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call") -!/DEBUGINIT WRITE(740+IAPROC,*) ' After ALL_VA_INTEGRAL_PRINT' -!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("Before W3IORS") - CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) -!/TIMINGS CALL PRINT_MY_TIME("After W3IORS") -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3a' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DEBUGINIT WRITE(740+IAPROC,*) ' 2: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) -!/DEBUGINIT WRITE(740+IAPROC,*) ' 2: NSEAL=', NSEAL -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call") -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.1' -!/DEBUGINIT WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA) -!/DEBUGINIT FLUSH(740+IAPROC) - FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 - IF ( IAPROC .EQ. NAPLOG ) THEN - IF (RSTYPE.EQ.0) THEN - WRITE (NDSO,930) 'cold start (idealized).' - ELSE IF ( RSTYPE .EQ. 1 ) THEN - WRITE (NDSO,930) 'cold start (wind).' - ELSE IF ( RSTYPE .EQ. 4 ) THEN - WRITE (NDSO,930) 'cold start (calm).' - ELSE - WRITE (NDSO,930) 'full restart.' - END IF - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.2' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2") -!/TIMINGS CALL PRINT_MY_TIME("After restart inits") - -! -! 3.b Compare MAPSTA from grid and restart -! - DO IX=1, NX - DO IY=1, NY - IF ( ABS(MAPSTA(IY,IX)).EQ.2 .OR. & - ABS(MAPTST(IY,IX)).EQ.2 ) THEN - MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) - END IF - END DO - END DO - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3b' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.3' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3") -! -! 3.b2 Set MAPSTA associated to PDLIB -! -!/PDLIB IF (GTYPE .eq. UNGTYPE) THEN -!/PDLIB CALL PDLIB_MAPSTA_INIT(IMOD) -!/PDLIB END IF -! -! 3.c Initialization from wind fields -! - FLIWND = RSTYPE.EQ.1 -!/T IF ( FLIWND ) WRITE (NDST,9030) -! -! 3.d Initialization with calm conditions -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 5' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5") - IF ( RSTYPE .EQ. 4 ) THEN - VA(:,:) = 0. -!/T WRITE (NDST,9031) - END IF - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! 3.e Prepare propagation scheme -! - IF ( .NOT. FLCUR ) FLCK = .FALSE. -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT definition of FSREFR and FRFREQ' -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'Before FLCTH=', FLCTH, 'FLCK=', FLCK -!/PDLIB IF (FSTOTALIMP .and. FSREFRACTION) THEN -!/PDLIB FLCTH = .FALSE. -!/PDLIB END IF -!/PDLIB IF (FSTOTALIMP .and. FSFREQSHIFT) THEN -!/PDLIB FLCK = .FALSE. -!/PDLIB END IF -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) ' After FLCTH=', FLCTH, 'FLCK=', FLCK -! -! 4. Set-up output times -------------------------------------------- * -! 4.a Unpack ODAT -! - DO J=1, NOTYPE - J0 = (J-1)*5 - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - END DO -! -! J=8, second stream of restart files - J=8 - J0 = (J-1)*5 - IF(ODAT(J0+1) .NE. 0) THEN - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - FLOUT(8) = .TRUE. - ELSE - FLOUT(8) = .FALSE. - END IF -! -! 4.b Check if output available -! - FLOUT(1) = .FALSE. - FLOGRD = FLGRD - FLOGD = FLGD - DO J=1, NOGRP - DO K=1, NGRPP - FLOUT(1) = FLOUT(1) .OR. FLOGRD(J,K) - END DO - END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6") -! - FLOUT(7) = .FALSE. - FLOGR2 = FLGR2 - FLOG2 = FLG2 - DO J=1, NOGRP - DO K=1, NGRPP - FLOUT(7) = FLOUT(7) .OR. FLOGR2(J,K) - END DO - END DO -! - FLOUT(2) = NPT .GT. 0 -! - FLOUT(3) = .TRUE. -! - FLOUT(4) = .TRUE. -! - FLOUT(5) = FLBPO - IF ( FLBPO ) THEN - CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) - ELSE - DTOUT(5) = 0. - END IF -! - IX0 = MAX ( 1, IPRT(1) ) - IXN = MIN ( NX, IPRT(2) ) - IXS = MAX ( 1, IPRT(3) ) - IY0 = MAX ( 1, IPRT(4) ) - IYN = MIN ( NY, IPRT(5) ) - IYS = MAX ( 1, IPRT(6) ) - FLFORM = PRTFRM - FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN -! -! 4.c Get first time per output and overall. -! - TOFRST(1) = -1 - TOFRST(2) = 0 -! -! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' -! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 7' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7") -!/DEBUGINIT WRITE(*,*) 'Starting the NOTYPE loop, takes time' -!/TIMINGS CALL PRINT_MY_TIME("Before NOTYPE loop") - DO J=1, NOTYPE -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! - IF ( FLOUT(J) ) THEN -!/NL5 IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT - END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! - END IF -! - END DO -! -! J=8, second stream of restart files -! - J=8 -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! - IF ( FLOUT(J) ) THEN - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT - END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! - END IF -! END J=8 -! -! -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DEBUGINIT WRITE(*,*) 'Ending the NOTYPE loop, takes time' -!/TIMINGS CALL PRINT_MY_TIME("After NOTYPE loop") -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 8' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1") -! -! 4.d Preprocessing for point output. -! - IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) -! -!/T WRITE (NDST,9040) -!/T DO J=1, 5 -!/T WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) -!/T END DO -!/T WRITE (NDST,9042) -!/T WRITE (NDST,9043) TOFRST -! -! 5. Define wavenumber grid ----------------------------------------- * -! 5.a Calculate depth -! -!/T ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) -!/T XOUT = -1. -! - MAPTST = MOD(MAPST2/2,2) - MAPST2 = MAPST2 - 2*MAPTST -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'Before INIT_GET_JSEA_ISPROC call' -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'NAPROC=', NAPROC -!/PDLIB!/DEBUGINIT FLUSH(740+IAPROC) - -! -!Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops -!Li may miss the refined cells as they are not 1-1 corresponding to -!Li the (Nx,NY) regular grid. The loop is now modified to run over -!Li full NSEA points. JGLi24Jan2012 -!Li DO IY=1, NY -!Li DO IX=1, NX -!Li ISEA = MAPFS(IY,IX) -!/DEBUGSTP WRITE(740+IAPROC,*) 'Debugging the SETUP / WLV' - DO ISEA=1, NSEA -!/DEBUGSTP WRITE(740+IAPROC,*) 'ISEA/WLV/ZB=', ISEA, WLV(ISEA), ZB(ISEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -!/T MAPOUT(IX,IY) = MAPSTA(IY,IX) -!Li IF ( ISEA .NE. 0) THEN - WLVeff=WLV(ISEA) -!/SETUP IF (DO_CHANGE_WLV) THEN -!/SETUP WLVeff=WLVeff + ZETA_SETUP(ISEA) -!/SETUP END IF - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) -!/T XOUT(IX,IY) = DW(ISEA) - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN - MAPTST(IY,IX) = 1 - MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) -!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA -!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL -!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC -!!/DEBUGINIT FLUSH(740+IAPROC) - END IF -!Li END IF - END DO -!Li END DO - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - WLVeff=WLV(ISEA) -!/SETUP IF (DO_CHANGE_WLV) THEN -!/SETUP WLVeff=WLVeff + ZETA_SETUP(ISEA) -!/SETUP END IF - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN -!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA -!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL -!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC -!!/DEBUGINIT FLUSH(740+IAPROC) - VA(:,JSEA) = 0. - END IF - END DO -!/DEBUGSTP FLUSH(740+IAPROC) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2") - -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.1' -!/DEBUGINIT WRITE(740+IAPROC,*) ' allocated(MAPTST)=', allocated(MAPTST) -!/DEBUGINIT WRITE(740+IAPROC,*) 'NY=', NY, ' NX=', NX -!/DEBUGINIT FLUSH(740+IAPROC) - MAPST2 = MAPST2 + 2*MAPTST -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.2' -!/DEBUGINIT FLUSH(740+IAPROC) -! - DEALLOCATE ( MAPTST ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.3' -!/DEBUGINIT FLUSH(740+IAPROC) - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.4' -!/DEBUGINIT FLUSH(740+IAPROC) -!/T WRITE (NDST,9050) -!/T NX0 = 1 -!/T DO -!/T NXN = MIN ( NX0+NXS-1 , NX ) -!/T CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & -!/T NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') -!/T IF ( NXN .NE. NX ) THEN -!/T NX0 = NX0 + NXS -!/T ELSE -!/T EXIT -!/T END IF -!/T END DO -!/T DEALLOCATE ( MAPOUT, XOUT ) -!/TIMINGS CALL PRINT_MY_TIME("Before section 5.b") -! -! 5.b Fill wavenumber and group velocity arrays. -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.5' -!/DEBUGINIT FLUSH(740+IAPROC) - DO IS=0, NSEA -!/DEBUGINIT WRITE(740+IAPROC,*) 'IS=', IS -!/DEBUGINIT FLUSH(740+IAPROC) - IF (IS.GT.0) THEN - DEPTH = MAX ( DMIN , DW(IS) ) - ELSE - DEPTH = DMIN - END IF -! -!/T1 WRITE (NDST,9051) IS, DEPTH -! - DO IK=0, NK+1 -! -! Calculate wavenumbers and group velocities. - CALL WAVNU1(SIG(IK),DEPTH,WN(IK,IS),CG(IK,IS)) -! -!/T1 WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) -! - END DO - END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.6' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! Commented by FA with version 4.12 -! DO IK=1, NK -! CG(IK,0) = CG(IK,1) -! WN(IK,0) = WN(IK,1) -! END DO -! -! 6. Initialize arrays ---------------------------------------------- / -! Some initialized in W3IORS -! - UA = 0. - UD = 0. - U10 = 0. - U10D = 0. -! - AS = UNDEF -! - AS (0) = 0. - DW (0) = 0. -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.7' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! 7. Write info to log file ----------------------------------------- / -! - IF ( IAPROC .EQ. NAPLOG ) THEN -! - WRITE (NDSO,970) GNAME - IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' - IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' - IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' - IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' - IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' - IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' - IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' - IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' - IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' - IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' - IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' - IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' -! - IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' - IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' - IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' - IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' - IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' - IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' - - IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' - IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' - IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' - IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' - IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' - IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' - IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' - IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' - IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' - IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' - - IF ( FLOUT(1) ) THEN - WRITE (NDSO,975) - DO J=1,NOGRP - DO K=1,NGRPP - IF ( FLOGRD(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(7) ) THEN - WRITE (NDSO,987) - DO J=1,NOGRP - DO K=1,NGRPP - IF ( FLOGR2(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(2) ) THEN - WRITE (NDSO,977) NOPTS - IF ( NOPTS .EQ. 0 ) THEN - WRITE (NDSO,978) - ELSE - IF ( FLAGLL ) THEN - WRITE (NDSO,979) - ELSE - WRITE (NDSO,985) - END IF - DO IP=1, NOPTS - IF ( FLAGLL ) THEN - WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - ELSE - WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - END IF - END DO - END IF - END IF -! - CALL STME21 ( TIME , DTME21 ) - WRITE (NDSO,981) DTME21 - IF (FLLEV) THEN - CALL STME21 ( TLEV , DTME21 ) - WRITE (NDSO,982) DTME21 - END IF - IF (FLICE) THEN - CALL STME21 ( TICE , DTME21 ) - WRITE (NDSO,983) DTME21 - END IF - IF (FLRHOA) THEN - CALL STME21 ( TRHO , DTME21 ) - WRITE (NDSO,990) DTME21 - END IF -! - WRITE (NDSO,984) -! - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.8' -!/DEBUGINIT FLUSH(740+IAPROC) -! - IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. - -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.9' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! Boundary set up for the directions -! -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3") -!!/PDLIB CALL VA_SETUP_IOBPD -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.4") -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.10' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! 8. Final MPI set up ----------------------------------------------- / -! -!/MPI CALL W3MPII ( IMOD ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After W3MPII' -!/DEBUGINIT FLUSH(740+IAPROC) -!/MPI CALL W3MPIO ( IMOD ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After W3MPIO' -!/DEBUGINIT FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After W3MPIP' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/PDLIB!/DEBUGINIT CALL PRINT_WN_STATISTIC("W3INIT leaving") -!/TIMINGS CALL PRINT_MY_TIME("Leaving W3INIT") - RETURN -! -! Escape locations read errors : -! -!/DIST 820 CONTINUE -!/DIST IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC -!/DIST CALL EXTCDE ( 820 ) -! -!/DIST 821 CONTINUE -!/DIST IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC -!/DIST CALL EXTCDE ( 821 ) -! -!/DIST 829 CONTINUE -!/DIST IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) -!/DIST CALL EXTCDE ( 829 ) - -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR - CALL EXTCDE ( 1 ) -! - 889 CONTINUE -! === no process number filtering for test file !!! === - WRITE (NDSE,8001) IERR - CALL EXTCDE ( 2 ) -! -! Formats -! - 900 FORMAT ( ' WAVEWATCH III log file ', & - ' version ',A/ & - ' ==================================', & - '==================================='/ & - 50X,'date : ',A10/50X,'time : ',A8) - 920 FORMAT (/' Model definition file read.') - 930 FORMAT ( ' Restart file read; ',A) -! - 970 FORMAT (/' Grid name : ',A) - 971 FORMAT (/' ',A,' water levels.') - 972 FORMAT ( ' ',A,' curents.') - 973 FORMAT ( ' ',A,' winds.') - 974 FORMAT ( ' ',A,' ice fields.') - 988 FORMAT ( ' ',A,' momentum') - 989 FORMAT ( ' ',A,' air density') - 9972 FORMAT( ' ',A,' mud density.') - 9971 FORMAT( ' ',A,' mud thickness.') - 9970 FORMAT( ' ',A,' mud viscosity.') - 9973 FORMAT( ' ',A,' ice parameter 1') - 9974 FORMAT( ' ',A,' ice parameter 2') - 9975 FORMAT( ' ',A,' ice parameter 3') - 9976 FORMAT( ' ',A,' ice parameter 4') - 9977 FORMAT( ' ',A,' ice parameter 5') - -! - 975 FORMAT (/' Gridded output fields : '/ & - '--------------------------------------------------') - 976 FORMAT ( ' ',A) -! - 977 FORMAT (/' Point output requested for',I6,' points : '/ & - '------------------------------------------') - 978 FORMAT (/' Point output disabled') - 979 FORMAT & - (/' point | longitude | latitude | name '/ & - ' --------|-------------|-------------|----------------') - 985 FORMAT & - (/' point | X | Y | name '/ & - ' --------|-------------|-------------|----------------') - 980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) - 986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) -! - 981 FORMAT (/' Initial time : ',A) - 982 FORMAT ( ' Water level time : ',A) - 983 FORMAT ( ' Ice field time : ',A) - 990 FORMAT ( ' Air density time : ',A) -! - 984 FORMAT (// & - 37X,' | input | output |'/ & - 37X,' |-----------------------|---------------|'/ & - 2X,' step | pass | date time |', & - ' b w l c t r i i1 i5 d | g p t r b f c |'/ & - 2X,'--------|------|---------------------|', & - '-------------------|---------------|'/ & - 2X,'--------+------+---------------------+', & - '-------------------+---------------+') - 987 FORMAT (/' Coupling output fields : '/ & - '--------------------------------------------------') -! - 8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING LOG FILE'/ & - ' IOSTAT =',I5/) - 8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING TEST FILE'/ & - ' IOSTAT =',I5/) - 8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & - ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & - ' OUTPUT :',F6.1,'%'/) -!/DIST 8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & -!/DIST ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & -!/DIST ' NSEA, NAPROC =',2I8/) -!/DIST 8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & -!/DIST ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & -!/DIST ' NSPEC, NAPROC =',2I8/) -!/DIST 8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & -!/DIST ' INCREASING TARGET IN MPP PROPAGATION MAP.'/ & -!/DIST ' IMBALANCE BETWEEN OVERALL AND CFL TIME STEPS'/) -!/DIST 8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & -!/DIST ' SOMETHING WRONG WITH MPP PROPAGATION MAP.'/ & -!/DIST ' CALL HENDRIK !!!'/) -! -!/T 9000 FORMAT ( 'TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') -!/T 9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & -!/T ' ASSIGNED PROCESSORS ',9I4) -!/T 9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) -!/T 9003 FORMAT ( ' LOG FILE : [',A,']'/ & -!/T ' TEST FILE : [',A,']') -! -!/T 9020 FORMAT (' TEST W3INIT : IP, NTTOT, NTTARG :') -!/T 9021 FORMAT ( ' ',3I8) -!/T 9025 FORMAT (' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') -!/T 9026 FORMAT (4X,I4,2X,24I4) -!/T 9027 FORMAT (10X,24I4) -! -!/T 9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & -!/T 'PERFORMED IN W3WAVE') -!/T 9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') -! -!/T 9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') -!/T 9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) -!/T 9042 FORMAT (' TEST W3INIT : FIRST TIME :') -!/T 9043 FORMAT (' ',I9.8,I7.6) -! -!/T 9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') -!/T1 9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & -!/T1 ' IK, T, K, CG :') -!/T1 9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) -!/ -!/ End of W3INIT ----------------------------------------------------- / -!/ - END SUBROUTINE W3INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPII ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-May-2007 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ -! 1. Purpose : -! -! Perform initializations for MPI version of model. -! Data transpose only. -! -! 2. Method : -! -! Some derived data types are defined. All communiction in -! W3GATH, W3SCAT and W3WAVE are initialized so that all -! communication can be performed with single MPI_STARTALL, -! MPI_TESTALL and MPI_WAITALL calls. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT -! Subr. mpif.h MPI derived data type routines. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Basic MPP set up partially performed in W3INIT. -! - Each processor has to be able to send out individual error -! messages in this routine ! -! - No testing on IMOD, since only called by W3INIT. -! - In version 3.09 STORE was split into a send and receive -! buffer, to avoid/reduce possible conflicts between the FORTRAN -! and MPI standards when a gather is posted in a given buffer -! right after a send is completed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI MPI communication calls. -! -! !/S Subroutine tracing, -! !/T Test output, general. -! !/MPIT Test output, MPI communications details. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -!/S USE W3SERVMD, ONLY: STRACE -! - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -!/MPI USE W3GDATMD, ONLY: NSPEC -!/MPI USE W3WDATMD, ONLY: VA -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC, & -!/MPI WW3_SPEC_VEC, IAPPRO, WADATS, & -!/MPI NRQSG1, IRQSG1, NRQSG2, IRQSG2, & -!/MPI GSTORE, SSTORE, MPIBUF, BSTAT, & -!/MPI BISPL, ISPLOC, IBFLOC, NSPLOC - USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NXXXX -!/MPI INTEGER :: IERR_MPI, ISP, IH, ITARG, & -!/MPI IERR1, IERR2, IP -!/S INTEGER, SAVE :: IENT = 0 -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3MPII') -! -! 1. Set up derived data types -------------------------------------- / -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) - NXXXX = NSEALM * NAPROC -! -!/MPI CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, & -!/MPI WW3_FIELD_VEC, IERR_MPI ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -!/MPI CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, & -!/MPI WW3_SPEC_VEC, IERR_MPI ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -!/MPI CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -!/MPI CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/MPIT WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/MPI IF( IAPROC .GT. NAPROC ) THEN -!/MPI NSPLOC = 0 -!/MPI NRQSG1 = 0 -!/MPI NRQSG2 = 0 -!/MPIT WRITE (NDST,9011) -!/MPI RETURN -!/MPI END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! 2. Set up scatters and gathers for W3WAVE ------------------------- / -! ( persistent communication calls ) -! -!/DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -!/MPI NSPLOC = 0 -!/MPI DO ISP=1, NSPEC -!/MPI IF ( IAPPRO(ISP) .EQ. IAPROC ) NSPLOC = NSPLOC + 1 -!/MPI END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/MPI NRQSG1 = NSPEC - NSPLOC -!/MPI ALLOCATE ( WADATS(IMOD)%IRQSG1(MAX(1,NRQSG1),2) ) -!/MPI IRQSG1 => WADATS(IMOD)%IRQSG1 -!/MPI IH = 0 -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/MPIT WRITE (NDST,9021) -!/DEBUGINIT WRITE(*,*) 'Before VA MPI_SEND/RECV_INIT inits' -!/MPI DO ISP=1, NSPEC -!/MPI IF ( IAPPRO(ISP) .NE. IAPROC ) THEN -!/MPI ITARG = IAPPRO(ISP) - 1 -!/MPI IH = IH + 1 -!/MPI CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & -!/MPI ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) -!/MPI CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & -!/MPI ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) -!/MPIT WRITE (NDST,9022) IH, ISP, ITARG+1, & -!/MPIT IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 -!/MPI END IF -!/MPI END DO -!/DEBUGINIT WRITE(*,*) 'After VA MPI_SEND/RECV_INIT inits' -!/MPIT WRITE (NDST,9023) -!/MPIT WRITE (NDST,9020) NRQSG1 -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3MPII, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) -! -! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / -! Also set up buffering of data. -! -!/MPI NRQSG2 = MAX( 1 , NAPROC-1 ) -!/MPI ALLOCATE ( WADATS(IMOD)%IRQSG2(NRQSG2*NSPLOC,2), & -!/MPI WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & -!/MPI WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) -!/MPI NRQSG2 = NAPROC - 1 -! -!/MPI IRQSG2 => WADATS(IMOD)%IRQSG2 -!/MPI GSTORE => WADATS(IMOD)%GSTORE -!/MPI SSTORE => WADATS(IMOD)%SSTORE -! -!/MPI IH = 0 -!/MPI ISPLOC = 0 -!/MPI IBFLOC = 0 -!/MPI WADATS(IMOD)%GSTORE = 0. -!/MPI WADATS(IMOD)%SSTORE = 0. -! -! 3.a Loop over local spectral components -! -!/MPIT WRITE (NDST,9031) -! -!/MPI DO ISP=1, NSPEC -!/MPI IF ( IAPPRO(ISP) .EQ. IAPROC ) THEN -! -!/MPI ISPLOC = ISPLOC + 1 -!/MPI IBFLOC = IBFLOC + 1 -!/MPI IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -! -! 3.b Loop over non-local processes -! -!/MPI DO IP=1, NAPROC -!/MPI IF ( IP .NE. IAPROC ) THEN -! -!/MPI ITARG = IP - 1 -!/MPI IH = IH + 1 -! -!/MPI CALL MPI_RECV_INIT & -!/MPI ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & -!/MPI WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & -!/MPI IRQSG2(IH,1), IERR2 ) -!/MPI CALL MPI_SEND_INIT & -!/MPI ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & -!/MPI WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & -!/MPI IRQSG2(IH,2), IERR2 ) -!/MPIT WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & -!/MPIT IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 -! -! ... End of loops -! -!/MPI END IF -!/MPI END DO -! -!/MPI END IF -!/MPI END DO -! -!/MPIT WRITE (NDST,9033) -!/MPIT WRITE (NDST,9030) NSPLOC, NRQSG2, IH -! -! 4. Initialize buffer management ----------------------------------- / -! -!/MPI BSTAT = 0 -!/MPI BISPL = 0 -!/MPI ISPLOC = 0 -!/MPI IBFLOC = 0 -! -!/DIST END IF - RETURN -! -! Format statements -! -!/MPIT 9010 FORMAT ( ' TEST W3MPII: DATA TYPES DEFINED'/ & -!/MPIT ' WW3_FIELD_VEC : ',I10/ & -!/MPIT ' WW3_SPEC_VEC : ',I10) -!/MPIT 9011 FORMAT ( ' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') -! -!/MPIT 9020 FORMAT ( ' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & -!/MPIT ' NRQSG1 : ',I10) -!/MPIT 9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & -!/MPIT ' +------+------+------+--------------+--------------+'/ & -!/MPIT ' | IH | ISP | TARG | SCATTER | GATHER |'/ & -!/MPIT ' | | | | handle err | handle err |'/ & -!/MPIT ' +------+------+------+--------------+--------------+') -!/MPIT 9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) -!/MPIT 9023 FORMAT ( & -!/MPIT ' +------+------+------+--------------+--------------+'/) -! -!/MPIT 9030 FORMAT ( ' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & -!/MPIT ' NSPLOC : ',I10/ & -!/MPIT ' NRQSG2 : ',I10/ & -!/MPIT ' TOTAL REQ. : ',I10/) -!/MPIT 9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & -!/MPIT ' +------+------+------+------+--------------+', & -!/MPIT '--------------+'/ & -!/MPIT ' | IH | ISP | TARG | IBFR | GATHER |', & -!/MPIT ' SCATTER |'/ & -!/MPIT ' | | | | | handle err |', & -!/MPIT ' handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+', & -!/MPIT '--------------+') -!/MPIT 9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) -!/MPIT 9033 FORMAT ( ' +------+------+------+------+--------------+', & -!/MPIT '--------------+'/) -!/ -!/ End of W3MPII ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPII -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPIO ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-Nov-2015 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 11-Nov-2015 : Added ICEF ( version 5.08 ) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. -! W3SETA Subr. " Set pointers for output arrays -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - The communication as set up in W3MPII uses tags with number -! ranging from 1 through NSPEC. New and unique tags for IO -! related communication are assigned here dynamically. -! - No testing on IMOD, since only called by W3INIT. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -!/MPI USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA -!/MPI USE W3IORSMD, ONLY: OARST - USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE -!/ - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM -!/MPI USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF -!/MPI USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC -!/MPI USE W3ADATMD, ONLY: HS, WLM, T02 - - -!/MPI USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, FP1, THP1, & -!/MPI DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& -!/MPI SXX, SYY, SXY, USERO, PHS, PTP, PLP, & -!/MPI PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC,& -!/MPI TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & -!/MPI TAUOY, USSX, USSY, MSSX, MSSY, MSSD, & -!/MPI MSCX, MSCY, MSCD, PRMS, TPMS, CHARN, & -!/MPI TWS, TAUWNX, TAUWNY, BHD, CGE, & -!/MPI CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & -!/MPI BEDFORMS, PHIBBL, TAUBBL, T01, & -!/MPI P2SMS, US3D, EF, TH1M, STH1M, TH2M, & -!/MPI STH2M, HSIG, PHICE, TAUICE, USSP, & -!/MPI STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, & -!/MPI HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW, & -!/MPI PTM1, PT1, PT2, PEP, WBT, CX, CY, & -!/MPI TAUOCX, TAUOCY, WNMEAN - -!/MPI USE W3GDATMD, ONLY: NK -!/MPI USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & -!/MPI NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& -!/MPI NOGRP, NGRPP, NOGE, FLOGRR -!/MPI USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & -!/MPI FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & -!/MPI NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & -!/MPI RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & -!/MPI IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & -!/MPI ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & -!/MPI IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & -!/MPI FLOGR2 -!/MPI USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/MPI INTEGER :: IK, IFJ -!/MPI INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & -!/MPI IFROM, IX(4), IY(4), IS(4), & -!/MPI IP(4), I, J, JSEA, ITARG, IB, & -!/MPI JSEA0, JSEAN, NSEAB, IBOFF, & -!/MPI ISEA, ISPROC, K, NRQMAX -!/S INTEGER, SAVE :: IENT -!/MPI LOGICAL :: FLGRDALL(NOGRP,NGRPP) -!/MPI LOGICAL :: FLGRDARST(NOGRP,NGRPP) -!/MPIT CHARACTER(LEN=5) :: STRING -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3MPIO') -! -! 1. Set-up for W3IOGO ---------------------------------------------- / -! -!/MPI DO J=1, NOGRP -!/MPI DO K=1, NGRPP -!/MPI FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) -!/MPI FLGRDARST(J,K) = (FLGRDALL(J,K) .OR. FLOGRR(J,K)) -!/MPI END DO -!/MPI END DO -! -!/MPI NRQGO = 0 -!/MPI NRQGO2 = 0 -!/MPI IT0 = NSPEC -!/MPI IROOT = NAPFLD - 1 -! -! -!/MPI IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & -!/MPI (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN -! -! NRQMAX is the maximum number of output fields that require MPI communication, -! aimed to gather field values stored in each processor into one processor in -! charge of model output; for each of such fields, this routine requires one -! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request -! handles in the vectors IRQGO and IRQGO2 respectively. -! NRQMAX is calculated as the sum of all fields described before (Hs) -! + 2 or 3 component fields (CUR) + 3 component fields + extra fields -! For group 1 fields except ICEF, all processors contain information on all -! grid points because they are input fields, and therefore this MPI -! communication is not necessary and they do not contribute to NRQMAX. -! -!/MPI ! Calculation of NRQMAX splitted by output groups and field type -!/MPI ! scalar 2-comp 3-comp -!/MPI NRQMAX = 1 + 0 + 0 + & ! group 1 -!/MPI 18 + 0 + 0 + & ! group 2 -!/MPI 0 + 0 + 0 + & ! group 3 (extra contributions below) -!/MPI 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 -!/MPI 11 + 3 + 1 + & ! group 5 -!/MPI 12 + 7 + 1 + & ! group 6 (extra contributions below) -!/MPI 5 + 4 + 1 + & ! group 7 -!/MPI 5 + 2 + 0 + & ! group 8 -!/MPI 5 + 0 + 0 + & ! group 9 -!/MPI NOEXTR + 0 + 0 ! group 10 -!/MPI -!/MPI ! Extra contributions to NRQMAX from group 3 -!/MPI DO IFJ=1,5 -!/MPI IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & -!/MPI E3DF(3,IFJ) - E3DF(2,IFJ) + 1 -!/MPI END DO -!/MPI ! Extra contributions to NRQMAX from group 6 -!/MPI IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & -!/MPI P2MSF(3) - P2MSF(2) + 1 -!/MPI IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK -!/MPI IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK -! -!/MPI IF ( NRQMAX .GT. 0 ) THEN -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) -!/MPI END IF -!/MPI IRQGO => OUTPTS(IMOD)%OUT1%IRQGO -!/MPI IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 -! -! 1.a Sends of fields -! -!/MPI IH = 0 -! -!/MPI IF ( IAPROC .LE. NAPROC ) THEN -!/MPI IT = IT0 -!/MPIT WRITE (NDST,9010) '(SEND)' -! -!/MPI IF ( FLGRDALL( 1, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN -!/MPI ! TP output shares FP0 internal field with FP -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 8) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 12) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 14) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 15) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 16) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 17) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 19) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 1) ) THEN -!/MPI DO IK=E3DF(2,1),E3DF(3,1) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 2) ) THEN -!/MPI DO IK=E3DF(2,2),E3DF(3,2) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 3) ) THEN -!/MPI DO IK=E3DF(2,3),E3DF(3,3) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 4) ) THEN -!/MPI DO IK=E3DF(2,4),E3DF(3,4) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 5) ) THEN -!/MPI DO IK=E3DF(2,5),E3DF(3,5) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 1) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 2) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 3) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 4) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 5) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 6) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 7) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 8) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 9) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,10) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,11) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,12) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -! -!/MPI IF ( FLGRDALL( 4,13) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,14) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,15) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,16) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,17) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 8) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 8) ) THEN -!/MPI DO IK=1,2*NK -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 9) ) THEN -!/MPI DO K=P2MSF(2),P2MSF(3) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6,11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 12) ) THEN -!/MPI DO IK=1,2*NK -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -! -!/MPI DO I=1, NOEXTR -!/MPI IF ( FLGRDALL(10, I) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & -!/MPI IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -!/MPIT WRITE (STRING,'(A3,I2.2)') '10/', I -!/MPIT WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR -!/MPI END IF -!/MPI END DO -! -!/MPI NRQGO = IH -!/MPIT WRITE (NDST,9012) -!/MPIT WRITE (NDST,9013) NRQGO, NRQMAX -! -!/MPI END IF -! -!/MPI IF ( NRQGO .GT. NRQMAX ) THEN -!/MPI WRITE (NDSE,1010) NRQGO, NRQMAX -!/MPI CALL EXTCDE (10) -!/MPI END IF -! -!/MPI IF ( IAPROC .EQ. NAPFLD ) THEN -! -! 1.b Setting up expanded arrays -! -!/MPI IF (NAPFLD .EQ. NAPRST) THEN -!/MPI CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) -!/MPI ELSE -!/MPI CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) -!/MPI ENDIF -! -! 1.c Receives of fields -! -!/MPI CALL W3XETA ( IMOD, NDSE, NDST ) -!/MPIT WRITE (NDST,9010) '(RECV)' -! -!/MPI IH = 0 -! -!/MPI DO I0=1, NAPROC -!/MPI IT = IT0 -!/MPI IFROM = I0 - 1 -! -!/MPI IF ( FLGRDALL( 1, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN -!/MPI ! TP output shares FP0 internal field with FP -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 8) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 12) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 14) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 15) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 16) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 17) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 2, 19) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 1) ) THEN -!/MPI DO IK=E3DF(2,1),E3DF(3,1) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 2) ) THEN -!/MPI DO IK=E3DF(2,2),E3DF(3,2) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 3) ) THEN -!/MPI DO IK=E3DF(2,3),E3DF(3,3) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 4) ) THEN -!/MPI DO IK=E3DF(2,4),E3DF(3,4) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 3, 5) ) THEN -!/MPI DO IK=E3DF(2,5),E3DF(3,5) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 1) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 2) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 3) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 4) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 5) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 6) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 7) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 8) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4, 9) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,10) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,11) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,12) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,13) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,14) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,15) ) THEN -!/MPI DO K=0, NOSWLL -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,16) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 4,17) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 8) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 5,11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 8) ) THEN -!/MPI DO IK=1,2*NK -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 9) ) THEN -!/MPI DO K=P2MSF(2),P2MSF(3) -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6,11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 12) ) THEN -!/MPI DO IK=1,2*NK -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 6, 13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 7, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & -!/MPI IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 8, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLGRDALL( 9, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -! -!/MPI DO I=1, NOEXTR -!/MPI !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) -!/MPI IF ( FLGRDALL(10, I) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQGO2(IH), IERR ) -!/MPIT WRITE (STRING,'(A3,I2.2)') '10/', I -!/MPIT WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR -!/MPI END IF -!/MPI END DO -! -!/MPI END DO -! -!/MPI NRQGO2 = IH -!/MPIT WRITE (NDST,9012) -!/MPIT WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC -! -!/MPI CALL W3SETA ( IMOD, NDSE, NDST ) -! -!/MPI END IF -! -!/MPI IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN -!/MPI WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC -!/MPI CALL EXTCDE (11) -!/MPI END IF -! -!/MPI END IF -! -! 2. Set-up for W3IORS ---------------------------------------------- / -! 2.a General preparations -! -!/MPI NRQRS = 0 -!/MPI IH = 0 -!/MPI IROOT = NAPRST - 1 -! -!/MPI IF ( FLOUT(4) .OR. FLOUT(8) ) THEN -!/MPI IF (OARST) THEN -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) -!/MPI ELSE -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) -!/MPI ENDIF -!/MPI IRQRS => OUTPTS(IMOD)%OUT4%IRQRS -! -! 2.b Fields at end of file (always) -! -!/MPIT WRITE (NDST,9020) -! -!/MPI IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 1 -!/MPI CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 2 -!/MPI CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 3 -!/MPI CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -! -!/MPI ELSE IF ( IAPROC .EQ. NAPRST ) THEN -!/MPI DO I0=1, NAPROC -!/MPI IFROM = I0 - 1 -!/MPI IF ( I0 .NE. IAPROC ) THEN -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 1 -!/MPI CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 2 -!/MPI CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR -! -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 3 -!/MPI CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -!/MPI END DO -!/MPI END IF -! -!/MPI IF (OARST) THEN -!/MPI IF ( FLOGRR( 1, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 4 -!/MPI CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 5 -!/MPI CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 1, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 6 -!/MPI CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 7 -!/MPI CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 8 -!/MPI CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 9 -!/MPI CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 2, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 10 -!/MPI CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 2, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 11 -!/MPI CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 12 -!/MPI CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 19) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 13 -!/MPI CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 5, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 14 -!/MPI CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 5, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 15 -!/MPI CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 16 -!/MPI CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 5, 11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 17 -!/MPI CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 18 -!/MPI CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 19 -!/MPI CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 20 -!/MPI CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 21 -!/MPI CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 22 -!/MPI CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 23 -!/MPI CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 24 -!/MPI CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 25 -!/MPI CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 26 -!/MPI CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 27 -!/MPI CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6,13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 28 -!/MPI CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 29 -!/MPI CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 30 -!/MPI CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 31 -!/MPI CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 32 -!/MPI CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 33 -!/MPI CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 34 -!/MPI CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -!/MPIT WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( IAPROC .EQ. NAPRST ) THEN -!/MPI IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) -!/MPI CALL W3XETA ( IMOD, NDSE, NDST ) -! -!/MPI DO I0=1, NAPROC -!/MPI IFROM = I0 - 1 -!/MPI IF ( FLOGRR( 1, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 4 -!/MPI CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IT0 + 5 -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 1, 9) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 6 -!/MPI CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 1) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 7 -!/MPI CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 8 -!/MPI CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 9 -!/MPI CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 2, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 10 -!/MPI CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 2, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 11 -!/MPI CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 7) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 12 -!/MPI CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 2, 19) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 13 -!/MPI CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 5, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 14 -!/MPI CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR -!/MPI ENDIF -! -!/MPI IF ( FLOGRR( 5, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 15 -!/MPI CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 16 -!/MPI CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 5,11) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 17 -!/MPI CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 18 -!/MPI CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 19 -!/MPI CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 3) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 20 -!/MPI CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 21 -!/MPI CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 22 -!/MPI CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 23 -!/MPI CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6, 6) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 24 -!/MPI CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 25 -!/MPI CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6,10) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 26 -!/MPI CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 27 -!/MPI CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 6,13) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 28 -!/MPI CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 29 -!/MPI CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 2) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 30 -!/MPI CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 31 -!/MPI CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 4) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 32 -!/MPI CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -! -!/MPI IF ( FLOGRR( 7, 5) ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 33 -!/MPI CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 34 -!/MPI CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& -!/MPI IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -!/MPIT WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR -!/MPI END IF -!/MPI END DO -! -!/MPI CALL W3SETA ( IMOD, NDSE, NDST ) -!/MPI END IF -!/MPI END IF -! -!/MPI NRQRS = IH -!/MPI IF (OARST) THEN -!/MPI IT0 = IT0 + 34 -!/MPI ELSE -!/MPI IT0 = IT0 + 3 -!/MPI ENDIF -! -!/MPIT WRITE (NDST,9022) -!/MPIT WRITE (NDST,9023) NRQRS -! -! 2.c Data server mode -! -!/MPI IF ( IOSTYP .GT. 0 ) THEN -! -!/MPI NBLKRS = 10 -!/MPI RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) -!/MPI IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 -!/MPI NBLKRS = 1 + (NSEALM-1)/RSBLKS -! -!/MPIT WRITE (NDST,9025) RSBLKS, NBLKRS -!/MPI IH = 0 -! -!/MPI IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN -!/MPI IF ( IAPROC .NE. NAPRST ) THEN -! -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) -!/MPI IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS -! -!/MPI DO IB=1, NBLKRS -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 3 + IB -!/MPI JSEA0 = 1 + (IB-1)*RSBLKS -!/MPI JSEAN = MIN ( NSEALM , IB*RSBLKS ) -!/MPI NSEAB = 1 + JSEAN - JSEA0 -!/MPI CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& -!/MPI MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & -!/MPI IRQRSS(IH), IERR ) -!/MPIT WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & -!/MPIT IRQRSS(IH), IERR, NSEAB -!/MPI END DO -! -!/MPI ELSE -! -!/MPI ALLOCATE & -!/MPI ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & -!/MPI OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) -! -!/MPI IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS -!/MPI VAAUX => OUTPTS(IMOD)%OUT4%VAAUX -!/MPI DO IB=1, NBLKRS -!/MPI IT = IT0 + 3 + IB -!/MPI JSEA0 = 1 + (IB-1)*RSBLKS -!/MPI JSEAN = MIN ( NSEALM , IB*RSBLKS ) -!/MPI NSEAB = 1 + JSEAN - JSEA0 -!/MPI DO I0=1, NAPROC -!/MPI IF ( I0 .NE. NAPRST ) THEN -!/MPI IH = IH + 1 -!/MPI IFROM = I0 - 1 -!/MPI IBOFF = MOD(IB-1,2)*RSBLKS -!/MPI CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& -!/MPI NSPEC*NSEAB, MPI_REAL, IFROM, IT, & -!/MPI MPI_COMM_WAVE, IRQRSS(IH), IERR ) -!/MPIT WRITE (NDST,9026) IH, 'R', IB, IFROM, & -!/MPIT IT, IRQRSS(IH), IERR, NSEAB -!/MPI END IF -!/MPI END DO -!/MPI END DO -! -!/MPI END IF -!/MPI END IF -! -!/MPIT WRITE (NDST,9027) -!/MPIT WRITE (NDST,9028) IH -!/MPI IT0 = IT0 + NBLKRS -! -!/MPI END IF -! -!/MPI END IF -! -! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / -! -!/MPI NRQBP = 0 -!/MPI NRQBP2 = 0 -!/MPI IH = 0 -!/MPI IT = IT0 -!/MPI IROOT = NAPBPT - 1 -! -!/MPI IF ( FLOUT(5) ) THEN -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & -!/MPI OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) -!/MPI IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 -!/MPI IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 -! -! 3.a Loops over files and points -! -!/MPIT WRITE (NDST,9030) 'MPI_SEND_INIT' -! -!/MPI DO J=1, NFBPO -!/MPI DO I=NBO2(J-1)+1, NBO2(J) -! -!/MPI IT = IT + 1 -! -! 3.b Residence processor of point -! -!/MPI ISEA = ISBPO(I) -!/MPI CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -! -! 3.c If stored locally, send data -! -!/MPI IF ( IAPROC .EQ. ISPROC ) THEN -!/MPI IH = IH + 1 -!/MPI CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) -!/MPIT WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR -!/MPI END IF -! -!/MPI END DO -!/MPI END DO -! -! ... End of loops 4.a -! -!/MPI NRQBP = IH -! -!/MPIT WRITE (NDST,9032) -!/MPIT WRITE (NDST,9033) NRQBP -! -! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / -! -!/MPI IF ( IAPROC .EQ. NAPBPT ) THEN -! -!/MPI IH = 0 -!/MPI IT = IT0 -! -! 3.e Loops over files and points -! -!/MPIT WRITE (NDST,9030) 'MPI_RECV_INIT' -! -!/MPI DO J=1, NFBPO -!/MPI DO I=NBO2(J-1)+1, NBO2(J) -! -! 3.f Residence processor of point -! -!/MPI ISEA = ISBPO(I) -!/MPI CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -! -! 3.g Receive in correct array -! -!/MPI IH = IH + 1 -!/MPI IT = IT + 1 -!/MPI ITARG = ISPROC - 1 -!/MPI CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& -!/MPI ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) -!/MPIT WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR -! -!/MPI END DO -!/MPI END DO -! -!/MPI NRQBP2 = IH -! -! ... End of loops 4.e -! -!/MPIT WRITE (NDST,9032) -!/MPIT WRITE (NDST,9033) NRQBP2 -! -!/MPI END IF -! -!/MPI IT0 = IT0 + NBO2(NFBPO) -! -!/MPI END IF -! -!/MPIT WRITE (NDST,*) -! -! 4. Set-up for W3IOTR ---------------------------------------------- / -! -!/MPI IH = 0 -!/MPI IROOT = NAPTRK - 1 -! -!/MPI IF ( FLOUT(3) ) THEN -! -! 4.a U* -! -!/MPIT WRITE (NDST,9040) -! -!/MPI IF ( IAPROC .NE. NAPTRK ) THEN -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) -!/MPI IRQTR => OUTPTS(IMOD)%OUT3%IRQTR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 1 -!/MPI CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) -!/MPIT WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 2 -!/MPI CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) -!/MPIT WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR -!/MPI ELSE -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) -!/MPI IRQTR => OUTPTS(IMOD)%OUT3%IRQTR -!/MPI DO I0=1, NAPROC -!/MPI IFROM = I0 - 1 -!/MPI IF ( I0 .NE. IAPROC ) THEN -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 1 -!/MPI CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& -!/MPI IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) -!/MPIT WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR -!/MPI IH = IH + 1 -!/MPI IT = IT0 + 2 -!/MPI CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& -!/MPI IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) -!/MPIT WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR -!/MPI END IF -!/MPI END DO -!/MPI END IF -! -!/MPI NRQTR = IH -!/MPI IT0 = IT0 + 2 -! -!/MPIT WRITE (NDST,9042) -!/MPIT WRITE (NDST,9043) NRQTR -! -!/MPI END IF -! -! 5. Set-up remaining counters -------------------------------------- / -! -!/MPI IT0PRT = IT0 -!/MPI IT0PNT = IT0PRT + 2*NAPROC -!/MPI IT0TRK = IT0PNT + 5000 -! - RETURN -! -! Formats : -! -!/MPI 1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) -!/MPI 1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) -! -!/MPIT 9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & -!/MPIT ' +------+-------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+-------+------+------+--------------+') -!/MPIT 9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9012 FORMAT ( ' +------+-------+------+------+--------------+') -!/MPIT 9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) -!/MPIT 9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) -! -!/MPIT 9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9022 FORMAT ( ' +------+------+------+------+--------------+') -!/MPIT 9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) -! -!/MPIT 9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & -!/MPIT ' BLOCK SIZE / BLOCKS : ',2I6/ & -!/MPIT ' +------+------+------+------+--------------+---------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err | spectra |'/ & -!/MPIT ' +------+------+------+------+--------------+---------+') -!/MPIT 9026 FORMAT ( & -!/MPIT ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') -!/MPIT 9027 FORMAT ( & -!/MPIT ' +------+------+------+------+--------------+---------+') -!/MPIT 9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) -! -!/MPIT 9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & -!/MPIT ' +------+------+---+------+------+--------------+'/ & -!/MPIT ' | IH | IPT | F | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+---+------+------+--------------+') -!/MPIT 9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9032 FORMAT ( & -!/MPIT ' +------+------+---+------+------+--------------+') -!/MPIT 9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) -!/MPIT 9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) -! -!/MPIT 9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9042 FORMAT ( & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) -!/ -!/ End of W3MPIO ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIO -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPIP ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 02-Aug-2006 : Origination. ( version 3.10 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE -!/MPI USE W3SERVMD, ONLY: EXTCDE -!/ -!/MPI USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS -!/MPI USE W3WDATMD, ONLY: VA -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT -!/MPI USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT -!/MPI USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2, & -!/MPI NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI -!/MPI USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/MPI INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA, & -!/MPI IERR, ITARG, IX(4), IY(4), & -!/MPI K, IS(4), IP(4) - INTEGER :: itout -!/S INTEGER, SAVE :: IENT -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3MPIP') -! -!/MPI IF ( O2IRQI ) THEN -!/MPI WRITE (NDSE,1001) -!/MPI CALL EXTCDE (1) -!/MPI END IF -! -! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / -! -!/MPI NRQPO = 0 -!/MPI NRQPO2 = 0 -!/MPI IH = 0 -!/MPI IT0 = IT0PNT -!/MPI IROOT = NAPPNT - 1 -! -!/MPI ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & -!/MPI OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) -!/MPI IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 -!/MPI IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 -!/MPI O2IRQI = .TRUE. -! -! 1.a Loop over output locations -! -!/MPIT WRITE (NDST,9010) 'MPI_SEND_INIT' -! -!/MPI DO I=1, NOPTS -!/MPI DO K=1,4 -!/MPI IX(K)=IPTINT(1,K,I) -!/MPI IY(K)=IPTINT(2,K,I) -!/MPI END DO -! 1.b Loop over corner points -! -!/MPI DO J=1, 4 -! -!/MPI IT = IT0 + (I-1)*4 + J -!/MPI IS(J) = MAPFS (IY(J),IX(J)) -!/MPI IF ( IS(J) .EQ. 0 ) THEN -!/MPI JSEA = 0 -!/MPI IP(J) = NAPPNT -!/MPI ELSE -!/MPI CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) -!/MPI END IF -! -! 1.c Send if point is stored here -! -!/MPI IF ( IP(J) .EQ. IAPROC ) THEN -!/MPI IH = IH + 1 -!/MPI CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR -!/MPI END IF -! -! ... End of loop 1.b -! -!/MPI END DO -! -! ... End of loop 1.a -! -!/MPI END DO -! -!/MPI NRQPO = IH -! -!/MPIT WRITE (NDST,9012) -!/MPIT WRITE (NDST,9013) NRQPO -! -! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / -! -!/MPI IF ( IAPROC .EQ. NAPPNT ) THEN -! -!/MPI IH = 0 -! -! 2.e Loop over output locations -! -!/MPIT WRITE (NDST,9010) 'MPI_RECV_INIT' -! -!/MPI DO I=1, NOPTS -!/MPI DO K=1,4 -!/MPI IX(K)=IPTINT(1,K,I) -!/MPI IY(K)=IPTINT(2,K,I) -!/MPI END DO -! -!/MPI DO J=1, 4 -! -!/MPI IT = IT0 + (I-1)*4 + J -!/MPI IS(J) = MAPFS (IY(J),IX(J)) -!/MPI IF ( IS(J) .EQ. 0 ) THEN -!/MPI JSEA = 0 -!/MPI IP(J) = NAPPNT -!/MPI ELSE -!/MPI CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) -!/MPI END IF -! -! 1.g Receive in correct array -! -!/MPI IH = IH + 1 -!/MPI ITARG = IP(J) - 1 -!/MPI CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & -!/MPI ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) -!/MPIT WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR -! -! ... End of loop 1.f -! -!/MPI END DO -! -! ... End of loop 1.e -! -!/MPI END DO -! -!/MPI NRQPO2 = NOPTS*4 -! -!/MPIT WRITE (NDST,9012) -!/MPIT WRITE (NDST,9014) NRQPO2 -! -!/MPI END IF -! -! -!/MPI IT0 = IT0 + 8*NOPTS -! -! 1.h Base tag number for track output -! -!/MPI IT0TRK = IT0 -! - RETURN -! -! Formats : -! -!/MPI 1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) -! -!/MPIT 9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & -!/MPIT ' +------+------+---+------+------+--------------+'/ & -!/MPIT ' | IH | IPT | J | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+---+------+------+--------------+') -!/MPIT 9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9012 FORMAT ( & -!/MPIT ' +------+------+---+------+------+--------------+') -!/MPIT 9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) -!/MPIT 9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) -!/ -!/ End of W3MPIP ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIP -!/ -!/ End of module W3INITMD -------------------------------------------- / -!/ - END MODULE W3INITMD diff --git a/model/ftn/w3iogrmd.ftn b/model/ftn/w3iogrmd.ftn deleted file mode 100644 index aa9dec7aa..000000000 --- a/model/ftn/w3iogrmd.ftn +++ /dev/null @@ -1,1558 +0,0 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3IOGRMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ For updates see W3IOGR documentation. -!/ -! 1. Purpose : -! -! Reading/writing of model definition file . -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERGRD C*10 Private Model definition file version number. -! IDSTR C*35 Private Model definition file ID string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IOGR Subr. Public Read/write model definition file. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to data structure for spatial gr. -! W3DIMX Subr. Id. Set up arrays for spatial grid. -! W3DIMS Subr. Id. Set array dimensions for a spec. grid. -! W3SETO Subr. W3ODATMD Point to data structure for spatial gr. -! W3DMO5 Subr. Id. Set array dimensions. -! INPTAB Subr. W3SRC2MD Fill interpolation tables for -! dispersion relation. -! DISTAB Subr. W3DISPMD Input coefficient lookup table. -! INSNL1 Subr. W3SNL1MD Initialization of the DIA. -! INSNL2 Subr. W3SNL2MD Initialization of WRT. -! INSNL3 Subr. W3SNL3MD Initialization of GMD. -! INSNL5 Subr. W3SNL5MD Initialization of GKE. -! INSNLS Subr. W3SNLSMD Initialization of nonlinear `smoother'. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - Arrays allocated here on read or ing ww3_grid on write. -! -! 6. Switches : -! -! See subroutine. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERGRD = '2021-08-06' - CHARACTER(LEN=35), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III MODEL DEFINITION FILE' -!/ -!/ Public variables -!/ -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3IOGR ( INXOUT, NDSM, IMOD, FEXT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! F. Ardhuin ! -!/ | FORTRAN 90 | -!/ | Last update : 19-Oct-2020 | -!/ +-----------------------------------+ -!/ -!/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 09-Jan-2001 : Flat grid option. ( version 2.06 ) -!/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) -!/ 27-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 29-Mar-2001 : Sub-grid islands added. ( version 2.10 ) -!/ 11-Jan-2002 : Sub-grid ice added. ( version 2.15 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 27-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) -!/ 26-Nov-2002 : Adding first VDIA and MDIA. ( version 3.01 ) -!/ 01-Aug-2003 : Adding moving grid GSE correction. ( version 3.03 ) -!/ 08-Mar-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 24-Jun-2005 : Add MAPST2 processing. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add W3SLN1 parameters. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 25-Jul-2006 : Reorder for 'GRID' option to read ( version 3.10 ) -!/ spectral data also. -!/ 28-Oct-2006 : Add partitioning pars. ( version 3.10 ) -!/ 26-Mar-2007 : Add partitioning pars. ( version 3.11 ) -!/ 16-Apr-2006 : Add Miche limiter pars. ( version 3.11 ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ 09-Oct-2007 : Adding WAM cycle 4+ Sin and Sds. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Fix ndst arg in call to w3dmo5. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 23-Dec-2009 : Addition of COU namelists ( version 3.14 ) -!/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) -!/ from 3.15 (HLT). ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 19-Dec-2012 : Add NOSWLL to file. ( version 4.11 ) -!/ 01-Jul-2013 : Document UQ / UNO switches in file ( version 4.12 ) -!/ 10-Sep-2013 : Add IG1 parameters ( version 4.12 ) -!/ 16-Sep-2013 : Add Arctic part in SMC grid. ( version 4.12 ) -!/ 11-Nov-2013 : Make SMC and RTD grids compatible. ( version 4.13 ) -!/ 06-Mar-2014 : Writes out a help message on error ( version 4.18 ) -!/ 10-Mar-2014 : Add IC2 parameters ( version 5.01 ) -!/ 29-May-2014 : Add IC3 parameters ( version 5.01 ) -!/ 20-Aug-2016 : Add IOBPA ( version 5.12 ) -!/ 08-Mar-2018 : Add FSWND for SMC grid. ( version 6.02 ) -!/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters -!/ for unstructured grids ( version 6.04 ) -!/ 27-Jul-2018 : Added PTMETH and PTFCUT parameters ( version 6.05 ) -!/ (C. Bunney, UKMO) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) -!/ 19-Oct-2020 : Add AIRCMIN, AIRGB parameters ( version 7.08 ) -!/ 07-07-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.12 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Reading and writing of the model definition file. -! -! 2. Method : -! -! The file is opened within the routine, the name is pre-defined -! and the unit number is given in the parameter list. The model -! definition file is written using UNFORMATTED write statements. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ', 'WRITE' and 'GRID'. -! NDSM Int. I File unit number. -! IMOD Int. I Model number for W3GDAT etc. -! FEXT C*(*) I File extension to be used. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See above. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ...... Prog. N/A All WAVEWATCH III aux programs and -! drivers. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - The model definition file has the pre-defined name -! 'mod_def.FILEXT'. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI calls -! -! !/LNn Select source terms -! !/STn -! !/NLn -! !/BTn -! !/DBn -! !/TRn -! !/BSn -! !/XXn -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - USE W3GDATMD -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE - USE W3ODATMD -!/ST2 USE W3SRC2MD, ONLY: INPTAB -!/ST3 USE W3SRC3MD, ONLY: INSIN3 -!/ST4 USE W3SRC4MD, ONLY: INSIN4, TAUT, TAUHFT, TAUHFT2, & -!/ST4 DELU, DELTAUW, DELUST, & -!/ST4 DELALP, DELTAIL, & -!/ST4 DIKCUMUL -!/NL1 USE W3SNL1MD, ONLY: INSNL1 -!/NL2 USE W3SNL2MD, ONLY: INSNL2 -!/NL3 USE W3SNL3MD, ONLY: INSNL3 -!/NL5 USE W3SNL5MD, ONLY: INSNL5 -!/NLS USE W3SNLSMD, ONLY: INSNLS -!/IS2 USE W3SIS2MD, ONLY: INSIS2 - USE W3TIMEMD, ONLY: CALTYPE - USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE - USE W3DISPMD -!/UOST USE W3UOSTMD, ONLY: UOST_INITGRID -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS -!/MEMCHECK USE MallocInfo_m -! - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSM - INTEGER, INTENT(IN), OPTIONAL :: IMOD - CHARACTER, INTENT(IN) :: INXOUT*(*) - CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: IGRD, IERR, I, J, MTH, MK, ISEA, IX, IY -!/ST4 INTEGER :: IK, ITH, IK2, ITH2 - INTEGER, ALLOCATABLE :: MAPTMP(:,:) -!/MPI INTEGER :: IERR_MPI, IP -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: K - LOGICAL :: WRITE, FLTEST = .FALSE., TESTLL, & - FLSNL2 = .FALSE. - LOGICAL, SAVE :: FLINP = .FALSE. , FLDISP = .FALSE., & - FLIS = .FALSE. - CHARACTER(LEN=10) :: VERTST - CHARACTER(LEN=13) :: TEMPXT - CHARACTER(LEN=30) :: TNAME0, TNAME1, TNAME2, TNAME3, & - TNAME4, TNAME5, TNAME6, & - TNAMEP, TNAMEG, TNAMEF, TNAMEI - CHARACTER(LEN=30) :: FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, & - FNAMEP, FNAMEG, FNAMEF, FNAMEI - CHARACTER(LEN=35) :: IDTST - CHARACTER(LEN=60) :: MESSAGE(5) - LOGICAL :: GLOBAL -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3IOGR') -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 1' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - - MESSAGE =(/ ' MOD DEF FILE WAS GENERATED WITH A DIFFERENT ', & - ' WW3 VERSION OR USING A DIFFERENT SWITCH FILE. ', & - ' MAKE SURE WW3_GRID IS COMPILED WITH SAME SWITCH', & - ' AS WW3_SHEL OR WW3_MULTI, RUN WW3_GRID AGAIN ', & - ' AND THEN TRY AGAIN THE PROGRAM YOU JUST USED. '/) -! - TNAMEF = '------------------------------' - TNAME0 = '------------------------------' - TNAME1 = '------------------------------' - TNAME2 = '------------------------------' - TNAME3 = '------------------------------' - TNAME4 = '------------------------------' - TNAME5 = '------------------------------' - TNAME6 = '------------------------------' - TNAMEP = '------------------------------' - TNAMEG = '------------------------------' - TNAMEI = '------------------------------' -! -!/FLX1 TNAMEF = 'Wu (1980) ' -!/FLX2 TNAMEF = 'Tolman and Chalikov (1996) ' -!/FLX3 TNAMEF = 'T and C(1996) with cap on Cd ' -!/FLX4 TNAMEF = 'Hwang (2011) with cap on Cd ' -!/FLX5 TNAMEF = 'Direct use of stress ' -!/LN0 TNAME0 = 'Not defined ' -!/LN1 TNAME0 = 'Cavaleri and M.-R. (1982) ' -!/ST0 TNAME1 = 'Not defined ' -!/ST1 TNAME1 = 'WAM cycles 1 through 3 ' -!/ST2 TNAME1 = 'Tolman and Chalikov (1996) ' -!/ST3 TNAME1 = 'WAM cycle 4+ ' -!/ST4 TNAME1 = 'Ardhuin et al. (2009+) ' -!/ST6 TNAME1 = 'BYDB input and dissipation ' -!/NL0 TNAME2 = 'Not defined ' -!/NL1 TNAME2 = 'Discrete Interaction Approx. ' -!/NL2 TNAME2 = 'Exact nonlinear interactions ' -!/NL3 TNAME2 = 'Generalized Multiple DIA ' -!/NL4 TNAME2 = 'Two Scaled Approximation ' -!/NL5 TNAME2 = 'Generalized Kinetic Equation ' -!/BT0 TNAME3 = 'Not defined ' -!/BT1 TNAME3 = 'JONSWAP ' -!/BT4 TNAME3 = 'SHOWEX ' -!/BT8 TNAME3 = 'Muddy Bed (D & L) ' -!/IC1 TNAMEI = 'Ice sink term (uniform k_i) ' -!/IC2 TNAMEI = 'Ice sink term (Lui et al) ' -!/IC3 TNAMEI = 'Ice sink term (Wang and Shen) ' -!/IC4 TNAMEI = 'Ice sink term (empirical) ' -!/IC5 TNAMEI = 'Ice sink term (eff. medium) ' -!/DB0 TNAME4 = 'Not defined ' -!/DB1 TNAME4 = 'Battjes and Janssen (1978) ' -!/TR0 TNAME5 = 'Not defined ' -!/BS0 TNAME6 = 'Not defined ' -!/PR0 TNAMEP = 'No propagation ' -!/PR1 TNAMEP = 'First order upstream ' -!/UQ TNAMEP = '3rd order UQ scheme ' -!/UNO TNAMEP = '2nd order UNO scheme ' -!/PR0 TNAMEG = 'No GSE aleviation ' -!/PR1 TNAMEG = 'No GSE aleviation (1up prop) ' -!/PR2 TNAMEG = 'Diffusion operator ' -!/PR3 TNAMEG = 'Averaging operator ' -! - FNAMEF = TNAMEF - FNAME0 = TNAME0 - FNAME1 = TNAME1 - FNAME2 = TNAME2 - FNAME3 = TNAME3 - FNAME4 = TNAME4 - FNAME5 = TNAME5 - FNAME6 = TNAME6 - FNAMEP = TNAMEP - FNAMEG = TNAMEG - FNAMEI = TNAMEI -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 2' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T FLTEST = .TRUE. -!/NL2 FLSNL2 = .TRUE. -! -! test input parameters ---------------------------------------------- * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - IF ( PRESENT(FEXT) ) THEN - TEMPXT = FEXT - ELSE - TEMPXT = 'ww3' - END IF -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' & - .AND. INXOUT.NE.'GRID') THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 3' -!/DEBUGIOGR FLUSH(740+IAPROC) - WRITE = INXOUT .EQ. 'WRITE' -! -!/T WRITE (NDST,9000) INXOUT, WRITE, NDSM, IGRD, TEMPXT -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - FILEXT = TEMPXT -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 4' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! open file ---------------------------------------------------------- * -! - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! -!AR: ADD DEBUGFLAG WRITE(*,*) 'FILE=', FNMPRE(:J)//'mod_def.'//FILEXT(:I) - IF ( WRITE ) THEN - OPEN (NDSM,FILE=FNMPRE(:J)//'mod_def.'//FILEXT(:I), & - FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSM,FILE=FNMPRE(:J)//'mod_def.'//FILEXT(:I), & - FORM='UNFORMATTED',STATUS='OLD',ERR=800,IOSTAT=IERR) - ENDIF -! - REWIND ( NDSM ) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 5, WRITE=', WRITE -!/DEBUGIOGR FLUSH(740+IAPROC) -! -! Dimensions and test information -------------------------------------- -! - IF ( WRITE ) THEN - WRITE (NDSM) & - IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & - NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI -! -!/SMC WRITE (NDSM) NCel, NUFc, NVFc, NRLv, MRFct -!/SMC WRITE (NDSM) NGLO, NARC, NBGL, NBAC, NBSMC -! - WRITE (NDSM) & - (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) -!/T WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & -!/T NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & -!/T FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & -!/T FNAMEF, FNAMEI -!/T WRITE (NDST,9002) (NBO(I),I=0,NFBPO) -!/T WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IDTST, VERTST, NX, NY, NSEA, MTH, MK, & - NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & - FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & - FNAMEF, FNAMEI -! -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC NCel, NUFc, NVFc, NRLv, MRFct -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC NGLO, NARC, NBGL, NBAC, NBSMC -! - NK = MK - NTH = MTH - NK2 = NK + 2 - NSPEC = NK * NTH -!/T WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & -!/T NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & -!/T FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & -!/T FNAMEF, FNAMEI -! - IF ( IDTST .NE. IDSTR ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,901) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VERGRD ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,902) VERTST, VERGRD - CALL EXTCDE ( 11 ) - END IF - IF ( NFBPO .GT. 9 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,904) NFBPO, 9 - CALL EXTCDE ( 13 ) - END IF - IF ( FNAME0 .NE. TNAME0 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 0, FILEXT(:I), FNAME0, TNAME0, & - MESSAGE - CALL EXTCDE ( 14 ) - END IF - IF ( FNAME1 .NE. TNAME1 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 1, FILEXT(:I), FNAME1, TNAME1, & - MESSAGE - CALL EXTCDE ( 15 ) - END IF - IF ( FNAME2 .NE. TNAME2 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 2, FILEXT(:I), FNAME2, TNAME2, & - MESSAGE - CALL EXTCDE ( 16 ) - END IF - IF ( FNAME3 .NE. TNAME3 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 3, FILEXT(:I), FNAME3, TNAME3, & - MESSAGE - CALL EXTCDE ( 17 ) - END IF - IF ( FNAMEI .NE. TNAMEI ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 3, FILEXT(:I), FNAMEI, TNAMEI, & - MESSAGE - CALL EXTCDE ( 17 ) - END IF - IF ( FNAME4 .NE. TNAME4 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 4, FILEXT(:I), FNAME4, TNAME4, & - MESSAGE - CALL EXTCDE ( 18 ) - END IF - IF ( FNAME5 .NE. TNAME5 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 5, FILEXT(:I), FNAME5, TNAME5, & - MESSAGE - CALL EXTCDE ( 19 ) - END IF - IF ( FNAME6 .NE. TNAME6 ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) 6, FILEXT(:I), FNAME6, TNAME6, & - MESSAGE - CALL EXTCDE ( 20 ) - END IF - IF ( FNAMEP .NE. TNAMEP ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) FNAMEP, TNAMEP - CALL EXTCDE ( 22 ) - END IF - IF ( FNAMEG .NE. TNAMEG ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,907) FNAMEG, TNAMEG, MESSAGE - CALL EXTCDE ( 22 ) - END IF - IF ( FNAMEF .NE. TNAMEF ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,908) FILEXT(:I), FNAMEF, TNAMEF, MESSAGE - CALL EXTCDE ( 24 ) - END IF -! - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) -!/T WRITE (NDST,9002) (NBO(I),I=0,NFBPO) -!/T WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) -! - ENDIF -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 6' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -! Parameters in modules --------------------------------------------- * -! Module W3GDAT GRID -! - ALLOCATE ( MAPTMP(NY,NX) ) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7' -!/DEBUGIOGR FLUSH(740+IAPROC) -! - IF ( WRITE ) THEN - MAPTMP = MAPSTA + 8*MAPST2 - WRITE (NDSM) & - GTYPE, FLAGLL, ICLOSE -! -! Writes different kind of information depending on grid type -! - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - WRITE (NDSM) & - SX, SY, X0, Y0 - CASE ( CLGTYPE ) - WRITE (NDSM) & - XGRD, YGRD - CASE (UNGTYPE) - WRITE (NDSM) & - FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & - FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & - DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & - NTRI,COUNTOT, COUNTRI, NNZ, & - B_JGS_TERMINATE_MAXITER, & - B_JGS_TERMINATE_DIFFERENCE, & - B_JGS_TERMINATE_NORM, & - B_JGS_LIMITER, & - B_JGS_BLOCK_GAUSS_SEIDEL, & - B_JGS_USE_JACOBI, & - B_JGS_MAXITER, & - B_JGS_PMIN, & - B_JGS_DIFF_THR, & - B_JGS_NORM_THR, & - B_JGS_NLEVEL, & - B_JGS_SOURCE_NONLINEAR - !Init COUNTCON to zero, it needs to be set somewhere or - !removed - COUNTCON=0 - WRITE (NDSM) & - X0, Y0, SX, SY, DXYMAX, XYB, TRIGP, TRIA, & - LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & - DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & - POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI - END SELECT !GTYPE -! - WRITE (NDSM) & - ZB, MAPTMP, MAPFS, MAPSF, TRFLAG -! -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC WRITE (NDSM) NLvCel, NLvUFc, NLvVFc -!/SMC WRITE (NDSM) IJKCel, IJKUFc, IJKVFc, ISMCBP -!/SMC WRITE (NDSM) ICLBAC -!/SMC WRITE (NDSM) ANGARC -!/SMC WRITE (NDSM) CTRNX, CTRNY, CLATF -!/SMC IF ( FLTEST ) THEN -!/SMC WRITE (NDSE,"(' NRLv, MRFct and NBSMC values are',3I9)") NRLv, MRFct, NBSMC -!/SMC WRITE (NDSE,"(' IJKCel, IJKUFc, IJKVFc Write for',3I9)") NCel, NUFc, NVFc -!/SMC WRITE (NDSE,"(' CTRNXY transparency write for 2x', I9)") NCel -!/SMC ENDIF -!/SMC ENDIF -! - IF ( TRFLAG .NE. 0 ) WRITE (NDSM) TRNX, TRNY - WRITE (NDSM) & - DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & - FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, FLCTH, & - FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, CTHG0S, & - STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, IICEDISP, & - ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, IICEHDISP,& - IICEDDISP, IICEFDISP, BTBETA, & - AAIRCMIN, AAIRGB - - WRITE(NDSM)GRIDSHIFT -!/SEC1 WRITE (NDSM) NITERSEC1 -!/RTD !! Add rotated Polat/lon and AnglD to mod_def JGLi12Jun2012 -!/RTD WRITE (NDSM) PoLat, PoLon, AnglD, FLAGUNR -!/RTD -!! WRITE(NDSM) & -!! COUG_2D, COUG_RAD3D, COUG_US3D - ELSE -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.1' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - GTYPE, FLAGLL, ICLOSE -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.2' -!/DEBUGIOGR FLUSH(740+IAPROC) -!!Li IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST ) - IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST & -!/SMC , NCel, NUFc, NVFc, NRLv, NBSMC & -!/SMC , NARC, NBAC, NSPEC & - ) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.3' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -! Reads different kind of information depending on grid type -! - SELECT CASE ( GTYPE ) -!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - SX, SY, X0, Y0 - DO IX=1,NX - XGRD(:,IX) = X0 + REAL(IX-1)*SX - END DO - DO IY=1,NY - YGRD(IY,:) = Y0 + REAL(IY-1)*SY - END DO - CASE ( CLGTYPE ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - XGRD, YGRD - !Set SX, SY, X0, Y0 to large values if curvilinear grid - X0 = HUGE(X0); Y0 = HUGE(Y0) - SX = HUGE(SX); SY = HUGE(SY) - CASE (UNGTYPE) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.4' -!/DEBUGIOGR FLUSH(740+IAPROC) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & - FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & - DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & - NTRI,COUNTOT, COUNTRI, NNZ, & - B_JGS_TERMINATE_MAXITER, & - B_JGS_TERMINATE_DIFFERENCE, & - B_JGS_TERMINATE_NORM, & - B_JGS_LIMITER, & - B_JGS_BLOCK_GAUSS_SEIDEL, & - B_JGS_USE_JACOBI, & - B_JGS_MAXITER, & - B_JGS_PMIN, & - B_JGS_DIFF_THR, & - B_JGS_NORM_THR, & - B_JGS_NLEVEL, & - B_JGS_SOURCE_NONLINEAR -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.5, GUGINIT=', GUGINIT -!/DEBUGIOGR FLUSH(740+IAPROC) - IF (.NOT. GUGINIT) THEN -!/DEBUGIOGR WRITE(740+IAPROC,*) 'Before call to W3DIMUG from W3IOGR' -!/DEBUGIOGR FLUSH(740+IAPROC) - CALL W3DIMUG ( IGRD, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) - END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.6' -!/DEBUGIOGR FLUSH(740+IAPROC) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - X0, Y0, SX, SY, DXYMAX, XYB, TRIGP, TRIA, & - LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & - DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & - POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI - -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.6.4' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - XGRD(1,:)=XYB(:,1) - YGRD(1,:)=XYB(:,2) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.7' -!/DEBUGIOGR FLUSH(740+IAPROC) - END SELECT !GTYPE -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.8' -!/DEBUGIOGR FLUSH(740+IAPROC) - IF (GTYPE.NE.UNGTYPE) CALL W3GNTX ( IGRD, NDSE, NDST ) -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.9' -!/DEBUGIOGR FLUSH(740+IAPROC) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - ZB, MAPTMP, MAPFS, MAPSF, TRFLAG -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.10' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC NLvCel, NLvUFc, NLvVFc -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC IJKCel, IJKUFc, IJKVFc, ISMCBP -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC ICLBAC -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC ANGARC -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC CTRNX, CTRNY, CLATF -!/SMC ENDIF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.11' -!/DEBUGIOGR FLUSH(740+IAPROC) - MAPSTA = MOD(MAPTMP+2,8) - 2 - MAPST2 = (MAPTMP-MAPSTA) / 8 - MAPSF(:,3) = MAPSF(:,2) + (MAPSF(:,1)-1)*NY -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.12' -!/DEBUGIOGR FLUSH(740+IAPROC) - IF ( TRFLAG .NE. 0 ) THEN - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) TRNX, TRNY - END IF -!/UOST ! UOST (Unresolved Obstacles Source Term) is enabled. -!/UOST ! setting TRNX, TRNY to null values -!/UOST TRNX = 1 -!/UOST TRNY = 1 - -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.13' -!/DEBUGIOGR FLUSH(740+IAPROC) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & - FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, & - FLCTH, FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, & - CTHG0S, STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, & - IICEDISP, ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, & - IICEDDISP, IICEHDISP, IICEFDISP, BTBETA, & - AAIRCMIN, AAIRGB -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.14' -!/DEBUGIOGR FLUSH(740+IAPROC) - - READ(NDSM,END=801,ERR=802,IOSTAT=IERR)GRIDSHIFT -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.15' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/SEC1 READ (NDSM) NITERSEC1 -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.16' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/RTD !! Read rotated Polat/lon and AnglD from mod_def JGLi12Jun2012 -!/RTD READ (NDSM) PoLat, PoLon, AnglD, FLAGUNR -!/RTD -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 7.17' -!/DEBUGIOGR FLUSH(740+IAPROC) - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 8' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9010) GTYPE, FLAGLL, ICLOSE, SX, SY, X0, Y0, TRFLAG -!/T WRITE (NDST,9011) 'MAPSTA' -!/T DO IY=MIN(NY,20), 1, -1 -!/T WRITE (NDST,9012) (MAPSTA(IY,IX),IX=1,MIN(NX,30)) -!/T END DO -!/T WRITE (NDST,9011) 'MAPST2' -!/T DO IY=MIN(NY,20), 1, -1 -!/T WRITE (NDST,9012) (MAPST2(IY,IX),IX=1,MIN(NX,30)) -!/T END DO -!/T WRITE (NDST,9011) 'MAPFS' -!/T DO IY=MIN(NY,20), 1, -1 -!/T WRITE (NDST,9013) (MAPFS(IY,IX),IX=1,MIN(NX,12)) -!/T END DO -!/T IF ( TRFLAG .NE. 0 ) THEN -!/T WRITE (NDST,9011) 'TRNX' -!/T DO IY=MIN(NY,20), 1, -1 -!/T WRITE (NDST,9014) (TRNX(IY,IX),IX=1,MIN(NX,12)) -!/T END DO -!/T WRITE (NDST,9011) 'TRNY' -!/T DO IY=MIN(NY,20), 1, -1 -!/T WRITE (NDST,9014) (TRNY(IY,IX),IX=1,MIN(NX,12)) -!/T END DO -!/T END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 9' -!/DEBUGIOGR FLUSH(740+IAPROC) - DEALLOCATE ( MAPTMP ) -! -!/T WRITE (NDST,9015) DTCFL, DTCFLI, DTMAX, DTMIN, & -!/T DMIN, CTMAX, FICE0, FICEN, FICEL, PFMOVE, & -!/T STEXU, STEYU, STEDU -!/T WRITE (NDST,9016) FLDRY, FLCX, FLCY, FLCTH, FLCK, & -!/T FLSOU, FLBPI, FLBPO -!/T WRITE (NDST,9017) (CLATS(ISEA),ISEA=1,1), & -!/T (CLATIS(ISEA),ISEA=1,1), (CTHG0S(IY),ISEA=1,1) -! -! Spectral parameters ------------------------------------------------ * -! Module W3GDATMD SGRD -! - IF ( WRITE ) THEN - WRITE (NDSM) & - MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & - XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & - FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE - ELSE - IF (.NOT.SINIT) CALL W3DIMS ( IGRD, NK, NTH, NDSE, NDST ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & - XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & - FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE - END IF - -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 10' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9030) (MAPWN(I),I=1,8), (MAPTH(I),I=1,8), DTH*RADE, & -!/T (TH(I)*RADE,I=1,4), (ESIN(I),I=1,4), (ECOS(I),I=1,4), & -!/T XFR, SIG(1)*TPIINV, SIG(NK)*TPIINV, FTE, FTF, FTWN, FTTR, & -!/T FTWL, FACTI1, FACTI2, FACHFA, FACHFE -! -! -! Output flags for 3D parameters ------------------------------------- * -! Module W3GDATMD - IF ( WRITE ) THEN - WRITE (NDSM) & - E3DF, P2MSF, US3DF,USSPF, USSP_WN - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - E3DF, P2MSF, US3DF,USSPF, USSP_WN - END IF - - IF ( INXOUT .EQ. 'GRID' ) THEN - CLOSE (NDSM) - RETURN - END IF -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 11' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -! Parameters for output boundary points ------------------------------ * -! Module W3ODATMD OUT5 -! - IF ( WRITE ) THEN - WRITE (NDSM) & - XBPO, YBPO, RDBPO, IPBPO, ISBPO - ELSE - CALL W3DMO5 ( IGRD, NDSE, NDST, 2 ) - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - XBPO, YBPO, RDBPO, IPBPO, ISBPO - END IF -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 12' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9020) -!/T DO I=1, NFBPO -!/T WRITE (NDST,9021) I -!/T DO J=NBO(I-1)+1,NBO(I) -!/T WRITE (NDST,9022) J-NBO(I-1), (IPBPO(J,K),K=1,4), & -!/T (RDBPO(J,K),K=1,4) -!/T END DO -!/T WRITE (NDST,9023) (ISBPO(J),J=NBO2(I-1)+1,NBO2(I)) -!/T END DO -! -! Parameters for spectral partitioning ------------------------------ * -! Module W3ODATMD OUT6 -! - IF ( WRITE ) THEN - WRITE (NDSM) & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & - PTMETH, PTFCUT - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & - PTMETH, PTFCUT - END IF -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 13' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9025) IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL -! -! Numerical parameters ----------------------------------------------- * -! Module W3GDATMD NPAR -! - IF ( WRITE ) THEN - WRITE (NDSM) & - FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & - FFACBERG, DELAB, FWTABLE -!/RWND WRITE (NDSM) & -!/RWND RWINDC -!/WCOR WRITE (NDSM) & -!/WCOR WWCOR -!/REF1 WRITE (NDSM) & -!/REF1 RREF, REFPARS, REFLC, REFLD -!/IG1 WRITE (NDSM) & -!/IG1 IGPARS(1:12) -!/IC2 WRITE (NDSM) & -!/IC2 IC2PARS(1:8) -!/IC3 WRITE (NDSM) & -!/IC3 IC3PARS -!/IC4 WRITE (NDSM) & -!/IC4 IC4PARS,IC4_KI,IC4_FC -!/IC5 WRITE (NDSM) & -!/IC5 IC5PARS - ELSE - READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & - FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & - FFACBERG, DELAB, FWTABLE -!/RWND READ (NDSM) & -!/RWND RWINDC -!/WCOR READ (NDSM) & -!/WCOR WWCOR -!/REF1 READ (NDSM) & -!/REF1 RREF, REFPARS, REFLC, REFLD -!/IG1 READ (NDSM) & -!/IG1 IGPARS(1:12) -!/IC2 READ (NDSM) & -!/IC2 IC2PARS(1:8) -!/IC3 READ (NDSM) & -!/IC3 IC3PARS -!/IC4 READ (NDSM) & -!/IC4 IC4PARS,IC4_KI,IC4_FC -!/IC5 READ (NDSM) & -!/IC5 IC5PARS - END IF -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 14' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9040) FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, & -!/T FACSD, FHMAX -! -! Source term parameters --------------------------------------------- * -! Module W3GDATMD SFLP -! Module W3GDATMD SLNP -! Module W3GDATMD SRCP -! Module W3GDATMD SNLP -! Module W3GDATMD SBTP -! -!/FLX2 IF ( WRITE ) THEN -!/FLX2 WRITE (NDSM) NITTIN, CINXSI -!/FLX2 ELSE -!/FLX2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) NITTIN, CINXSI -!/FLX2 END IF -! -!/FLX2 IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CINXSI -! -!/FLX3 IF ( WRITE ) THEN -!/FLX3 WRITE (NDSM) & -!/FLX3 NITTIN, CINXSI, CD_MAX, CAP_ID -!/FLX3 ELSE -!/FLX3 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/FLX3 NITTIN, CINXSI, CD_MAX, CAP_ID -!/FLX3 END IF -! -!/FLX3 IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CAP_ID, CINXSI, CD_MAX -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 15' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/FLX4 IF ( WRITE ) THEN -!/FLX4 WRITE (NDSM) FLX4A0 -!/FLX4 ELSE -!/FLX4 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) FLX4A0 -!/FLX4 END IF -! -! -!/LN1 IF ( WRITE ) THEN -!/LN1 WRITE (NDSM) SLNC1, FSPM, FSHF -!/LN1 ELSE -!/LN1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SLNC1, FSPM, FSHF -!/LN1 END IF -! -!/LN1 IF ( FLTEST ) WRITE (NDST,9049) SLNC1, FSPM, FSHF -! -!/ST1 IF ( WRITE ) THEN -!/ST1 WRITE (NDSM) SINC1, SDSC1 -!/ST1 ELSE -!/ST1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SINC1, SDSC1 -!/ST1 END IF -! -!/ST1 IF ( FLTEST ) WRITE (NDST,9050) SINC1, SDSC1 -! -!/ST2 IF ( WRITE ) THEN -!/ST2 WRITE (NDSM) & -!/ST2 ZWIND, FSWELL, & -!/ST2 SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & -!/ST2 CDSA0, CDSA1, CDSA2, SDSALN, & -!/ST2 CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 -!/ST2 ELSE -!/ST2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/ST2 ZWIND, FSWELL, & -!/ST2 SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & -!/ST2 CDSA0, CDSA1, CDSA2, SDSALN, & -!/ST2 CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 -!/ST2 IF ( .NOT. FLINP ) CALL INPTAB -!/ST2 FLINP = .TRUE. -!/ST2 END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 16' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/ST2 IF ( FLTEST ) WRITE (NDST,9050) & -!/ST2 ZWIND, FSWELL, CDSA0, CDSA1, CDSA2, & -!/ST2 SDSALN, CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, & -!/ST2 XF2, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS -! -!/ST3 IF ( WRITE ) THEN -!/ST3 WRITE (NDSM) & -!/ST3 ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & -!/ST3 SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& -!/ST3 SSTXFTFTAIL, SSTXFTWN, & -!/ST3 DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & -!/ST3 FFXPM, FFXFM -!/ST3 ELSE -!/ST3 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/ST3 ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & -!/ST3 SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& -!/ST3 SSTXFTFTAIL, SSTXFTWN, & -!/ST3 DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & -!/ST3 FFXPM, FFXFM -!/ST3 IF ( .NOT. FLINP ) THEN -!/ST3 CALL INSIN3 -!/ST3 FLINP = .TRUE. -!/ST3 END IF -!/ST3 END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 17' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/ST4 IF ( WRITE ) THEN -!/ST4 CALL INSIN4(.TRUE.) -!/ST4 WRITE (NDSM) & -!/ST4 ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & -!/ST4 TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & -!/ST4 ZZ0RAT, SSDSC, & -!/ST4 SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & -!/ST4 SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& -!/ST4 SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & -!/ST4 SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & -!/ST4 SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & -!/ST4 SSDSHCK, DELUST, DELTAIL, DELTAUW, & -!/ST4 DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & -!/ST4 IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & -!/ST4 DIKCUMUL, CUMULW -!/ST4 ELSE -!/ST4 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/ST4 ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & -!/ST4 TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & -!/ST4 ZZ0RAT, SSDSC, & -!/ST4 SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & -!/ST4 SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& -!/ST4 SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & -!/ST4 SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & -!/ST4 SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & -!/ST4 SSDSHCK, DELUST, DELTAIL, DELTAUW, & -!/ST4 DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & -!/ST4 IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & -!/ST4 DIKCUMUL, CUMULW -!/ST4 END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 18' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/ST6 IF ( WRITE ) THEN -!/ST6 WRITE (NDSM) SIN6A0, SDS6ET, SDS6A1, SDS6A2, & -!/ST6 SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& -!/ST6 SIN6WS, SIN6FC -!/ST6 ELSE -!/ST6 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/ST6 SIN6A0, SDS6ET, SDS6A1, SDS6A2, & -!/ST6 SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& -!/ST6 SIN6WS, SIN6FC -!/ST6 END IF -! -! ... Nonlinear interactions -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 19' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/NL1 IF ( WRITE ) THEN -!/NL1 WRITE (NDSM) & -!/NL1 SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 -!/NL1 ELSE -!/NL1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL1 SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 -!/NL1 END IF -! -!/NL1 IF ( FLTEST ) WRITE (NDST,9051) SNLC1, LAM, & -!/NL1 KDCON, KDMN, SNLS1, SNLS2, SNLS3 -! -!/NL2 IF ( WRITE ) THEN -!/NL2 WRITE (NDSM) IQTPE, NLTAIL, NDPTHS -!/NL2 WRITE (NDSM) DPTHNL -!/NL2 ELSE -!/NL2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL2 IQTPE, NLTAIL, NDPTHS -!/NL2 ALLOCATE ( MPARS(IGRD)%SNLPS%DPTHNL(NDPTHS) ) -!/NL2 DPTHNL => MPARS(IGRD)%SNLPS%DPTHNL -!/NL2 PINIT = .TRUE. -!/NL2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) DPTHNL -!/NL2 END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 20' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/NL2 IF ( FLTEST ) WRITE (NDST,9051) IQTPE, NLTAIL, NDPTHS -!/NL2 IF ( FLTEST ) WRITE (NDST,9151) DPTHNL -! -!/NL3 IF ( WRITE ) THEN -!/NL3 WRITE (NDSM) SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS -!/NL3 WRITE (NDSM) SNLL(1:SNLNQ), SNLM(1:SNLNQ), & -!/NL3 SNLT(1:SNLNQ), SNLCD(1:SNLNQ), & -!/NL3 SNLCS(1:SNLNQ) -!/NL3 ELSE -!/NL3 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL3 SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS -!/NL3 ALLOCATE ( MPARS(IGRD)%SNLPS%SNLL(SNLNQ), & -!/NL3 MPARS(IGRD)%SNLPS%SNLM(SNLNQ), & -!/NL3 MPARS(IGRD)%SNLPS%SNLT(SNLNQ), & -!/NL3 MPARS(IGRD)%SNLPS%SNLCD(SNLNQ), & -!/NL3 MPARS(IGRD)%SNLPS%SNLCS(SNLNQ) ) -!/NL3 SNLL => MPARS(IGRD)%SNLPS%SNLL -!/NL3 SNLM => MPARS(IGRD)%SNLPS%SNLM -!/NL3 SNLT => MPARS(IGRD)%SNLPS%SNLT -!/NL3 SNLCD => MPARS(IGRD)%SNLPS%SNLCD -!/NL3 SNLCS => MPARS(IGRD)%SNLPS%SNLCS -!/NL3 PINIT = .TRUE. -!/NL3 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL3 SNLL, SNLM, SNLT, SNLCD, SNLCS -!/NL3 END IF -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 21' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/NL3 IF ( FLTEST ) WRITE (NDST,9051) SNLNQ, SNLMSC, SNLNSC, & -!/NL3 SNLSFD, SNLSFS -!/NL3 IF ( FLTEST ) THEN -!/NL3 DO I=1, SNLNQ -!/NL3 WRITE (NDST,9151) SNLL(I), SNLM(I), SNLT(I), & -!/NL3 SNLCD(I), SNLCS(I) -!/NL3 END DO -!/NL3 END IF -! -!/NL4 IF ( WRITE ) THEN -!/NL4 WRITE (NDSM) ITSA, IALT -!/NL4 ELSE -!/NL4 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL4 ITSA, IALT -!/NL4 END IF -! -!/NL4 IF ( FLTEST ) WRITE (NDST,9051) ITSA, IALT -! -! (QL: INXOUT = Grid option ?) -!/NL5 IF (WRITE) THEN -!/NL5 CALL INSNL5 -!/NL5 WRITE (NDSM) QR5DPT, QR5OML, QI5DIS, QI5KEV, & -!/NL5 QI5NNZ, QI5IPL, QI5PMX -!/NL5 ELSE -!/NL5 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NL5 QR5DPT, QR5OML, QI5DIS, QI5KEV, & -!/NL5 QI5NNZ, QI5IPL, QI5PMX -!/NL5 END IF -!/NL5 IF ( FLTEST ) WRITE (NDST,9051) QR5DPT, QR5OML, QI5DIS, & -!/NL5 QI5KEV, QI5NNZ, QI5IPL, & -!/NL5 QI5PMX -! -!/NLS IF ( WRITE ) THEN -!/NLS WRITE (NDSM) & -!/NLS CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 -!/NLS ELSE -!/NLS READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/NLS CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 -!/NLS END IF -! -!/NLS IF ( FLTEST ) WRITE (NDST,9251) & -!/NLS CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 -! -!/NL1 IF ( .NOT. WRITE ) CALL INSNL1 ( IGRD ) -!/NL3 IF ( .NOT. WRITE ) CALL INSNL3 -!/NLS IF ( .NOT. WRITE ) CALL INSNLS -! -! Layered barriers needed for file management in xnl_init -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 22' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MPI IF ( FLSNL2 .AND. .NOT.WRITE ) THEN -!/MPI DO IP=1, IAPROC-1 -!/MPI CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) -!/MPI END DO -!/MPI END IF -!/NL2 IF ( .NOT. WRITE ) CALL INSNL2 -!/MPI IF ( FLSNL2 .AND. .NOT.WRITE ) THEN -!/MPI DO IP=IAPROC, NAPROC-1 -!/MPI CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) -!/MPI END DO -!/MPI END IF -! -! ... Bottom friction ... -! -!/BT1 IF ( WRITE ) THEN -!/BT1 WRITE (NDSM) SBTC1 -!/BT1 ELSE -!/BT1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SBTC1 -!/BT1 END IF -! -!/BT1 IF ( FLTEST ) WRITE (NDST,9052) SBTC1 -! -! -!/BT4 IF ( WRITE ) THEN -!/BT4 WRITE (NDSM) & -!/BT4 SBTCX, SED_D50, SED_PSIC -!/BT4 ELSE -!/BT4 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/BT4 SBTCX, SED_D50, SED_PSIC -!/BT4 END IF -! -! ... Depth induced breaking ... -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 23' -!/DEBUGIOGR FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 8' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DB1 IF ( WRITE ) THEN -!/DB1 WRITE (NDSM) & -!/DB1 SDBC1, SDBC2, FDONLY -!/DB1 ELSE -!/DB1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/DB1 SDBC1, SDBC2, FDONLY -!/DB1 END IF -! -!/DB1 IF ( FLTEST ) WRITE (NDST,9053) SDBC1, SDBC2, FDONLY - -!/UOST IF ( WRITE ) THEN -!/UOST WRITE (NDSM) UOSTFILELOCAL, UOSTFILESHADOW, & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW -!/UOST ELSE -!/UOST READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/UOST UOSTFILELOCAL, UOSTFILESHADOW, & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW -!/UOST CALL UOST_INITGRID(IGRD, UOSTFILELOCAL, UOSTFILESHADOW, & -!/UOST UOSTFACTORLOCAL, UOSTFACTORSHADOW) - -!/UOST END IF - -! -!/IS1 IF ( WRITE ) THEN -!/IS1 WRITE (NDSM) IS1C1, IS1C2 -!/IS1 ELSE -!/IS1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS1C1, IS1C2 -!/IS1 END IF -! -!/IS2 IF ( WRITE ) THEN -!/IS2 WRITE (NDSM) IS2PARS -!/IS2 ELSE -!/IS2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS2PARS -!/IS2 IF ( .NOT. FLIS ) THEN -!/IS2 CALL INSIS2 -!/IS2 FLIS = .TRUE. -!/IS2 END IF -!/IS2 END IF -! -! Propagation scheme ------------------------------------------------- * -! Module W3GDATMD PROP -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 24' -!/DEBUGIOGR FLUSH(740+IAPROC) -! -!/PR2 IF ( WRITE ) THEN -!/PR2 WRITE (NDSM) DTME, CLATMN -!/PR2 ELSE -!/PR2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/PR2 DTME, CLATMN -!/PR2 END IF -! -!/PR2 IF ( FLTEST ) WRITE (NDST,9060) DTME, CLATMN -! -!/PR3 IF ( WRITE ) THEN -!/PR3 WRITE (NDSM) WDCG, WDTH -!/PR3 ELSE -!/PR3 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/PR3 WDCG, WDTH -!/PR3 END IF -! -!/PR3 IF ( FLTEST ) WRITE (NDST,9060) WDCG, WDTH -! -!/SMC IF ( WRITE ) THEN -!/SMC WRITE(NDSM) DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC -!/SMC ELSE -!/SMC READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/SMC DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC -!/SMC END IF -! -!/SMC IF ( FLTEST ) WRITE (NDST,9260) DTMS, Refran -! -!/FLD1 IF ( WRITE ) THEN -!/FLD1 WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD1 ELSE -!/FLD1 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/FLD1 TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD1 END IF -!/FLD2 IF ( WRITE ) THEN -!/FLD2 WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD2 ELSE -!/FLD2 READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & -!/FLD2 TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD2 END IF -! -! Interpolation tables ( fill locally ) ----------------------------- * -! Module W3DISPMD -! -!/DEBUGIOGR WRITE(740+IAPROC,*) 'W3IOGR, step 25' -!/DEBUGIOGR FLUSH(740+IAPROC) - IF ( .NOT.WRITE .AND. .NOT.FLDISP ) THEN -!/T WRITE (NDST,9070) - CALL DISTAB - FLDISP = .TRUE. - END IF -! - CLOSE ( NDSM ) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 9' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - RETURN -! -! Escape locations read errors --------------------------------------- * -! - 800 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:I), IERR - CALL EXTCDE ( 50 ) -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:I) - CALL EXTCDE ( 51 ) -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:I), IERR, & - MESSAGE - CALL EXTCDE ( 52 ) -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL VERGRD, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' ILEGAL NFBPO READ : ',I8/ & - ' CHECK : ',I8/) - 905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED SOURCE TERM IDENTIFIER',I2/ & - ' IN mod_def.',A,' FILE : ',A/ & - ' EXPECTED FROM switch FILE : ',A,/ & - 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED PROPAGATION SCHEME IDENTIFIER'/ & - ' IN FILE :',A/ & - ' EXPECTED :',A/ & - ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 907 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED GSE ALEVIATION IDENTIFIER'/ & - ' IN FILE :',A/ & - ' EXPECTED :',A/ & - , 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) - 908 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & - ' UNEXPECTED FLUX PARAMETERIZATION IDENTIFIER'/ & - ' IN mod_def.',A,' :',A/ & - ' EXPECTED :',A/ & - , 5(A,/) /) -! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) -! - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & - ' ERROR IN OPENING mod_def.',A,' FILE'/ & - ' IOSTAT =',I5/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & - ' PREMATURE END OF mod_def.',A,' FILE'/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/, & - ' ERROR IN READING FROM mod_def.',A,' FILE'/ & - ' IOSTAT =',I5, & - 5(A,/) /) -! -!/T 9000 FORMAT (' TEST W3IOGR : INXOUT = ',A,', WRITE = ',L1, & -!/T ', UNIT =',I3,', IGRD =',I3,', FEXT = ',A) -!/T 9001 FORMAT (' TEST W3IOGR : TEST PARAMETERS :'/ & -!/T ' IDSTR : ',A/ & -!/T ' VERGRD : ',A/ & -!/T ' NX/Y/SEA : ',3I10/ & -!/T ' NTH,NK : ',2I10/ & -!/T ' NBI : ',I10/ & -!/T ' NFBPO : ',2I10/ & -!/T ' GNAME : ',A/ & -!/T ' FNAME0 : ',A/ & -!/T ' FNAME1 : ',A/ & -!/T ' FNAME2 : ',A/ & -!/T ' FNAME3 : ',A/ & -!/T ' FNAME4 : ',A/ & -!/T ' FNAME5 : ',A/ & -!/T ' FNAME6 : ',A/ & -!/T ' FNAMEP : ',A/ & -!/T ' FNAMEG : ',A/ & -!/T ' FNAMEF : ',A/ & -!/T ' FNAMEI : ',A) -!/T 9002 FORMAT (' NBO : ',10I5) -!/T 9003 FORMAT (' NBO2 : ',10I5) -! -!/T 9010 FORMAT (' TEST W3IOGR : MODULE W3GDATMD GRID'/ & -!/T ' GTYPE : ',I9/ & -!/T ' FLAGLL : ',L9/ & -!/T ' ICLOSE : ',I9/ & -!/T ' SX, SY : ',2E10.3/ & -!/T ' X0, Y0 : ',2E10.3/ & -!/T ' TRFLAG : ',I9) -!/T 9011 FORMAT (' LOWER LEFT PART OF ',A) -!/T 9012 FORMAT (' ',4X,30I2) -!/T 9013 FORMAT (' ',12I6) -!/T 9014 FORMAT (' ',12F6.2) -!/T 9015 FORMAT (' STEPS : ',4F8.1/ & -!/T ' DEPTH : ',F8.1,F10.3/ & -!/T ' FICE0/N: ',F9.2,F8.2/ & -!/T ' FICEL : ',F9.1 / & -!/T ' PFMOVE : ',F9.2 / & -!/T ' STEXU : ',F9.2 / & -!/T ' STEYU : ',F9.2 / & -!/T ' STEDU : ',F9.2) -! -!/T 9016 FORMAT (' FLAGS : ',8L2) -!/T 9017 FORMAT (' CLATS : ',3F8.3,' ...'/ & -!/T ' CLATIS : ',3F8.3,' ...'/ & -!/T ' CTHG0S : ',3E11.3,' ...') -! -!/T 9020 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT5') -!/T 9021 FORMAT (' INTERPOLATION DATA : FILE ',I1) -!/T 9022 FORMAT (' ',I5,2X,4I4,2X,4F5.2) -!/T 9023 FORMAT (' ',10I7) -!/T 9025 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT6'/ & -!/T ' PARTITIONING DATA :',I5,3E10.3,L4,2X,I4) -! -!/T 9030 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SGRD'/ & -!/T ' MAPWN : ',8I4,' ...'/ & -!/T ' MAPTH : ',8I4,' ...'/ & -!/T ' DTH : ',F6.1/ & -!/T ' TH : ',4F6.1,' ...'/ & -!/T ' ESIN : ',4F6.3,' ...'/ & -!/T ' ECOS : ',4F6.3,' ...'/ & -!/T ' XFR : ',F6.3/ & -!/T ' FR : ',F6.3,' ...',F6.3/ & -!/T ' FACs : ',6E10.3/ & -!/T ' ',3E10.3) -! -!/T 9040 FORMAT (' TEST W3IOGR : MODULE W3GDATMD NPAR'/ & -!/T ' FACs : ',5E10.3/ & -!/T ' ',4E10.3) -! -!/FLX2 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & -!/FLX2 ' FLUXES : ',I5,3X,E10.3) -!/FLX3 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & -!/FLX3 ' FLUXES : ',2I5,3X,2E10.3) -! -!/LN1 9049 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SLNP'/ & -!/LN1 ' INPUT : ',3E10.3) -! -!/ST1 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & -!/ST1 ' INPUT : ',E10.3/ & -!/ST1 ' DISSIP : ',E10.3) -!/ST2 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & -!/ST2 ' INPUT : ',2E10.3/ & -!/ST2 ' DISSIP : ',4E10.3/ & -!/ST2 ' ',5E10.3/ & -!/ST2 ' ',3E10.3/ & -!/ST2 ' STAB2 : ',6E10.3) -! -!/NL1 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & -!/NL1 ' DATA : ',2E10.3/ & -!/NL1 ' ',5E10.3) -! -!/NL2 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & -!/NL2 ' DATA : ',I4,F5.1,I4) -!/NL2 9151 FORMAT (' ',5F7.1) -! -!/NL3 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & -!/NL3 ' DATA : ',I4,4F8.3) -!/NL3 9151 FORMAT (' ',2F8.3,F6.1,2E12.4) -! -!/NL4 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & -!/NL4 ' DATA : ',I4,I4) -! -!/NL5 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & -!/NL5 ' DATA : ', F7.1, F8.2, 2I2.1, I12, 2I2.1) -! -!/NLS 9251 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP (NLS)'/ & -!/NLS ' DATA : ',F8.3,E12.4,4F8.3) -! -!/BT1 9052 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SBTP'/ & -!/BT1 ' DATA : ',E10.3) -! -!/DB1 9053 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SDBP'/ & -!/DB1 ' DATA : ',2E10.3,L4) -! -!/PR2 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & -!/PR2 ' DATA : ',2E10.3) -! -!/PR3 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & -!/PR3 ' DATA : ',2F6.2) -! -!/SMC 9260 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SMCG'/ & -!/SMC ' DATA : ',3E10.3) -! -!/T 9070 FORMAT (' TEST W3IOGR : DISPERSION INTEPOLATION TABLES') -!/ -!/ End of W3IOGR ----------------------------------------------------- / -!/ - END SUBROUTINE W3IOGR -!/ -!/ End of module W3IOGRMD -------------------------------------------- / -!/ - END MODULE W3IOGRMD diff --git a/model/ftn/w3wavemd.ftn b/model/ftn/w3wavemd.ftn deleted file mode 100644 index 63f2bc302..000000000 --- a/model/ftn/w3wavemd.ftn +++ /dev/null @@ -1,3371 +0,0 @@ -#include "w3macros.h" -!/ ------------------------------------------------------------------- / - MODULE W3WAVEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination. ( version 2.00 ) -!/ For upgrades see subroutines. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn -!/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ Fix NRQSG1/2 = 0 array bound issue. -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) -!/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) -!/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) -!/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) -!/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) -!/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) -!/ defunct OMPX switches. -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3WAVE Subr. Public Actual wave model. -! W3GATH Subr. Public Data transpose before propagation. -! W3SCAT Subr. Public Data transpose after propagation. -! W3NMIN Subr. Public Calculate minimum number of sea -! points per processor. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETx Subr. W3xDATMD Point to data structure. -! -! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. -! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. -! W3UINI Subr. W3UPDTMD Update initial conditions if init. -! with initial wind conditions. -! W3UBPT Subr. W3UPDTMD Update boundary points. -! W3UICE Subr. W3UPDTMD Update ice coverage. -! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. -! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. -! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. -! -! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. -! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. -! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. -! -! W3SRCE Subr. W3SRCEMD Source term integration and calculation. -! -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3OUTG Subr. W3IOGOMD Generate gridded output fields. -! W3IOGO Subr. W3IOGOMD Read/write gridded output. -! W3IOPE Subr. W3IOPOMD Extract point output. -! W3IOPO Subr. W3IOPOMD Read/write point output. -! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. -! W3IORS Subr. W3IORSMD Read/write restart files. -! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. -! W3CPRT Subr. W3IOSFMD Partition spectra. -! W3IOSF Subr. Id. Write partitioned spectral data. -! -! STRACE Subr. W3SERVMD Subroutine tracing. -! WWTIME Subr. Id. System time in readable format. -! EXTCDE Subr. Id. Program abort. -! -! TICK21 Subr. W3TIMEMD Advance the clock. -! DSEC21 Func. Id. Difference between times. -! STME21 Subr. Id. Time in readable format. -! -! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL -! Subr. Basic MPI routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! !/OMPG Id. -! -! !/PR1 First order propagation schemes. -! !/PR2 ULTIMATE QUICKEST scheme. -! !/PR3 Averaged ULTIMATE QUICKEST scheme. -! !/SMC UNO2 scheme on SMC grid. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! !/MPIT Test output for MPI specific code. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/MPI USE W3ADATMD, ONLY: MPIBUF -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & -!/OASIS ,ID_LCOMM, TIMEN & - ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) -!/ declaration of FLIWND. -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Improve MPI_WAITALL call tests/allocations. -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) -!/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) -!/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) -!/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING -!/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH -!/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ -! 1. Purpose : -! -! Run WAVEWATCH III for a given time interval. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! TEND I.A. I Ending time of integration. -! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). -! NO_OUT Log. I Skip output (optional, defaults to F). -! Skip at ending time only! -! ---------------------------------------------------------------- -! -! Local parameters : Flags -! ---------------------------------------------------------------- -! FLOUTG Log. Flag for running W3OUTG. -! FLPART Log. Flag for running W3CPRT. -! FLZERO Log. Flag for zero time interval. -! FLAG0 Log. Flag for processors without tasks. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Currents are updated before winds as currents are used in wind -! and USTAR processing. -! - Ice and water levels can be updated only once per call. -! - If ice or water level time are undefined, the update -! takes place asap, otherwise around the "half-way point" -! betweem the old and new times. -! - To increase accuracy, the calculation of the intra-spectral -! propagation is performed in two parts around the spatial propagation. -! -! 8. Structure : -! -! ----------------------------------------------------------- -! 0. Initializations -! a Point to data structures -! b Subroutine tracing -! c Local parameter initialization -! d Test output -! 1. Check the consistency of the input. -! a Ending time versus initial time. -! b Water level time. -! c Current time interval. -! d Wind time interval. -! e Ice time. -! 2. Determine next time from ending and output -! time and get corresponding time step. -! 3. Loop over time steps (see below). -! 4. Perform output to file if requested. -! a Check if time is output time. -! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) -! c Reset next output time. -! -------------- loop over output types ------------------ -! d Perform output. ( W3IOxx ) -! e Update next output time. -! -------------------- end loop -------------------------- -! 5. Update log file. -! 6. If time is not ending time, branch back to 2. -! ----------------------------------------------------------- -! -! Section 3. -! ---------------------------------------------------------- -! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) -! ( W3UWND ) -! ( W3UINI ) -! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) -! 3.3 Update ice coverage (if new ice map). ( W3UICE ) -! 3.4 Transform grid (if new water level). ( W3ULEV ) -! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) -! ( W3NMIN, W3UTRN ) -! Update grid advection vector. -! 3.6 Perform propagation -! a Preparations. -! b Intra spectral part 1. ( W3KTPn ) -! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) -! b Intra spectral part 2. ( W3KTPn ) -! 3.7 Calculate and integrate source terms. ( W3SRCE ) -! 3.8 Update global time step. -! ---------------------------------------------------------- -! -! 9. Switches : -! -! See module documentation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3IDATMD - USE W3ODATMD -!/ - USE W3UPDTMD - USE W3SRCEMD -!/PR1 USE W3PRO1MD -!/PR2 USE W3PRO2MD -!/PR3 USE W3PRO3MD -!/SMC USE W3PSMCMD -! -!/PR1 USE W3PROFSMD -!/PR2 USE W3PROFSMD -!/PR3 USE W3PROFSMD -!/ - USE W3TRIAMD - USE W3IOGRMD - USE W3IOGOMD - USE W3IOPOMD - USE W3IOTRMD - USE W3IORSMD - USE W3IOBCMD - USE W3IOSFMD -!/PDLIB USE PDLIB_W3PROFSMD, only : APPLY_BOUNDARY_CONDITION_VA -!/PDLIB USE PDLIB_W3PROFSMD, only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT -!/PDLIB USE PDLIB_W3PROFSMD, only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT -!/PDLIB USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM -!/PDLIB USE yowNodepool, only: npa, iplg -!/ - USE W3SERVMD - USE W3TIMEMD -!/IC3 USE W3SIC3MD -!/IS2 USE W3SIS2MD -!/UOST USE W3UOSTMD, ONLY: UOST_SETGRID - USE W3PARALL, ONLY : INIT_GET_ISEA -!/MEMCHECK USE MallocInfo_m -!/SETUP USE W3WAVSET, only : WAVE_SETUP_COMPUTATION -!/NETCDF_QAD USE W3NETCDF, only : OUTPUT_NETCDF_QUICK_AND_DIRTY - -!/OASIS USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 -!/OASOCM USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN -!/OASACM USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS -!/OASICM USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE - -!/PDLIB USE PDLIB_FIELD_VEC, only : DO_OUTPUT_EXCHANGES -!/TIMINGS USE W3PARALL, only : PRINT_MY_TIME -! - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, TEND(2),ODAT(35) - LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT -!/OASIS INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM -!/OASIS INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters : -!/ -!/T INTEGER :: ILEN -!/S INTEGER, SAVE :: IENT = 0 - INTEGER :: IP - INTEGER :: TCALC(2), IT, IT0, NT, ITEST, & - ITLOC, ITLOCH, NTLOC, ISEA, JSEA, & - IX, IY, ISPEC, J, TOUT(2), TLST(2), & - REFLED(6), IK, ITH, IS, NKCFL - INTEGER :: ISP, IP_glob - INTEGER :: TTEST(2),DTTEST - REAL :: ICEDAVE -! -!/MPI LOGICAL :: SBSED -!/SEC1 INTEGER :: ISEC1 -!/SBS INTEGER :: JJ, NDSOFLG -!/MPI INTEGER :: IERR_MPI, NRQMAX -!/MPI INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) - INTEGER :: IXrel - REAL :: DTTST, DTTST1, DTTST2, DTTST3, & - DTL0, DTI0, DTR0, DTI10, DTI50, & - DTGA, DTG, DTGpre, DTRES, & - FAC, VGX, VGY, FACK, FACTH, & - FACX, XXX, REFLEC(4), & - DELX, DELY, DELA, DEPTH, D50, PSIC - REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) - LOGICAL :: SHAVETOTioDummy -!/SEC1 REAL :: DTGTEMP -! - REAL, ALLOCATABLE :: FIELD(:) - REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) -!/IC3 REAL, ALLOCATABLE :: WN_I(:) -!/REFRX REAL, ALLOCATABLE :: CIK(:) -! -! Orphaned arrays from old data structure -! - REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) -! - LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP,& - SKIP_O, FLAG_O, FLDDIR, READBC, & - FLAG0 = .FALSE., FLOUTG, FLPFLD, & - FLPART, LOCAL, FLOUTG2 -! -!/MPI LOGICAL :: FLGMPI(0:8) -!/IC3 REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS -!/IC3 REAL :: USE_CHENG, USE_CGICE, HICE - LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=21) :: IDACT - CHARACTER(LEN=13) :: OUTID - CHARACTER(LEN=23) :: IDTIME - INTEGER eIOBP - INTEGER ITH_F -!/PDLIB REAL :: VS_SPEC(NSPEC) -!/PDLIB REAL :: VD_SPEC(NSPEC) - -! -!/SBS CHARACTER(LEN=30) :: FOUTNAME -! -!/T REAL :: INDSORT(NSEA), DTCFL1(NSEA) -!/ -!/SMC !Li Temperature spectra for Arctic boundary update. -!/SMC REAL, ALLOCATABLE :: BACSPEC(:) -!/SMC REAL :: BACANGL -!/SMC - -!/ ------------------------------------------------------------------- / -! 0. Initializations -! -! 0.a Set pointers to data structure -! -!/COU SCREEN = 333 -! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3WAVE, step 1' -!/DEBUGSRC WRITE(740+IAPROC,*) 'Step 1 : max(UST)=', maxval(UST) -!/DEBUGINIT FLUSH(740+IAPROC) - IF ( IOUTP .NE. IMOD ) CALL W3SETO ( IMOD, NDSE, NDST ) - IF ( IGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) - IF ( IWDATA .NE. IMOD ) CALL W3SETW ( IMOD, NDSE, NDST ) - IF ( IADATA .NE. IMOD ) CALL W3SETA ( IMOD, NDSE, NDST ) - IF ( IIDATA .NE. IMOD ) CALL W3SETI ( IMOD, NDSE, NDST ) -!/UOST CALL UOST_SETGRID(IMOD) - -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NEGATIVE ACTION 1', IS, JSEA, VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN CALL EXTCDE(666) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 1', SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN CALL EXTCDE(666) -!/DEBUGRUN ENDIF - - -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1") -!/PDLIB!/DEBUGIOBP IF (NX .ge. 10210) WRITE(*,*) 'CRIT 1:', MAPSTA(1,10210), IOBP(10210) - -! - ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL)) -!/REFRX ALLOCATE(CIK(NSEAL)) -! - IF ( PRESENT(STAMP) ) THEN - TSTAMP = STAMP - ELSE - TSTAMP = .TRUE. - END IF -! - IF ( PRESENT(NO_OUT) ) THEN - SKIP_O = NO_OUT - ELSE - SKIP_O = .FALSE. - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3WAVE, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2") -! -! 0.b Subroutine tracing -! -!/S CALL STRACE (IENT, 'W3WAVE') -! -! -! 0.c Local parameter initialization -! - IPASS = IPASS + 1 - IDACT = ' ' - OUTID = ' ' - FLACT = ITIME .EQ. 0 - FLMAP = ITIME .EQ. 0 - FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION & - .OR. FLCK .OR. FSFREQSHIFT ) -! - FLPFLD = .FALSE. - DO J=1,NOGE(4) - FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) - END DO -! - IF ( IAPROC .EQ. NAPLOG ) BACKSPACE ( NDSO ) -! - IF ( FLCOLD ) THEN - DTDYN = 0. - FCUT = SIG(NK) * TPIINV - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 -!/SMC !!Li Use sea point only field for SMC grid. -!/SMC ALLOCATE ( FIELD(NCel) ) - ELSE - ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) - ENDIF -! - LOCAL = IAPROC .LE. NAPROC - UGDTUPDATE = .FALSE. - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. - END IF -! -!/SBS NDSOFLG = 99 -!/MPI SBSED = .FALSE. -!/SBS SBSED = .TRUE. -! - TAUWX = 0. - TAUWY = 0. -! -! 0.d Test output -! -!/T ILEN = LEN_TRIM(FILEXT) -!/T WRITE (NDST,9000) IMOD, FILEXT(:ILEN), TEND -! -! 1. Check the consistency of the input ----------------------------- / -! 1.a Ending time versus initial time -! - DTTST = DSEC21 ( TIME , TEND ) -!/DEBUGRUN WRITE(740+IAPROC,*) '1 : DTTST=', DTTST, TIME, TEND - FLZERO = DTTST .EQ. 0. -!/T WRITE (NDST,9010) DTTST, FLZERO - IF ( DTTST .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) - CALL EXTCDE ( 1 ) - END IF -! -! 1.b Water level time -! - IF ( FLLEV ) THEN - IF ( TLEV(1) .GE. 0. ) THEN - DTL0 = DSEC21 ( TLEV , TLN ) - ELSE - DTL0 = 1. - END IF -!/T WRITE (NDST,9011) DTL0 - IF ( DTL0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - CALL EXTCDE ( 2 ) - END IF - ELSE - DTL0 = 0. - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3WAVE, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4") -! -! 1.c Current interval -! - IF ( FLCUR ) THEN - DTTST1 = DSEC21 ( TC0 , TCN ) - DTTST2 = DSEC21 ( TC0 , TIME ) - DTTST3 = DSEC21 ( TEND , TCN ) -!/T WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(7:7) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.d Wind interval -! - IF ( FLWIND ) THEN - DTTST1 = DSEC21 ( TW0 , TWN ) - DTTST2 = DSEC21 ( TW0 , TIME ) - DTTST3 = DSEC21 ( TEND , TWN ) -!/T WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) - CALL EXTCDE ( 4 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(3:3) = 'F' - TOFRST = TIME - END IF - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3WAVE, step 5' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5") -! -! 1.e Ice concentration interval -! - IF ( FLICE ) THEN - IF ( TICE(1) .GE. 0 ) THEN - DTI0 = DSEC21 ( TICE , TIN ) - ELSE - DTI0 = 1. - END IF -!/T WRITE (NDST,9014) DTI0 - IF ( DTI0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI0 = 0. - END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3WAVE, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6") -! -! 1.f Momentum interval -! - IF ( FLTAUA ) THEN - DTTST1 = DSEC21 ( TU0 , TUN ) - DTTST2 = DSEC21 ( TU0 , TIME ) - DTTST3 = DSEC21 ( TEND , TUN ) -!/T WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(9:9) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.g Air density time -! - IF ( FLRHOA ) THEN - DTTST1 = DSEC21 ( TU0 , TUN ) - DTTST2 = DSEC21 ( TU0 , TIME ) - DTTST3 = DSEC21 ( TEND , TUN ) -!/T WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) - CALL EXTCDE ( 2 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(11:11) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.e Ice thickness interval -! - IF ( FLIC1 ) THEN - IF ( TIC1(1) .GE. 0 ) THEN - DTI10 = DSEC21 ( TIC1 , TI1 ) - ELSE - DTI10 = 1. - END IF -!/T WRITE (NDST,9015) DTI10 - IF ( DTI10 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI10 = 0. - END IF -! -! 1.e Ice floe interval -! -!/IS2 IF ( FLIC5 ) THEN -!/IS2 IF ( TIC5(1) .GE. 0 ) THEN -!/IS2 DTI50 = DSEC21 ( TIC5 , TI5 ) -!/IS2 ELSE -!/IS2 DTI50 = 1. -!/IS2 END IF -!/IS2!/T WRITE (NDST,9016) DTI50 -!/IS2 IF ( DTI50 .LT. 0. ) THEN -!/IS2 IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) -!/IS2 CALL EXTCDE ( 5 ) -!/IS2 END IF -!/IS2 ELSE -!/IS2 DTI50 = 0. -!/IS2 END IF -! -! 2. Determine next time from ending and output --------------------- / -! time and get corresponding time step. -! - FLFRST = .TRUE. - DO -!/DEBUGRUN WRITE(740+IAPROC,*) 'First entry in the TIME LOOP' -!/DEBUGRUN FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("First entry in the TIME LOOP") -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.1' -!/DEBUGRUN FLUSH(740+IAPROC) -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF - - -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1") -! -! -! 2.a Pre-calculate table for IC3 ------------------------------------ / -!/IC3 USE_CHENG=IC3PARS(9) -!/IC3 IF( USE_CHENG==1.0 )THEN -!/IC3 FIXEDVISC=IC3PARS(14) -!/IC3 FIXEDDENS=IC3PARS(15) -!/IC3 FIXEDELAS=IC3PARS(16) -!/IC3 IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. & -!/IC3 (FIXEDELAS.LT.0.0) ) THEN -!/IC3 IF ( IAPROC .EQ. NAPERR ) & -!/IC3 WRITE(NDSE,*)'Cheng method requires stationary', & -!/IC3 ' and uniform rheology from namelist.' -!/IC3 CALL EXTCDE(2) -!/IC3 END IF -!/IC3 IF (CALLEDIC3TABLE==0) THEN -!/IC3 CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) -!/IC3 CALLEDIC3TABLE = 1 -!/IC3 ENDIF -!/IC3 ENDIF - -! 2.b Update group velocity and wavenumber from ice parameters ------- / -! from W3SIC3MD module. ------------------------------------------ / -! Note: "IF FLFRST" can be added for efficiency, but testing req'd - - JSEA=1 ! no switch (intentional) - -!/IC3 USE_CGICE=IC3PARS(12) -!/IC3 IF ( USE_CGICE==1.0 ) THEN -!/IC3 IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) - -!/IC3 DO JSEA=1,NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA -!/IC3 ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) -!/IC3 WN_I(:) = 0. -!/IC3 DEPTH = MAX( DMIN , DW(ISEA) ) -!/IC3 IX = MAPSF(ISEA,1) -!/IC3 IY = MAPSF(ISEA,2) - -! 2.b.1 Using Cheng method: requires stationary/uniform rheology. -! However, ice thickness may be input by either method - -!/IC3 IF ( USE_CHENG==1.0 ) THEN -!/IC3 IF (FLIC1) THEN -!/IC3 HICE=ICEP1(IX,IY) -!/IC3 ELSEIF (IC3PARS(13).GE.0.0)THEN -!/IC3 HICE=IC3PARS(13) -!/IC3 ELSE -!/IC3 IF ( IAPROC .EQ. NAPERR ) & -!/IC3 WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & -!/IC3 'FOR CG CALC' -!/IC3 CALL EXTCDE(2) -!/IC3 ENDIF -!/IC3 IF (HICE > 0.0) THEN ! non-zero ice -!/IC3 CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & -!/IC3 CG(:,ISEA),HICE,FIXEDVISC, & -!/IC3 FIXEDDENS, FIXEDELAS, DEPTH) -!/IC3 END IF ! non-zero ice - -!/IC3 ELSE ! not using Cheng method -! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly -! necesssary, but makes code simpler) - -!/IC3 IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN -!/IC3 IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice -!/IC3 CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & -!/IC3 CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & -!/IC3 ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) -!/IC3 END IF ! non-zero ice -!/IC3 ELSE -!/IC3 IF ( IAPROC .EQ. NAPERR ) & -!/IC3 WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & -!/IC3 'FOR CG CALC' -!/IC3 CALL EXTCDE(2) -!/IC3 END IF -!/IC3 ENDIF ! IF USE_CHENG... - -!/IC3 DEALLOCATE(WN_I) -!/IC3 END DO ! DO JSEA=1,NSEAL -!/IC3 END IF ! IF USE_CGICE ... -! - IF ( TOFRST(1) .GT. 0 ) THEN - DTTST = DSEC21 ( TEND , TOFRST ) - ELSE - DTTST = 0. - ENDIF -!/DEBUGRUN WRITE(740+IAPROC,*) '2 : DTTST=', DTTST, TEND, TOFRST -! - IF ( DTTST.GE.0. ) THEN - TCALC = TEND - ELSE - TCALC = TOFRST - END IF -! - DTTST = DSEC21 ( TIME , TCALC ) -!/DEBUGRUN WRITE(740+IAPROC,*) '3 : DTTST=', DTTST, TEND, TOFRST - NT = 1 + INT ( DTTST / DTMAX - 0.001 ) - DTGA = DTTST / REAL(NT) -!/DEBUGRUN WRITE(740+IAPROC,*) 'DTTST=', DTTST, ' NT=', NT - IF ( DTTST .EQ. 0. ) THEN - IT0 = 0 - IF ( .NOT.FLZERO ) ITIME = ITIME - 1 - NT = 0 - ELSE - IT0 = 1 - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -!/T WRITE (NDST,9020) IT0, NT, DTGA -! -! ==================================================================== / -! -! 3. Loop over time steps -! - DTRES = 0. - -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 3', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 3', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -!/DEBUGRUN WRITE(740+IAPROC,*) 'IT0=', IT0, ' NT=', NT -!/DEBUGRUN FLUSH(740+IAPROC) -! - DO IT=IT0, NT -!/TIMINGS CALL PRINT_MY_TIME("Begin of IT loop") -!/SETUP CALL WAVE_SETUP_COMPUTATION -! copy old values -!/PDLIB DO IP=1,NSEAL -!/PDLIB DO ISPEC=1,NSPEC -!/PDLIB VAOLD(ISPEC,IP)=VA(ISPEC,IP) -!/PDLIB END DO -!/PDLIB END DO -! -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop") -!/TIMINGS CALL PRINT_MY_TIME("After assigning VAOLD") -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 0' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - ITIME = ITIME + 1 -! - DTG = REAL(NINT(DTGA+DTRES+0.0001)) - DTRES = DTRES + DTGA - DTG - IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. - CALL TICK21 ( TIME , DTG ) -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'DTGA=', DTGA, ' DTRES=', DTRES -!/DEBUGRUN WRITE(740+IAPROC,*) 'DTG 1 : DTG=', DTG -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN - CALL WWTIME ( STTIME ) - CALL STME21 ( TIME , IDTIME ) - WRITE (SCREEN,950) IDTIME, STTIME - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 4', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 4', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -! - VGX = 0. - VGY = 0. - IF(INFLAGS1(10)) THEN - DTTST1 = DSEC21 ( TIME, TGN ) - DTTST2 = DSEC21 ( TG0, TGN ) - FAC = DTTST1 / MAX ( 1. , DTTST2 ) - VGX = (FAC*GA0+(1.-FAC)*GAN) * & - COS(FAC*GD0+(1.-FAC)*GDN) - VGY = (FAC*GA0+(1.-FAC)*GAN) * & - SIN(FAC*GD0+(1.-FAC)*GDN) - END IF -!/TIMINGS CALL PRINT_MY_TIME("After VGX/VGY assignation") -! -!/T WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, & -!/T VGX, VGY, DTG, DTRES -!/DEBUGSRC WRITE(740+IAPROC,*) 'DTG 2 : DTG=', DTG -!/DEBUGSRC WRITE(740+IAPROC,*) 'max(UST)=', maxval(UST) -!/DEBUGSRC FLUSH(740+IAPROC) -! -! 3.1 Interpolate winds, currents, and momentum. -! (Initialize wave fields with winds) -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCUR=', FLCUR -!/DEBUGRUN FLUSH(740+IAPROC) -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3a ' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - IF ( FLCUR ) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.4' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before UCUR") -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1' -!/DEBUGRUN FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") - -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.2 before W3UCUR' -!/DEBUGRUN FLUSH(740+IAPROC) - CALL W3UCUR ( FLFRST ) -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1 after W3UCUR' -!/DEBUGRUN FLUSH(740+IAPROC) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3b ' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 -!/SMC !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. -!/SMC CALL SMCDCXY - ELSE IF (GTYPE .EQ. UNGTYPE) THEN -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' - CALL UG_GRADIENTS(CX, DCXDX, DCXDY) - CALL UG_GRADIENTS(CY, DCYDX, DCYDY) - CALL GET_INTERFACE - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - ELSE - CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT - CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT - ENDIF !! End GTYPE -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - ELSE IF ( FLFRST ) THEN - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - CX = 0. - CY = 0. - END IF ! FLCUR -!/TIMINGS CALL PRINT_MY_TIME("After CX/CY assignation") -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - IF ( FLWIND ) THEN - IF ( FLFRST ) ASF = 1. - CALL W3UWND ( FLFRST, VGX, VGY ) - ELSE IF ( FLFRST ) THEN - U10 = 0.01 - U10D = 0. - UST = 0.05 - USTDIR = 0.05 - END IF - -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/TIMINGS CALL PRINT_MY_TIME("After U10, etc. assignation") -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.5' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI") -!/TIMINGS CALL PRINT_MY_TIME("Before call W3UINI") - IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.5.1 DTG=', DTG -!/DEBUGRUN FLUSH(740+IAPROC) -! - IF ( FLTAUA ) THEN - CALL W3UTAU ( FLFRST ) - ELSE IF ( FLFRST ) THEN - TAUA = 0.01 - TAUADIR = 0. - END IF -! - IF ( FLRHOA ) THEN - CALL W3URHO ( FLFRST ) - ELSE IF ( FLFRST ) THEN - RHOAIR = DAIR - END IF -! -! 3.2 Update boundary conditions if boundary flag is true (FLBPI) -! -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update") -!/TIMINGS CALL PRINT_MY_TIME("Before boundary update") -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLBPI=', FLBPI -!/DEBUGRUN WRITE(740+IAPROC,*) 'LOCAL=', LOCAL -!/DEBUGRUN FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - IF ( FLBPI .AND. LOCAL ) THEN -! - DO - IF ( TBPIN(1) .EQ. -1 ) THEN - READBC = .TRUE. - IDACT(1:1) = 'F' - ELSE - READBC = DSEC21(TIME,TBPIN).LT.0. - IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' - END IF - FLACT = READBC .OR. FLACT -!/DEBUGIOBC WRITE(740+IAPROC,*) 'READBC=', READBC -!/DEBUGIOBC FLUSH(740+IAPROC) - - IF ( READBC ) THEN -!/DEBUGIOBC WRITE(740+IAPROC,*) 'Before call to W3IOBC' -!/DEBUGIOBC FLUSH(740+IAPROC) - CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, & - ITEST, IMOD ) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'After call to W3IOBC' -!/DEBUGIOBC WRITE(740+IAPROC,*) 'ITEST=', ITEST -!/DEBUGIOBC FLUSH(740+IAPROC) - IF ( ITEST .NE. 1 ) CALL W3UBPT - ELSE - ITEST = 0 - END IF - IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' - IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' - IF ( .NOT. (READBC.AND.FLBPI) ) EXIT - END DO - - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - -!/PDLIB CALL APPLY_BOUNDARY_CONDITION_VA -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL") -!/TIMINGS CALL PRINT_MY_TIME("After FLBPI and LOCAL") - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 8' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! 3.3.1 Update ice coverage (if new ice map). -! Need to be run on output nodes too, to update MAPSTx -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLICE=', FLICE -!/DEBUGRUN WRITE(740+IAPROC,*) 'DTI0=', DTI0 -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLICE .AND. DTI0.NE.0. ) THEN -! - IF ( TICE(1).GE.0 ) THEN - IF ( DTI0 .LT. 0. ) THEN - IDACT(13:13) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TIN ) - IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' - END IF - ELSE - IDACT(13:13) = 'I' - END IF -! - IF ( IDACT(13:13).NE.' ' ) THEN - CALL W3UICE ( VA, VA ) - DTI0 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - END IF - END IF -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0") -!/TIMINGS CALL PRINT_MY_TIME("After FLICE and DTI0") -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.7 DTG=', DTG -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB!/DEBUGIOBP IF (NX .ge. 10210) WRITE(*,*) 'Before W3ULEV:', MAPSTA(1,10210), IOBP(10210) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 9' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! 3.3.2 Update ice thickness -! - IF ( FLIC1 .AND. DTI10.NE.0. ) THEN -! - IF ( TIC1(1).GE.0 ) THEN - IF ( DTI10 .LT. 0. ) THEN - IDACT(15:15) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TI1 ) - IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' - END IF - ELSE - IDACT(15:15) = 'I' - END IF - -! - IF ( IDACT(15:15).NE.' ' ) THEN - CALL W3UIC1 ( FLFRST ) - DTI10 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - END IF -! - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 10' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -! 3.3.3 Update ice floe diameter -! -!/IS2 IF ( FLIC5 .AND. DTI50.NE.0. ) THEN -! -!/IS2 IF ( TIC5(1).GE.0 ) THEN -!/IS2 IF ( DTI50 .LT. 0. ) THEN -!/IS2 IDACT(18:18) = 'B' -!/IS2 ELSE -!/IS2 DTTST = DSEC21 ( TIME, TI5 ) -!/IS2 IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' -!/IS2 END IF -!/IS2 ELSE -!/IS2 IDACT(18:18) = 'I' -!/IS2 END IF -! -!/IS2 IF ( IDACT(18:18).NE.' ' ) THEN -!/IS2 CALL W3UIC5( FLFRST ) -!/IS2 DTI50 = 0. -!/IS2 FLACT = .TRUE. -!/IS2 FLMAP = .TRUE. -!/IS2 END IF -! -!/IS2 END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11a' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! 3.4 Transform grid (if new water level). -! -! write(740+IAPROC,*) 'TEST ARON', FLLEV, DTL0, TLEV(1), IDACT(5:5), DSEC21 ( TIME, TLN ), TIME, TLN -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLLEV=', FLLEV, ' DTL0=', DTL0 -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLLEV .AND. DTL0 .NE.0. ) THEN -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'Before time works' -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( TLEV(1) .GE. 0 ) THEN - IF ( DTL0 .LT. 0. ) THEN - IDACT(5:5) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TLN ) - IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' - END IF - ELSE - IDACT(5:5) = 'I' - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'After time works' -!/DEBUGRUN FLUSH(740+IAPROC) -! - IF ( IDACT(5:5).NE.' ' ) THEN - -!/DEBUGRUN WRITE(740+IAPROC,*) 'Before W3ULEV' -!/DEBUGRUN FLUSH(740+IAPROC) - CALL W3ULEV ( VA, VA ) -!/DEBUGRUN WRITE(740+IAPROC,*) 'After W3ULEV' -!/DEBUGRUN FLUSH(740+IAPROC) - - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - DTL0 = 0. - FLACT = .TRUE. - FLMAP = .TRUE. - FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION & - .OR. FLCK .OR. FSFREQSHIFT - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'After IDACT if test' -!/DEBUGRUN FLUSH(740+IAPROC) - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'After FLLEV test' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0") -!/PDLIB!/DEBUGIOBP IF (NX .ge. 10210) WRITE(*,*) ' After W3ULEV:', MAPSTA(1,10210), IOBP(10210) -!/TIMINGS CALL PRINT_MY_TIME("After FFLEV and DTL0") -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLMAP=', FLMAP -!/DEBUGRUN FLUSH(740+IAPROC) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11b' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -! 3.5 Update maps and derivatives. -! - IF ( FLMAP ) THEN - IF ( GTYPE .NE. SMCTYPE ) THEN -!/PR1 CALL W3MAP1 ( MAPSTA ) -!/PR2 CALL W3MAP2 -!/PR3 CALL W3MAP3 - CALL W3UTRN ( TRNX, TRNY ) -!/PR3 CALL W3MAPT - END IF !! GTYPE - CALL W3NMIN ( MAPSTA, FLAG0 ) - IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD - FLMAP = .FALSE. - END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.1 DTG=', DTG -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.2 DTG=', DTG -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLDDIR=', FLDDIR -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLDDIR ) THEN - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 -!/SMC !!Li Use new sub for DDDX and DDDY assignment. -!/SMC CALL SMCDHXY - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - CALL UG_GRADIENTS(DW, DDDX, DDDY) - ELSE - CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) - END IF - FLDDIR = .FALSE. - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 12' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.3 DTG=', DTG -!/DEBUGRUN FLUSH(740+IAPROC) -! -! Calculate PHASE SPEED GRADIENT. - DCDX = 0. - DCDY = 0. -!/REFRX CIK = 0. -!/REFRX! -!/REFRX IF (GTYPE .NE. UNGTYPE) THEN -!/REFRX DO IK=0,NK+1 -!/REFRX CIK = SIG(IK) / WN(IK,1:NSEA) -!/REFRX CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) -!/REFRX END DO -!/REFRX ELSE -!/REFRX WRITE (NDSE,1040) -!/REFRX CALL EXTCDE(2) -!/REFRX ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! -!/REFRX END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.4' -!/DEBUGRUN FLUSH(740+IAPROC) -! - FLIWND = .FALSE. - FLFRST = .FALSE. -! -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT -!/PDLIB!/DEBUGSRC CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC IF (DEBUG_NODE .le. NSEAL) THEN -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC END IF -!/PDLIB IF (IT .eq. 0) THEN -!/PDLIB DTGpre = 1. -!/PDLIB ELSE -!/PDLIB DTGpre = DTG -!/PDLIB END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 13' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - IF ( FLSOU .and. LPDLIB) THEN -! -!/OMP0/!$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1) - D50=0.0002 - REFLEC(:)=0. - REFLED(:)=0 - PSIC=0. -!/PDLIB VSTOT = 0. -!/PDLIB VDTOT = 0. - - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DELA=1. - DELX=1. - DELY=1. -!/REF1 IF (GTYPE.EQ.RLGTYPE) THEN -!/REF1 DELX=SX*CLATS(ISEA)/FACX -!/REF1 DELY=SY/FACX -!/REF1 DELA=DELX*DELY -!/REF1 END IF -!/REF1 IF (GTYPE.EQ.CLGTYPE) THEN -!/REF1! Maybe what follows works also for RLGTYPE ... to be verified -!/REF1 DELX=HPFAC(IY,IX)/ FACX -!/REF1 DELY=HQFAC(IY,IX)/ FACX -!/REF1 DELA=DELX*DELY -!/REF1 END IF -! -!/REF1 REFLEC=REFLC(:,ISEA) -!/REF1 REFLEC(4)=BERG(ISEA)*REFLEC(4) -!/REF1 REFLED=REFLD(:,ISEA) -!/BT4 D50=SED_D50(ISEA) -!/BT4 PSIC=SED_PSIC(ISEA) -!/REF1 REFLEC=REFLC(:,ISEA) -!/REF1 REFLEC(4)=BERG(ISEA)*REFLEC(4) -!/REF1 REFLED=REFLD(:,ISEA) -!/BT4 D50=SED_D50(ISEA) -!/BT4 PSIC=SED_PSIC(ISEA) -! -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 7', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -! - IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN - IF (FSSOURCE) THEN -!/PDLIB!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA -!/PDLIB!/DEBUGSRC END IF -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) -!/PDLIB!/DEBUGSRC FLUSH(740+IAPROC) -!/PDLIB CALL W3SRCE(srce_imp_pre, IT, JSEA, IX, IY, IMOD, & -!/PDLIB VAoldDummy, VA(:,JSEA), & -!/PDLIB VSTOT(:,JSEA), VDTOT(:,JSEA), SHAVETOT(JSEA), & -!/PDLIB ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & -!/PDLIB CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & -!/PDLIB U10D(ISEA), AS(ISEA), UST(ISEA), & -!/PDLIB USTDIR(ISEA), CX(ISEA), CY(ISEA), & -!/PDLIB ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & -!/PDLIB ICEDMAX(ISEA), & -!/PDLIB REFLEC, REFLED, DELX, DELY, DELA, & -!/PDLIB TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & -!/PDLIB FPIS(ISEA), DTDYN(JSEA), & -!/PDLIB FCUT(JSEA), DTGpre, TAUWX(JSEA), TAUWY(JSEA), & -!/PDLIB TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & -!/PDLIB TAUWIY(JSEA), TAUWNX(JSEA), & -!/PDLIB TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & -!/PDLIB TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC, TMP2, & -!/PDLIB PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & -!/PDLIB TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & -!/PDLIB RHOAIR(ISEA), ASF(ISEA)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) -!/PDLIB!/DEBUGSRC FLUSH(740+IAPROC) - ENDIF - ELSE - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - DTDYN (JSEA) = UNDEF - FCUT (JSEA) = UNDEF - END IF - END DO ! JSEA - END IF ! PDLIB -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT -!/PDLIB!/DEBUGSRC CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") -!/PDLIB!/DEBUGSRC IF (DEBUG_NODE .le. NSEAL) THEN -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 14' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - - IF ( FLZERO ) THEN -!/T WRITE (NDST,9022) - GOTO 400 - END IF - IF ( IT.EQ.0 ) THEN - DTG = 1. -! DTG = 60. - GOTO 370 - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.5' -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLDRY=', FLDRY -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN -!/T WRITE (NDST,9023) -!/DEBUGRUN WRITE(740+IAPROC,*) 'Jump to 380' -!/DEBUGRUN FLUSH(740+IAPROC) - GOTO 380 - END IF -! -! Estimation of the local maximum CFL for XY propagation -! -!/T WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLOGRD(9,3) = ', FLOGRD(9,3) -!/DEBUGRUN WRITE(740+IAPROC,*) 'UGDTUPDATE=', UGDTUPDATE -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.6' -!/DEBUGRUN FLUSH(740+IAPROC) - IF (FSTOTALIMP .eqv. .FALSE.) THEN - NKCFL=NK -!/T NKCFL=1 -! -!/OMPG/!$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) -!/PR3 IF (GTYPE .EQ. UNGTYPE) THEN -!/PR3 IF ( FLOGRD(9,3) ) THEN -!/T IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA -!/PDLIB IF (.NOT. LPDLIB) THEN -!/PR3 CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, & -!/PR3 MAPFS, CFLXYMAX(JSEA), VGX, VGY ) -!/PDLIB ENDIF -!/PR3 END IF -!/PR3 ELSE -!/PR3 CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, & -!/PR3 CFLXYMAX(JSEA), VGX, VGY ) -!/PR3 END IF - END DO -! -!/OMPG/!$OMP END PARALLEL DO -! - END IF - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.7' -!/DEBUGRUN FLUSH(740+IAPROC) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 15' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 8', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 6 ', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF - -! -!/T IF (GTYPE .EQ. UNGTYPE) THEN -!/T IF ( FLOGRD(9,3) ) THEN -!/T DTCFL1(:)=1. -!/T DO JSEA=1,NSEAL -!/T INDSORT(JSEA)=FLOAT(JSEA) -!/T DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) -!/T END DO -!/T CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) -!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' -!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) -!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) -!/T DO JSEA = 1, MIN(NSEAL,200) -!/T ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI -!/T IX = MAPSF(ISEA,1) -!/T IF (JSEA.EQ.1) & -!/T WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' -!/T WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XYB(IX,1), XYB(IX,2), XYB(IX,3) -!/T END DO ! JSEA -!/T CLOSE(995) -!/T END IF -!/T END IF - -! -! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = -! 3.6.1 Preparations -! -!/SEC1 DTGTEMP=DTG -!/SEC1 DTG=DTG/NITERSEC1 -!/SEC1 DO ISEC1=1,NITERSEC1 - NTLOC = 1 + INT( DTG/DTCFLI - 0.001 ) -!/SEC1 IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 -! - FACTH = DTG / (DTH*REAL(NTLOC)) -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, DTCFLI=', DTCFLI -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, DTG=', DTG -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, DTH=', DTH -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, NTLOC=', NTLOC -!/DEBUGRUN FLUSH(740+IAPROC) - FACK = DTG / REAL(NTLOC) - - TTEST(1) = TIME(1) - TTEST(2) = 0 - DTTEST = DSEC21(TTEST,TIME) - ITLOCH = ( NTLOC + 1 - MOD(NINT(DTTEST/DTG),2) ) / 2 -! -! 3.6.2 Intra-spectral part 1 -! -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before intraspectral part 1") -!/TIMINGS CALL PRINT_MY_TIME("Before intraspectral") -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.10' -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCTH=', FLCTH, ' FLCK=', FLCK -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=1, ITLOCH -! -!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1) -! -!/DEBUGRUN WRITE(740+IAPROC,*) ' ITLOC=', ITLOC -!/DEBUGRUN WRITE(740+IAPROC,*) ' 1: Before call to W3KTP1 / W3KTP2 / W3KTP3' - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - -!/DEBUGRUN IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF - - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - DEPTH = MAX ( DMIN , DW(ISEA) ) - IF (LPDLIB) THEN - IXrel = JSEA - ELSE - IXrel = IX - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 -!/SMC !!Li Refraction and GCT in theta direction is done by rotation. -!/SMC CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/SMC CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/SMC DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & -!/SMC CX(ISEA), CY(ISEA), DCXDX(IY,IX), & -!/SMC DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & -!/SMC DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -! - ELSE - J = 1 -! -!/PR1 CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR1 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR1 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR1 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR1 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR1 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) -!/PR2 CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR2 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR2 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR2 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR2 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR2 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) -!/PR3 CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR3 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR3 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR3 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR3 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR3 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & -!/PR3 CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -! - END IF !! GTYPE -! - END IF - END DO -! -!/OMPG/!$OMP END DO -!/OMPG/!$OMP END PARALLEL -! - END DO - END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 16' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection") -!/TIMINGS CALL PRINT_MY_TIME("Before spatial advection") -! -! 3.6.3 Longitude-latitude -! (time step correction in routine) -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12' -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSN=', FSN -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSPSI=', FSPSI -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSFCT=', FSFCT -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSNIMP=', FSNIMP -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCTH=', FLCTH -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCK=', FLCK -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLSOU=', FLSOU -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSTOTALEXP=', FSTOTALEXP -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCUR=', FLCUR -!/DEBUGRUN WRITE(740+IAPROC,*) 'PDLIB=', LPDLIB -!/DEBUGRUN WRITE(740+IAPROC,*) 'GTYPE=', GTYPE -!/DEBUGRUN WRITE(740+IAPROC,*) 'UNGTYPE=', UNGTYPE -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, 'NTPROC=', NTPROC -!/DEBUGRUN WRITE(740+IAPROC,*) 'FLCX=', FLCX, ' FLCY=', FLCY -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/NETCDF_QAD CALL OUTPUT_NETCDF_QUICK_AND_DIRTY(IMOD, DTG) -! - IF (GTYPE .EQ. UNGTYPE) THEN - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. - END IF - END IF - IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN -! -!/PDLIB IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.1' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB DO ISPEC=1,NSPEC -!/PDLIB CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, & -!/PDLIB VGX, VGY, UGDTUPDATE ) -!/PDLIB END DO -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.2' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB END IF -! -!/PDLIB IF (FSTOTALIMP .and. (IT .ne. 0)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3A' -!/DEBUGRUN WRITE(*,*), 'W3WAVE, step 6.12.3A' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT (FACX, FACX, DTG, VGX, VGY) -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4A' -!/DEBUGRUN WRITE(*,*), 'W3WAVE, step 6.12.4A' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3B' -!/DEBUGRUN WRITE(*,*), 'W3WAVE, step 6.12.3B' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(FACX, FACX, DTG, VGX, VGY) -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4B' -!/DEBUGRUN WRITE(*,*), 'W3WAVE, step 6.12.4B' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB ENDIF - ELSE - IF (FLCX .or. FLCY) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.13' -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/MPI IF ( NRQSG1 .GT. 0 ) THEN -!/MPI CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) -!/MPI CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.14' -!/DEBUGRUN FLUSH(740+IAPROC) -! -! Initialize FIELD variable - FIELD = 0. -! - DO ISPEC=1, NSPEC - IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN -! - IF( GTYPE .EQ. SMCTYPE ) THEN - IX = 1 -!/SMC !!Li Use SMC sub to gether field -!/SMC CALL W3GATHSMC ( ISPEC, FIELD ) - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3GATH ( ISPEC, FIELD ) - END IF !! GTYPE -! - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 -!/SMC !!Li Propagation on SMC grid uses UNO2 scheme. -!/SMC CALL W3PSMC ( ISPEC, DTG, FIELD ) -! - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - IX = 1 -!/MPI IF (.NOT. LPDLIB) THEN -!/PR1 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & -!/PR1 FIELD, VGX, VGY, UGDTUPDATE ) -!/PR2 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & -!/PR2 FIELD, VGX, VGY, UGDTUPDATE ) -!/PR3 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & -!/PR3 FIELD, VGX, VGY, UGDTUPDATE ) -!/MPI END IF -! - ELSE - IX = 1 -!/PR1 CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) -!/PR2 CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) -!/PR3 CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) -! - END IF !! GTYPE -! - IF( GTYPE .EQ. SMCTYPE ) THEN - IX = 1 -!/SMC !!Li Use SMC sub to scatter field -!/SMC CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) - END IF !! GTYPE - - END IF - END DO -! -!/MPI IF ( NRQSG1 .GT. 0 ) THEN -!/MPI ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) -!/MPI CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, & -!/MPI IERR_MPI) -!/MPI CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, & -!/MPI IERR_MPI) -!/MPI DEALLOCATE ( STATCO ) -!/MPI END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 17' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!Li Initialise IK IX IY in case ARC option is not used to avoid warnings. - IK=1 - IX=1 - IY=1 -!/SMC !Li Find source boundary spectra and assign to SPCBAC -!/SMC IF( ARCTC ) THEN -!/SMC -!/SMC DO IK = 1, NBAC -!/SMC IF( IK .LE. (NBAC-NBGL) ) THEN -!/SMC IY = ICLBAC(IK) -!/SMC ELSE -!/SMC IY = NGLO + IK -!/SMC ENDIF -!/SMC -!/SMC !Li Work out root PE (ISPEC) and JSEA numbers for IY -!/SMC/!/DIST ISPEC = MOD( IY-1, NAPROC ) -!/SMC/!/DIST JSEA = 1 + (IY - ISPEC - 1)/NAPROC -!/SMC/!/SHRD ISPEC = 0 -!/SMC/!/SHRD JSEA = IY -! -!/SMC !!Li Assign boundary cell spectra. -!/SMC IF( IAPROC .EQ. ISPEC+1 ) THEN -!/SMC SPCBAC(:,IK)=VA(:,JSEA) -!/SMC ENDIF -! -!/SMC !!Li Broadcast local SPCBAC(:,IK) to all other PEs. -!/SMC/!/MPI CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) -!/SMC/!/MPI CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) -! -!/SMC END DO !! Loop IK ends. -! -!/SMC !!Li Update Arctic boundary cell spectra if within local range -!/SMC ALLOCATE ( BACSPEC(NSPEC) ) -!/SMC DO IK = 1, NBAC -!/SMC IF( IK .LE. (NBAC-NBGL) ) THEN -!/SMC IX = NGLO + IK -!/SMC BACANGL = ANGARC(IK) -!/SMC ELSE -!/SMC IX = ICLBAC(IK) -!/SMC BACANGL = - ANGARC(IK) -!/SMC ENDIF -!/SMC -!/SMC !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX -!/SMC/!/DIST ISPEC = MOD( IX-1, NAPROC ) -!/SMC/!/DIST JSEA = 1 + (IX - ISPEC - 1)/NAPROC -!/SMC/!/SHRD ISPEC = 0 -!/SMC/!/SHRD JSEA = IX -! -!/SMC IF( IAPROC .EQ. ISPEC+1 ) THEN -!/SMC BACSPEC = SPCBAC(:,IK) -!/SMC -!/SMC CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) -!/SMC -!/SMC VA(:,JSEA) = BACSPEC -!/SMC !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK -!/SMC ENDIF -!/SMC -!/SMC END DO !! Loop IK ends. -!/SMC DEALLOCATE ( BACSPEC ) -!/SMC -!/SMC ENDIF !! ARCTC -! -! End of test FLCX.OR.FLCY - END IF -! - END IF - -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection") -!/TIMINGS CALL PRINT_MY_TIME("After spatial advection") -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.16' -!/DEBUGRUN WRITE(740+IAPROC,*) 'NTLOC=', NTLOC -!/DEBUGRUN WRITE(740+IAPROC,*) 'ITLOCH=', ITLOCH -!/DEBUGRUN FLUSH(740+IAPROC) -! -! 3.6.4 Intra-spectral part 2 -! - IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=ITLOCH+1, NTLOC -! -!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1) -! -!/DEBUGRUN WRITE(740+IAPROC,*) ' ITLOC=', ITLOC -!/DEBUGRUN WRITE(740+IAPROC,*) ' 2: Before call to W3KTP1 / W3KTP2 / W3KTP3' - DO JSEA = 1, NSEAL - - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -!/DEBUGRUN IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) - DEPTH = MAX ( DMIN , DW(ISEA) ) - - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF - - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN - IF (LPDLIB) THEN - IXrel = JSEA - ELSE - IXrel = IX - END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 -!/SMC !!Li Refraction and GCT in theta direction is done by rotation. -!/SMC CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/SMC CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/SMC DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & -!/SMC CX(ISEA), CY(ISEA), DCXDX(IY,IX), & -!/SMC DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & -!/SMC DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -! - ELSE - J = 1 -!/PR1 CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR1 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR1 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR1 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR1 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR1 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) -!/PR2 CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR2 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR2 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR2 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR2 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR2 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) -!/PR3 CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & -!/PR3 CG(:,ISEA), WN(:,ISEA), DEPTH, & -!/PR3 DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & -!/PR3 CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & -!/PR3 DCYDX(IY,IXrel), DCYDY(IY,IXrel), & -!/PR3 DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & -!/PR3 CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -! - END IF !! GTYPE -! - END IF - END DO -! -!/OMPG/!$OMP END DO -!/OMPG/!$OMP END PARALLEL -! - END DO - END IF -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.") -!/TIMINGS CALL PRINT_MY_TIME("fter intraspectral adv.") -! - UGDTUPDATE = .FALSE. -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.17' -!/DEBUGRUN WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE -!/DEBUGRUN FLUSH(740+IAPROC) -! -! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = - -! 3.7 Calculate and integrate source terms. -! - 370 CONTINUE - IF ( FLSOU ) THEN -! - D50=0.0002 - REFLEC(:)=0. - REFLED(:)=0 - PSIC=0. -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT -!/PDLIB!/DEBUGSRC CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST") -!/PDLIB!/DEBUGSRC CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST") -!/PDLIB!/DEBUGSRC IF (DEBUG_NODE .le. NSEAL) THEN -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC END IF -! -!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & -!/OMPG/!$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) -!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1) -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DELA=1. - DELX=1. - DELY=1. -!/REF1 IF (GTYPE.EQ.RLGTYPE) THEN -!/REF1 DELX=SX*CLATS(ISEA)/FACX -!/REF1 DELY=SY/FACX -!/REF1 DELA=DELX*DELY -!/REF1 END IF -!/REF1 IF (GTYPE.EQ.CLGTYPE) THEN -!/REF1! Maybe what follows works also for RLGTYPE ... to be verified -!/REF1 DELX=HPFAC(IY,IX)/ FACX -!/REF1 DELY=HQFAC(IY,IX)/ FACX -!/REF1 DELA=DELX*DELY -!/REF1 END IF -! -!/REF1 REFLEC=REFLC(:,ISEA) -!/REF1 REFLEC(4)=BERG(ISEA)*REFLEC(4) -!/REF1 REFLED=REFLD(:,ISEA) -!/BT4 D50=SED_D50(ISEA) -!/BT4 PSIC=SED_PSIC(ISEA) - -!/DEBUGRUN IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', ISEA, JSEA, SUM(VA(:,JSEA)) - - IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN - TMP1 = WHITECAP(JSEA,1:4) - TMP2 = BEDFORMS(JSEA,1:3) - TMP3 = TAUBBL(JSEA,1:2) - TMP4 = TAUICE(JSEA,1:2) -!/PDLIB IF (FSSOURCE) THEN -!/PDLIB CALL W3SRCE(srce_imp_post,IT,JSEA,IX,IY,IMOD, & -!/PDLIB VAOLD(:,JSEA), VA(:,JSEA), & -!/PDLIB VSTOT(:,JSEA),VDTOT(:,JSEA),SHAVETOT(JSEA), & -!/PDLIB ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & -!/PDLIB CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & -!/PDLIB U10D(ISEA), AS(ISEA), UST(ISEA), & -!/PDLIB USTDIR(ISEA), CX(ISEA), CY(ISEA), & -!/PDLIB ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & -!/PDLIB ICEDMAX(ISEA), & -!/PDLIB REFLEC, REFLED, DELX, DELY, DELA, & -!/PDLIB TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & -!/PDLIB FPIS(ISEA), DTDYN(JSEA), & -!/PDLIB FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & -!/PDLIB TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & -!/PDLIB TAUWIY(JSEA), TAUWNX(JSEA), & -!/PDLIB TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & -!/PDLIB TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2,& -!/PDLIB PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & -!/PDLIB TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & -!/PDLIB RHOAIR(ISEA), ASF(ISEA)) -!/PDLIB ELSE - CALL W3SRCE(srce_direct, IT, JSEA, IX, IY, IMOD, & - VAoldDummy, VA(:,JSEA), & - VSioDummy, VDioDummy, SHAVETOTioDummy, & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & -!/FLX5 TAUA(ISEA), TAUADIR(ISEA), & - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2,& - PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) -!/PDLIB END IF - WHITECAP(JSEA,1:4) = TMP1 - BEDFORMS(JSEA,1:3) = TMP2 - TAUBBL(JSEA,1:2) = TMP3 - TAUICE(JSEA,1:2) = TMP4 - ELSE - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - DTDYN (JSEA) = UNDEF - FCUT (JSEA) = UNDEF -! VA(:,JSEA) = 0. - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'RET: min/max/sum(VA)=',minval(VA(:,JSEA)),maxval(VA(:,JSEA)),sum(VA(:,JSEA)) - END DO -!/DEBUGRUN WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) -!/DEBUGRUN FLUSH(740+IAPROC) - -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 9', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 7', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -! -!/OMPG/!$OMP END DO -!/OMPG/!$OMP END PARALLEL -! -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT -!/PDLIB!/DEBUGSRC CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST") -!/PDLIB!/DEBUGSRC CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST") -!/PDLIB!/DEBUGSRC IF (DEBUG_NODE .le. NSEAL) THEN -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) -!/PDLIB!/DEBUGSRC END IF - -! -! This barrier is from older code versions. It has been removed in 3.11 -! to optimize IO2/3 settings. May be needed on some systems still -! -!!/MPI IF (FLAG0) CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) -!!/MPI ELSE -!!/MPI CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) -! - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.18' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After source terms") -!/TIMINGS CALL PRINT_MY_TIME("After source terms") -! -! End of interations for DTMAX < 1s -! -!/SEC1 IF (IT.EQ.0) EXIT -!/SEC1 END DO -!/SEC1 IF (IT.GT.0) DTG=DTGTEMP -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.19' -!/DEBUGRUN FLUSH(740+IAPROC) -!/DEBUGRUN DO JSEA = 1, NSEAL -!/DEBUGRUN DO IS = 1, NSPEC -!/DEBUGRUN IF (VA(IS, JSEA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 10', VA(IS,JSEA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN ENDIF -!/DEBUGRUN ENDDO -!/DEBUGRUN ENDDO -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 8', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -! -! 3.8 Update global time step. -! (Branch point FLDRY, IT=0) -! - 380 CONTINUE -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.20' -!/DEBUGRUN FLUSH(740+IAPROC) - IF (IT.NE.NT) THEN - DTTST = DSEC21 ( TIME , TCALC ) - DTG = DTTST / REAL(NT-IT) - END IF -! - IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN - CALL STME21 ( TIME , IDTIME ) - IF ( IDLAST .NE. TIME(1) ) THEN - WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), & - IDACT, OUTID - IDLAST = TIME(1) - ELSE - WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF - FLACT = .FALSE. - IDACT = ' ' - END IF -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21' -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/PDLIB!/DEBUGCOH CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop") -!/TIMINGS CALL PRINT_MY_TIME("end of time loop") -! -! - END DO - -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.1' -!/DEBUGRUN FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") -! -!/T WRITE (NDST,9030) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END TIME LOOP' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -! End of loop over time steps -! ==================================================================== / -! - 400 CONTINUE -! -! 4. Perform output to file if requested ---------------------------- / -! 4.a Check if time is output time -! Delay if data assimilation time. -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.2' -!/DEBUGRUN FLUSH(740+IAPROC) -! - IF ( TOFRST(1) .EQ. -1 ) THEN - DTTST = 1. - ELSE - DTTST = DSEC21 ( TIME, TOFRST ) - END IF -! - IF ( TDN(1) .EQ. -1 ) THEN - DTTST1 = 1. - ELSE - DTTST1 = DSEC21 ( TIME, TDN ) - END IF -! - DTTST2 = DSEC21 ( TIME, TEND ) - FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) -! -!/T WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.3' -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.4' -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9041) -! -! 4.b Processing and MPP preparations -! - IF ( FLOUT(1) ) THEN - FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. - ELSE - FLOUTG = .FALSE. - END IF -! - IF ( FLOUT(7) ) THEN - FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. - ELSE - FLOUTG2 = .FALSE. - END IF -! - FLPART = .FALSE. - IF ( FLOUT(1) .AND. FLPFLD ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.7' -!/DEBUGRUN FLUSH(740+IAPROC) - IF ( FLOUT(6) ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. -!/DEBUGRUN WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.8' -!/DEBUGRUN FLUSH(740+IAPROC) -! -!/T WRITE (NDST,9042) LOCAL, FLPART, FLOUTG -! - IF ( LOCAL .AND. FLPART ) CALL W3CPRT ( IMOD ) - IF ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) & - CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) -! -!/MPI FLGMPI = .FALSE. -!/MPI NRQMAX = 0 -! -!/MPI IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & -!/MPI ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. & -!/MPI SBSED ) ) THEN -!/MPI IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN -!/MPI IF (NRQGO.NE.0 ) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO.NE.0 , step 0', & -!/DEBUGRUN NRQGO, IRQGO, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) -!/DEBUGRUN WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO.NE.0, step 0' -!/DEBUGRUN FLUSH(740+IAPROC) - -!/MPI FLGMPI(0) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQGO ) -!/MPIT WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD -!/MPI END IF -! -!/MPI IF (NRQGO2.NE.0 ) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO2.NE.0, step 0', & -!/DEBUGRUN NRQGO2, IRQGO2, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) -!/DEBUGRUN WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO2.NE.0, step 0' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI FLGMPI(1) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQGO2 ) -!/MPIT WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD -!/MPI END IF -!/MPI ELSE -!/DEBUGRUN WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' -!/DEBUGRUN FLUSH(740+IAPROC) -!/PDLIB CALL DO_OUTPUT_EXCHANGES(IMOD) -!/MPI END IF -!/MPI END IF - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 1' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN -!/MPI IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN -!/MPI CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) -!/MPI FLGMPI(2) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQPO ) -!/MPIT WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT -!/MPI END IF -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN -!/MPI IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN -!/MPI CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) -!/MPI FLGMPI(4) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQRS ) -!/MPIT WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST -!/MPI END IF -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(8) .AND. NRQRS.NE.0 ) THEN -!/MPI IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN -!/MPI CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) -!/MPI FLGMPI(8) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQRS ) -!/MPIT WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST -!/MPI END IF -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 3' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN -!/MPI IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN -!/MPI CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) -!/MPI FLGMPI(5) = .TRUE. -!/MPI NRQMAX = MAX ( NRQMAX , NRQBP ) -!/MPIT WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT -!/MPI END IF -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 4' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. & -!/MPI IAPROC.EQ.NAPBPT) THEN -!/MPI IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN -!/MPI CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) -!/MPI NRQMAX = MAX ( NRQMAX , NRQBP2 ) -!/MPIT WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT -!/MPI END IF -!/MPI END IF -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 5' -!/DEBUGRUN FLUSH(740+IAPROC) -!/MPI IF ( NRQMAX .NE. 0 ) ALLOCATE & -!/MPI ( STATIO(MPI_STATUS_SIZE,NRQMAX) ) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -! 4.c Reset next output time - -!/DEBUGRUN IF (MINVAL(VA) .LT. 0.) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'TEST W3WAVE 12', SUM(VA), MINVAL(VA), MAXVAL(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -!/DEBUGRUN IF (SUM(VA) .NE. SUM(VA)) THEN -!/DEBUGRUN WRITE(740+IAPROC,*) 'NAN in ACTION 9', IX, IY, SUM(VA) -!/DEBUGRUN CALL FLUSH(740+IAPROC) -!/DEBUGRUN STOP -!/DEBUGRUN ENDIF -! - TOFRST(1) = -1 - TOFRST(2) = 0 -! - DO J=1, NOTYPE -!/DEBUGRUN WRITE(740+IAPROC,*) 'NOTYPE, J=', J -!/DEBUGRUN FLUSH(740+IAPROC) - - IF ( FLOUT(J) ) THEN -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'Matching FLOUT(J)' -!/DEBUGRUN FLUSH(740+IAPROC) -! -! 4.d Perform output -! -!/NL5 IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) - TOUT(:) = TONEXT(:,J) - DTTST = DSEC21 ( TIME, TOUT ) -! - IF ( DTTST .EQ. 0. ) THEN - IF ( ( J .EQ. 1 ) & -!/SBS .OR. ( J .EQ. 7 ) & - ) THEN - IF ( IAPROC .EQ. NAPFLD ) THEN -!/MPI IF ( FLGMPI(1) ) CALL MPI_WAITALL & -!/MPI ( NRQGO2, IRQGO2, STATIO, IERR_MPI ) -!/MPI FLGMPI(1) = .FALSE. -! -!/SBS IF ( J .EQ. 1 ) THEN - CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) -!/SBS ENDIF -! -!/SBS ! -!/SBS ! Generate output flag file for fields and SBS coupling. -!/SBS ! -!/SBS JJ = LEN_TRIM ( FILEXT ) -!/SBS CALL STME21 ( TIME, IDTIME ) -!/SBS FOUTNAME = 'Field_done.' // IDTIME(1:4) & -!/SBS // IDTIME(6:7) // IDTIME(9:10) & -!/SBS // IDTIME(12:13) // '.' // FILEXT(1:JJ) -! -!/SBS OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) -!/SBS CLOSE( NDSOFLG ) - END IF -! - ELSE IF ( J .EQ. 2 ) THEN -! -! Point output -! - IF ( IAPROC .EQ. NAPPNT ) THEN -! -! Gets the necessary spectral data -! - CALL W3IOPE ( VA ) - CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) - END IF -! - ELSE IF ( J .EQ. 3 ) THEN -! -! Track output -! - CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) - ELSE IF ( J .EQ. 4 ) THEN - CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) - ITEST = RSTYPE - ELSE IF ( J .EQ. 5 ) THEN - IF ( IAPROC .EQ. NAPBPT ) THEN -!/MPI IF (NRQBP2.NE.0) CALL MPI_WAITALL & -!/MPI ( NRQBP2, IRQBP2,STATIO, IERR_MPI ) - CALL W3IOBC ( 'WRITE', NDS(10), & - TIME, TIME, ITEST, IMOD ) - END IF - ELSE IF ( J .EQ. 6 ) THEN - CALL W3IOSF ( NDS(13), IMOD ) -!/OASIS ELSE IF ( J .EQ. 7 ) THEN -!/OASIS ! -!/OASIS ! Send variables to atmospheric or ocean circulation or ice model -!/OASIS ! -!/OASIS IF (DTOUT(7).NE.0) THEN -!/OASIS IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & -!/OASIS (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN -!/OASIS IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. & -!/OASIS .NOT. CPLT0 ) THEN -!/OASIS IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) -!/OASIS -!/OASACM CALL SND_FIELDS_TO_ATMOS() -!/OASOCM CALL SND_FIELDS_TO_OCEAN() -!/OASICM CALL SND_FIELDS_TO_ICE() -!/OASIS IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) -!/OASIS ENDIF -!/OASIS ENDIF -!/OASIS ENDIF - END IF -! - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' -!/OASIS IF ( (DTOUT(7).NE.0) .AND. & -!/OASIS (DSEC21(TIME,TIME00).EQ.0 .OR. & -!/OASIS DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' - ELSE - OUTID(2*J-1:2*J-1) = 'L' - END IF - END IF -! -! 4.e Update next output time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! - END IF -! - END DO - - -! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. - J=8 - IF ( FLOUT(J) ) THEN -! -!/DEBUGRUN WRITE(740+IAPROC,*) 'Matching FLOUT(J)' -!/DEBUGRUN FLUSH(740+IAPROC) -! -! 4.d Perform output -! - TOUT(:) = TONEXT(:,J) - DTTST = DSEC21 ( TIME, TOUT ) - IF ( DTTST .EQ. 0. ) THEN - CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) - ITEST = RSTYPE - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' -!/OASIS IF ( (DTOUT(7).NE.0) .AND. & -!/OASIS (DSEC21(TIME,TIME00).EQ.0 .OR. & -!/OASIS DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' - ELSE - OUTID(2*J-1:2*J-1) = 'L' - END IF - END IF -! -! 4.e Update next output time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF - END IF -! END OF CHECKPOINT -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -!/MPI IF ( FLGMPI(0) ) CALL MPI_WAITALL & -!/MPI ( NRQGO, IRQGO , STATIO, IERR_MPI ) -!/MPI IF ( FLGMPI(2) ) CALL MPI_WAITALL & -!/MPI ( NRQPO, IRQPO1, STATIO, IERR_MPI ) -!/MPI IF ( FLGMPI(4) ) CALL MPI_WAITALL & -!/MPI ( NRQRS, IRQRS , STATIO, IERR_MPI ) -!/MPI IF ( FLGMPI(8) ) CALL MPI_WAITALL & -!/MPI ( NRQRS, IRQRS , STATIO, IERR_MPI ) -!/MPI IF ( FLGMPI(5) ) CALL MPI_WAITALL & -!/MPI ( NRQBP, IRQBP1, STATIO, IERR_MPI ) -!/MPI IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO ) -! -!/T WRITE (NDST,9044) -! -! This barrier is from older code versions. It has been removed in 3.11 -! to optimize IO2/3 settings. May be needed on some systems still -! -!!/MPI IF (FLDRY) CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) -! - END IF -!/TIMINGS CALL PRINT_MY_TIME("Before update log file") - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -! -! 5. Update log file ------------------------------------------------ / - -! IF (MINVAL(VA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 13', SUM(VA), MINVAL(VA), MAXVAL(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF -! - IF ( IAPROC.EQ.NAPLOG ) THEN -! - CALL STME21 ( TIME , IDTIME ) - IF ( FLCUR ) THEN - DTTST = DSEC21 ( TIME , TCN ) - IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' - END IF - IF ( FLWIND ) THEN - DTTST = DSEC21 ( TIME , TWN ) - IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' - END IF - IF ( FLTAUA ) THEN - DTTST = DSEC21 ( TIME , TUN ) - IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' - END IF - IF ( FLRHOA ) THEN - DTTST = DSEC21 ( TIME , TRN ) - IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' - END IF - IF ( TDN(1) .GT. 0 ) THEN - DTTST = DSEC21 ( TIME , TDN ) - IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' - END IF -! - IF ( IDLAST.NE.TIME(1) ) THEN - WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & - IDACT, OUTID - IDLAST = TIME(1) - ELSE - WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF -! - END IF -! - IDACT = ' ' - OUTID = ' ' - FLACT = .FALSE. -! -! 6. If time is not ending time, branch back to 2 ------------------- / -! - DTTST = DSEC21 ( TIME, TEND ) - IF ( DTTST .EQ. 0. ) EXIT -!/TIMINGS CALL PRINT_MY_TIME("Continuing the loop") - END DO - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - - IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN - CALL WWTIME ( STTIME ) - WRITE (SCREEN,951) STTIME - END IF - - IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,902) -! - DEALLOCATE(FIELD) - DEALLOCATE(TAUWX, TAUWY) -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END W3WAVE' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - RETURN -! -! Formats -! - 900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') - 901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') - 902 FORMAT (2X,'--------+------+---------------------+' & - ,'-------------------+---------------+') -! -!/IC3 920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) - 950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) - 951 FORMAT (' WAVEWATCH III reached the end of a computation', & - ' loop at ',A) - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ENDING TIME BEFORE STARTING TIME '/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ILLEGAL CURRENT INTERVAL '/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' ILLEGAL WIND INTERVAL '/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW ICE FIELD BEFORE OLD ICE FIELD '/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW ATM MOMENTUM BEFORE OLD ATM MOMENTUM '/) - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & - ' NEW AIR DENSITY BEFORE OLD AIR DENSITY '/) -!/IS2 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & -!/IS2 ' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/) - 1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & - ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & - ' IN GRID',I3) -!/REFRX 1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & -!/REFRX ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/) -! -!/T 9000 FORMAT ( & -!/T '============================================================', & -!/T '===================='/ & -!/T ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & -!/T '] UP TO ',I8.8,I7.6 / & -!/T '====================', & -!/T '============================================================') -!/T 9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) -!/T 9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) -!/T 9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & -!/T ' ',F12.1/ & -!/T ' ',F12.1) -!/T 9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & -!/T ' ',F12.1/ & -!/T ' ',F12.1) -!/T 9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) -!/T 9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) -!/T 9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) -!/T 9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) -!/T 9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) -!/T 9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) -!/T 9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & -!/T 2F6.2,F7.1,F6.2) -!/T 9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') -!/T 9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') -!/T 9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') -!/T 9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & -!/T ' TOFRST :',I9.8,I7.6/ & -!/T ' TND :',I9.8,I7.6/ & -!/T ' DTTST[1], FLAG_O :',2F8.1,L4) -!/T 9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') -!/T 9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) -!/MPIT 9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) -!/T 9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') -!/ -!/ End of W3WAVE ----------------------------------------------------- / -!/ - END SUBROUTINE W3WAVE -!/ ------------------------------------------------------------------- / - SUBROUTINE W3GATH ( ISPEC, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ -! 1. Purpose : -! -! Gather spectral bin information into a propagation field array. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! FIELD R.A. O Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is extracted but not converted. -! - MPI version requires posing of send and receive calls in -! W3WAVE to match local calls. -! - MPI version does not require an MPI_TESTALL call for the -! posted gather operation as MPI_WAITALL is mandatory to -! reset persistent communication for next time step. -! - MPI version allows only two new pre-fetch postings per -! call to minimize chances to be slowed down by gathers that -! are not yet needed, while maximizing the pre-loading -! during the early (low-frequency) calls to the routine -! where the amount of calculation needed for proagation is -! the largest. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE -!/ - USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN - USE W3PARALL, ONLY: INIT_GET_ISEA - USE W3WDATMD, ONLY: A => VA -!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & -!/MPI NSPLOC, NRQSG2, IRQSG2, GSTORE -!/MPI USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC - REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/SHRD INTEGER :: ISEA, IXY -!/MPI INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & -!/MPI IOFF, IERR_MPI, JSEA, ISEA, & -!/MPI IXY, IS0, IB0, NPST, J -!/S INTEGER, SAVE :: IENT -!/MPIT CHARACTER(LEN=15) :: STR(MPIBUF), STRT -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3GATH') -! - FIELD = 0. -! -! 1. Shared memory version ------------------------------------------ / -! -!/SHRD DO ISEA=1, NSEA -!/SHRD IXY = MAPSF(ISEA,3) -!/SHRD FIELD(IXY) = A(ISPEC,ISEA) -!/SHRD END DO -! -!/SHRD RETURN -! -! 2. Distributed memory version ( MPI ) ----------------------------- / -! 2.a Update counters -! -!/MPI ISPLOC = ISPLOC + 1 -!/MPI IBFLOC = IBFLOC + 1 -!/MPI IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -! -!/MPIT IF ( ISPLOC .EQ. 1 ) THEN -!/MPIT STR = '--------------+' -!/MPIT WRITE (NDST,9000) STR -!/MPIT END IF -!/MPIT STR = ' |' -!/MPIT STRT = STR(IBFLOC) -!/MPIT STRT(9:9) = 'A' -! -! 2.b Check status of present buffer -! 2.b.1 Scatter (send) still in progress, wait to end -! -!/MPI IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI BSTAT(IBFLOC) = 0 -!/MPIT STRT(13:13) = 'S' -!/MPI END IF -! -! 2.b.2 Gather (recv) not yet posted, post now -! -!/MPI IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN -!/MPI BSTAT(IBFLOC) = 1 -!/MPI BISPL(IBFLOC) = ISPLOC -!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) -!/MPIT STRT(10:10) = 'g' -!/MPI END IF -! -! 2.c Put local spectral densities in store -! -!/MPI DO JSEA=1, NSEAL -!/MPI CALL INIT_GET_ISEA(ISEA, JSEA) -!/MPI GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) -!/MPI END DO -! -! 2.d Wait for remote spectral densities -! -!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) -! -!/MPIT STRT(11:11) = 'G' -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC -!/MPIT STR(IBFLOC) = STRT -! -! 2.e Convert storage array to field. -! -!/MPI DO ISEA=1, NSEA -!/MPI IXY = MAPSF(ISEA,3) -!/MPI FIELD(IXY) = GSTORE(ISEA,IBFLOC) -!/MPI END DO -! -! 2.f Pre-fetch data in available buffers -! -!/MPI IS0 = ISPLOC -!/MPI IB0 = IBFLOC -!/MPI NPST = 0 -! -!/MPI DO J=1, MPIBUF-1 -!/MPI IS0 = IS0 + 1 -!/MPI IF ( IS0 .GT. NSPLOC ) EXIT -!/MPI IB0 = 1 + MOD(IB0,MPIBUF) -!/MPI IF ( BSTAT(IB0) .EQ. 0 ) THEN -!/MPI BSTAT(IB0) = 1 -!/MPI BISPL(IB0) = IS0 -!/MPI IOFF = 1 + (IS0-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) -!/MPI NPST = NPST + 1 -!/MPIT STRT = STR(IB0) -!/MPIT STRT(10:10) = 'g' -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) -!/MPIT STR(IB0) = STRT -!/MPI END IF -!/MPI IF ( NPST .GE. 2 ) EXIT -!/MPI END DO -! -! 2.g Test output -! -!/MPIT DO IB0=1, MPIBUF -!/MPIT STRT = STR(IB0) -!/MPIT IF ( STRT(2:2) .EQ. ' ' ) THEN -!/MPIT IF ( BSTAT(IB0) .EQ. 0 ) THEN -!/MPIT WRITE (STRT(1:2),'(I2)') BSTAT(IB0) -!/MPIT ELSE -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) -!/MPIT END IF -!/MPIT STR(IB0) = STRT -!/MPIT END IF -!/MPIT END DO -!/MPIT WRITE (NDST,9010) ISPLOC, STR -! -!/MPI RETURN -! -! Formats -! -!/MPIT 9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & -!/MPIT ' -------------------------------'/ & -!/MPIT ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & -!/MPIT ' FRIST COLLUMN : LOCAL ISPEC'/ & -!/MPIT ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & -!/MPIT ' 0 : INACTIVE'/ & -!/MPIT ' 1 : RECEIVING'/ & -!/MPIT ' 2 : SENDING'/ & -!/MPIT ' LOCAL ISPEC FOR BUFFER'/ & -!/MPIT ' A : ACTIVE BUFFER'/ & -!/MPIT ' g/G: START/FINISH RECIEVE'/ & -!/MPIT ' s/S: START/FINISH SEND'/ & -!/MPIT ' +-----+',8A15) -!/MPIT 9010 FORMAT ( ' |',I4,' |',8A15) -!/ -!/ End of W3GATH ----------------------------------------------------- / -!/ - END SUBROUTINE W3GATH -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ -! 1. Purpose : -! -! 'Scatter' data back to spectral storage after propagation. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! See also W3GATH. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! MAPSTA I.A. I Status map for spatial grid. -! FIELD R.A. I Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is put back but not converted ! -! - MPI persistent communication calls initialize in W3MPII. -! - See W3GATH and W3MPII for additional comments on data -! buffering. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE -!/ - USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF - USE W3WDATMD, ONLY: A => VA -!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & -!/MPI NSPLOC, NRQSG2, IRQSG2, SSTORE - USE W3ODATMD, ONLY: NDST -!/MPI USE W3ODATMD, ONLY: IAPROC, NAPROC - USE CONSTANTS, ONLY : LPDLIB - USE W3PARALL, only: INIT_GET_ISEA -!/ - IMPLICIT NONE -! -!/MPI INCLUDE "mpif.h" -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) - REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/SHRD INTEGER :: ISEA, IXY -!/MPI INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & -!/MPI STATUS(MPI_STATUS_SIZE,NSPEC), & -!/MPI JSEA, IB0 -!/S INTEGER, SAVE :: IENT -!/MPIT CHARACTER(LEN=15) :: STR(MPIBUF), STRT -!/MPI LOGICAL :: DONE -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3SCAT') -! -! 1. Shared memory version ------------------------------------------ * -! -!/SHRD DO ISEA=1, NSEA -!/SHRD IXY = MAPSF(ISEA,3) -!/SHRD IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(IXY) -!/SHRD END DO -! -!/SHRD RETURN -! -! 2. Distributed memory version ( MPI ) ----------------------------- * -! 2.a Initializations -! -!/MPIT DO IB0=1, MPIBUF -!/MPIT STR(IB0) = ' |' -!/MPIT END DO -! -!/MPIT STRT = STR(IBFLOC) -!/MPIT STRT(9:9) = 'A' -! -! 2.b Convert full grid to sea grid, active points only -! -!/MPI DO ISEA=1, NSEA -!/MPI IXY = MAPSF(ISEA,3) -!/MPI IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) -!/MPI END DO -! -! 2.c Send spectral densities to appropriate remote -! -!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) -!/MPI BSTAT(IBFLOC) = 2 -!/MPIT STRT(12:12) = 's' -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC -!/MPIT STR(IBFLOC) = STRT -! -! 2.d Save locally stored results -! -!/MPI DO JSEA=1, NSEAL -!/MPI CALL INIT_GET_ISEA(ISEA, JSEA) -!/MPI IXY = MAPSF(ISEA,3) -!/MPI IF (MAPSTA(IXY) .GE. 1) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) -!/MPI END DO -! -! 2.e Check if any sends have finished -! -!/MPI IB0 = IBFLOC -! -!/MPI DO J=1, MPIBUF -!/MPI IB0 = 1 + MOD(IB0,MPIBUF) -!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) THEN -!/MPI CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & -!/MPI STATUS, IERR_MPI ) -!/MPI ELSE -!/MPI DONE = .TRUE. -!/MPI END IF -!/MPI IF ( DONE .AND. NRQSG2.GT.0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI IF ( DONE ) THEN -!/MPI BSTAT(IB0) = 0 -!/MPIT STRT = STR(IB0) -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) -!/MPIT STRT(13:13) = 'S' -!/MPIT STR(IB0) = STRT -!/MPI END IF -!/MPI END IF -!/MPI END DO -! -! 2.f Last component, finish message passing, reset buffer control -! -!/MPI IF ( ISPLOC .EQ. NSPLOC ) THEN -! -!/MPI DO IB0=1, MPIBUF -!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI BSTAT(IB0) = 0 -!/MPIT STRT = STR(IB0) -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) -!/MPIT STRT(13:13) = 'S' -!/MPIT STR(IB0) = STRT -!/MPI END IF -!/MPI END DO -! -!/MPI ISPLOC = 0 -!/MPI IBFLOC = 0 -! -!/MPI END IF -! -! 2.g Test output -! -!/MPIT DO IB0=1, MPIBUF -!/MPIT STRT = STR(IB0) -!/MPIT IF ( STRT(2:2) .EQ. ' ' ) THEN -!/MPIT IF ( BSTAT(IB0) .EQ. 0 ) THEN -!/MPIT WRITE (STRT(1:2),'(I2)') BSTAT(IB0) -!/MPIT ELSE -!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) -!/MPIT END IF -!/MPIT STR(IB0) = STRT -!/MPIT END IF -!/MPIT END DO -! -!/MPIT WRITE (NDST,9000) STR -! -!/MPIT IF ( ISPLOC .EQ. 0 ) THEN -!/MPIT DO IB0=1, MPIBUF -!/MPIT STR(IB0) = '--------------+' -!/MPIT END DO -!/MPIT WRITE (NDST,9010) STR -!/MPIT WRITE (NDST,*) -!/MPIT END IF -! -!/MPI RETURN -! -! Formats -! -!/MPIT 9000 FORMAT ( ' | |',8A15) -!/MPIT 9010 FORMAT ( ' +-----+',8A15) -!/ -!/ End of W3SCAT ----------------------------------------------------- / -!/ - END SUBROUTINE W3SCAT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 23-Feb-2001 : Origination. ( version 2.07 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Check minimum number of active sea points at given processor to -! evaluate the need for a MPI_BARRIER call. -! -! 2. Method : -! -! Evaluate mapsta. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MAPSTA I.A. I Status map for spatial grid. -! FLAG0 log. O Flag to identify 0 as minimum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF - USE W3ODATMD, ONLY: NDST, NAPROC - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MAPSTA(NY*NX) - LOGICAL, INTENT(OUT) :: FLAG0 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY - INTEGER :: JSEA, ISPROC -!/S INTEGER, SAVE :: IENT -!/ -!/ ------------------------------------------------------------------- / -!/ -!/S CALL STRACE (IENT, 'W3NMIN') -! - NMIN = NSEA -! - DO IPROC=1, NAPROC - NLOC = 0 - DO ISEA=1, NSEA - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF (ISPROC .eq. IPROC) THEN - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 - END IF - END DO -!/SMC !!Li For SMC grid, local sea points are equally NSEA/NAPROC -!/SMC !!Li so the NLOC is overwirte by a constant. -!/SMC NLOC = NSEA/NAPROC -! -!/T WRITE (NDST,9000) IPROC, NLOC - NMIN = MIN ( NMIN , NLOC ) - END DO -! - FLAG0 = NMIN .EQ. 0 -!/T WRITE (NDST,9001) NMIN, FLAG0 -! - RETURN -! -! Formats -! -!/T 9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) -!/T 9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) -!/ -!/ End of W3NMIN ----------------------------------------------------- / -!/ - END SUBROUTINE W3NMIN -!/ -!/ End of module W3WAVEMD -------------------------------------------- / -!/ - END MODULE W3WAVEMD diff --git a/model/ftn/PDLIB/yowdatapool.ftn b/model/src/PDLIB/yowdatapool.F90 similarity index 100% rename from model/ftn/PDLIB/yowdatapool.ftn rename to model/src/PDLIB/yowdatapool.F90 diff --git a/model/ftn/PDLIB/yowelementpool.ftn b/model/src/PDLIB/yowelementpool.F90 similarity index 100% rename from model/ftn/PDLIB/yowelementpool.ftn rename to model/src/PDLIB/yowelementpool.F90 diff --git a/model/ftn/PDLIB/yowerr.ftn b/model/src/PDLIB/yowerr.F90 similarity index 100% rename from model/ftn/PDLIB/yowerr.ftn rename to model/src/PDLIB/yowerr.F90 diff --git a/model/ftn/PDLIB/yowexchangeModule.ftn b/model/src/PDLIB/yowexchangeModule.F90 similarity index 95% rename from model/ftn/PDLIB/yowexchangeModule.ftn rename to model/src/PDLIB/yowexchangeModule.F90 index 1a5d3d80b..b248d0b2c 100644 --- a/model/ftn/PDLIB/yowexchangeModule.ftn +++ b/model/src/PDLIB/yowexchangeModule.F90 @@ -261,12 +261,16 @@ subroutine PDLIB_exchange2Dreal(U) integer :: recvStat(MPI_STATUS_SIZE, nConnDomains), sendStat(MPI_STATUS_SIZE, nConnDomains) -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 3' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 3' + FLUSH(740+IAPROC) +#endif ! post receives -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 4' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 4' + FLUSH(740+IAPROC) +#endif do i=1, nConnDomains tag = 30000 + myrank call MPI_IRecv(U, 1, neighborDomains(i)%p2DRrecvType1, & @@ -276,8 +280,10 @@ subroutine PDLIB_exchange2Dreal(U) CALL PARALLEL_ABORT("MPI_IRecv", ierr) endif enddo -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 5' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 5' + FLUSH(740+IAPROC) +#endif ! post sends do i=1, nConnDomains @@ -289,18 +295,24 @@ subroutine PDLIB_exchange2Dreal(U) CALL PARALLEL_ABORT("MPI_ISend", ierr) endif end do -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 6' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 6' + FLUSH(740+IAPROC) +#endif ! Wait for completion call mpi_waitall(nConnDomains, recvRqst, recvStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 11' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 11' + FLUSH(740+IAPROC) +#endif call mpi_waitall(nConnDomains, sendRqst, sendStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) -!/DEBUGEXCH WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 12' -!/DEBUGEXCH FLUSH(740+IAPROC) +#ifdef W3_DEBUGEXCH + WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 12' + FLUSH(740+IAPROC) +#endif end subroutine diff --git a/model/ftn/PDLIB/yowfunction.ftn b/model/src/PDLIB/yowfunction.F90 similarity index 70% rename from model/ftn/PDLIB/yowfunction.ftn rename to model/src/PDLIB/yowfunction.F90 index 46e98757b..0118f4ee6 100644 --- a/model/ftn/PDLIB/yowfunction.ftn +++ b/model/src/PDLIB/yowfunction.F90 @@ -66,14 +66,20 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel ! ! Computing ListNP and ListNPA ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 1' + FLUSH(740+IAPROC) +#endif allocate(ListNP(NAPROC), ListNPA(NAPROC), iVect(2), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 2' + FLUSH(740+IAPROC) +#endif IF (istat /= 0) CALL PDLIB_ABORT(1) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 3' + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. 1) THEN ListNP(1)=np ListNPA(1)=npa @@ -94,31 +100,43 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel CALL MPI_RECV(ListNPA,NAPROC,MPI_INTEGER, 0, 21, MPI_COMM_WCMP, istatus, ierr) END IF deallocate(iVect) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 4' + FLUSH(740+IAPROC) +#endif ! ! ListIPLG ! sumNP=sum(ListNPA) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 5, sumNP=', sumNP -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 5, sumNP=', sumNP + FLUSH(740+IAPROC) +#endif allocate(ListIPLG(sumNP), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 6' + FLUSH(740+IAPROC) +#endif IF (istat /= 0) CALL PDLIB_ABORT(2) -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 7' -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, NAPROC=', NAPROC, ' NTPROC=', NTPROC -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 7' + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, NAPROC=', NAPROC, ' NTPROC=', NTPROC + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. 1) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Main node 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Main node 1' + FLUSH(740+IAPROC) +#endif idx=0 DO IP=1,NPA idx=idx+1 ListIPLG(IP)=iplg(IP) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Main node 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Main node 2' + FLUSH(740+IAPROC) +#endif DO IPROC=2,NAPROC len=ListNPA(IPROC) allocate(iVect(len), stat=istat) @@ -130,29 +148,45 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel END DO deallocate(iVect) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Main node 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Main node 3' + FLUSH(740+IAPROC) +#endif DO IPROC=2,NAPROC -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before mpi_send IPROC=', IPROC -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before mpi_send IPROC=', IPROC + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ListIPLG, sumNP,MPI_INTEGER, iProc-1, 271, MPI_COMM_WCMP, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After mpi_send IPROC=', IPROC -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After mpi_send IPROC=', IPROC + FLUSH(740+IAPROC) +#endif END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Main node 4' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Main node 4' + FLUSH(740+IAPROC) +#endif ELSE -!/DEBUGINIT WRITE(740+IAPROC,*) 'Peripheral node 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Peripheral node 1' + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(iplg, npa,MPI_INTEGER, 0, 269, MPI_COMM_WCMP, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Peripheral node 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Peripheral node 2' + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(ListIPLG,sumNP,MPI_INTEGER, 0, 271, MPI_COMM_WCMP, istatus, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Peripheral node 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Peripheral node 3' + FLUSH(740+IAPROC) +#endif END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 8' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 8' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !********************************************************************** !* * @@ -166,52 +200,80 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG IMPLICIT NONE INCLUDE "mpif.h" INTEGER sumNP, iProc, ierr, istat -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before ComputeListNP_ListNPA_Kernel' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before ComputeListNP_ListNPA_Kernel' + FLUSH(740+IAPROC) +#endif IF (IAPROC .le. NAPROC) THEN CALL ComputeListNP_ListNPA_ListIPLG_Kernel END IF -!/DEBUGINIT WRITE(740+IAPROC,*) ' After ComputeListNP_ListNPA_Kernel' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' After ComputeListNP_ListNPA_Kernel' + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. 1) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Doing the send' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Doing the send' + FLUSH(740+IAPROC) +#endif sumNP=sum(ListNPA) DO iProc=NAPROC+1,NTPROC -!/DEBUGINIT WRITE(740+IAPROC,*) 'Loop state 1, iProc=', iProc -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Loop state 1, iProc=', iProc + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ListNP, NAPROC,MPI_INTEGER, iProc-1, 20, MPI_COMM_WAVE, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Loop state 2, iProc=', iProc -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Loop state 2, iProc=', iProc + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ListNPA,NAPROC,MPI_INTEGER, iProc-1, 21, MPI_COMM_WAVE, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Loop state 3, iProc=', iProc -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Loop state 3, iProc=', iProc + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ListIPLG, sumNP,MPI_INTEGER, iProc-1, 271, MPI_COMM_WAVE, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Loop state 4, iProc=', iProc -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Loop state 4, iProc=', iProc + FLUSH(740+IAPROC) +#endif END DO END IF IF (IAPROC .gt. NAPROC) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before allocation' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before allocation' + FLUSH(740+IAPROC) +#endif allocate(ListNP(NAPROC), ListNPA(NAPROC), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before receiving of data 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before receiving of data 1' + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(ListNP ,NAPROC,MPI_INTEGER, 0, 20, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before receiving of data 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before receiving of data 2' + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(ListNPA,NAPROC,MPI_INTEGER, 0, 21, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before computing sumNP' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before computing sumNP' + FLUSH(740+IAPROC) +#endif sumNP=sum(ListNPA) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before allocating ListIPLG' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before allocating ListIPLG' + FLUSH(740+IAPROC) +#endif allocate(ListIPLG(sumNP), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before receiving ListIPLG' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before receiving ListIPLG' + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(ListIPLG,sumNP,MPI_INTEGER, 0, 271, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After receiving ListIPLG' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After receiving ListIPLG' + FLUSH(740+IAPROC) +#endif END IF END SUBROUTINE !********************************************************************** diff --git a/model/ftn/PDLIB/yownodepool.ftn b/model/src/PDLIB/yownodepool.F90 similarity index 100% rename from model/ftn/PDLIB/yownodepool.ftn rename to model/src/PDLIB/yownodepool.F90 diff --git a/model/ftn/PDLIB/yowpd.ftn b/model/src/PDLIB/yowpd.F90 similarity index 100% rename from model/ftn/PDLIB/yowpd.ftn rename to model/src/PDLIB/yowpd.F90 diff --git a/model/ftn/PDLIB/yowpdlibmain.ftn b/model/src/PDLIB/yowpdlibmain.F90 similarity index 98% rename from model/ftn/PDLIB/yowpdlibmain.ftn rename to model/src/PDLIB/yowpdlibmain.F90 index be63fe447..377f60b7b 100644 --- a/model/ftn/PDLIB/yowpdlibmain.ftn +++ b/model/src/PDLIB/yowpdlibmain.F90 @@ -74,15 +74,25 @@ subroutine initFromGridDim(MNP, XP, YP, DEP, MNE, INE, secDim, MPIcomm) integer istat call setDimSize(secDim) -!/DEBUGINIT Print *, '1: MPIcomm=', MPIcomm +#ifdef W3_DEBUGINIT + Print *, '1: MPIcomm=', MPIcomm +#endif call initMPI(MPIcomm) -!/DEBUGINIT Print *, '2: After initMPI' +#ifdef W3_DEBUGINIT + Print *, '2: After initMPI' +#endif call assignMesh(MNP, XP, YP, DEP, MNE, INE) -!/DEBUGINIT Print *, '3: After assignMesh' +#ifdef W3_DEBUGINIT + Print *, '3: After assignMesh' +#endif call prePartition() -!/DEBUGINIT Print *, '3: After prePartition' +#ifdef W3_DEBUGINIT + Print *, '3: After prePartition' +#endif call findConnNodes() -!/DEBUGINIT Print *, '4: After findConnNodes' +#ifdef W3_DEBUGINIT + Print *, '4: After findConnNodes' +#endif if(debugPrePartition) then if(myrank == 0) then write(*,*) "pre-partition" @@ -96,13 +106,19 @@ subroutine initFromGridDim(MNP, XP, YP, DEP, MNE, INE, secDim, MPIcomm) endif ! call writeMesh() -!/DEBUGINIT Print *, '4.1: After findConnNodes' +#ifdef W3_DEBUGINIT + Print *, '4.1: After findConnNodes' +#endif ! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "Before call to runParmetis") call runParmetis(MNP, XP, YP) ! CALL REAL_MPI_BARRIER_PDLIB(MPIcomm, "After call to runParmetis") -!/DEBUGINIT Print *, '5: After runParmetis' +#ifdef W3_DEBUGINIT + Print *, '5: After runParmetis' +#endif call postPartition -!/DEBUGINIT Print *, 'Before findGhostNodes' +#ifdef W3_DEBUGINIT + Print *, 'Before findGhostNodes' +#endif call findGhostNodes call findConnDomains call exchangeGhostIds @@ -172,7 +188,9 @@ subroutine initMPI(MPIcomm) integer, intent(in) :: MPIcomm logical :: flag integer :: ierr -!/DEBUGINIT Print *, '2: MPIcomm=', MPIcomm +#ifdef W3_DEBUGINIT + Print *, '2: MPIcomm=', MPIcomm +#endif if(MPIcomm == MPI_COMM_NULL) then CALL ABORT("A null communicator is not allowed") endif @@ -182,9 +200,13 @@ subroutine initMPI(MPIcomm) if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr) if(flag .eqv. .false.) then -!/DEBUGINIT Print *, 'Before MPI_INIT yowpdlibmain' +#ifdef W3_DEBUGINIT + Print *, 'Before MPI_INIT yowpdlibmain' +#endif call mpi_init(ierr) -!/DEBUGINIT Print *, 'After MPI_INIT yowpdlibmain' +#ifdef W3_DEBUGINIT + Print *, 'After MPI_INIT yowpdlibmain' +#endif if(ierr/=MPI_SUCCESS) call parallel_abort(error=ierr) endif @@ -688,7 +710,9 @@ subroutine findGhostNodes type(t_Node), pointer :: node, nodeNeighbor, nodeGhost !> temporary hold the ghost numbers integer, save, allocatable :: ghostTemp(:) -!/DEBUGINIT Print *, 'Passing in findGhostNodes' +#ifdef W3_DEBUGINIT + Print *, 'Passing in findGhostNodes' +#endif ! iterate over all local nodes and look at their neighbors ! has the neighbor another domain id, than it is a ghost @@ -715,7 +739,9 @@ subroutine findGhostNodes allocate(ghostTemp(ng), stat=stat) if(stat/=0) call parallel_abort('ghostTemp allocation failure') -!/DEBUGINIT Print *, 'np_global=', np_global +#ifdef W3_DEBUGINIT + Print *, 'np_global=', np_global +#endif IF (allocated(ghostgl)) THEN Print *, 'ghostgl is already allocated' END IF diff --git a/model/ftn/PDLIB/yowrankModule.ftn b/model/src/PDLIB/yowrankModule.F90 similarity index 100% rename from model/ftn/PDLIB/yowrankModule.ftn rename to model/src/PDLIB/yowrankModule.F90 diff --git a/model/ftn/PDLIB/yowsidepool.ftn b/model/src/PDLIB/yowsidepool.F90 similarity index 100% rename from model/ftn/PDLIB/yowsidepool.ftn rename to model/src/PDLIB/yowsidepool.F90 diff --git a/model/ftn/SCRIP/SCRIP.mk b/model/src/SCRIP/SCRIP.mk similarity index 96% rename from model/ftn/SCRIP/SCRIP.mk rename to model/src/SCRIP/SCRIP.mk index 6334ac0a7..61e3841b1 100644 --- a/model/ftn/SCRIP/SCRIP.mk +++ b/model/src/SCRIP/SCRIP.mk @@ -43,7 +43,7 @@ $(aPo)/scrip_timers.o: SCRIP/scrip_timers.f \ $(aPo)/scrip_kindsmod.o @$(aPb)/ad3 scrip_timers -$(aPo)/scrip_interface.o: SCRIP/scrip_interface.ftn \ +$(aPo)/scrip_interface.o: SCRIP/scrip_interface.F90 \ $(aPo)/scrip_kindsmod.o \ $(aPo)/scrip_constants.o \ $(aPo)/scrip_timers.o \ diff --git a/model/ftn/SCRIP/SCRIP_NC.mk b/model/src/SCRIP/SCRIP_NC.mk similarity index 97% rename from model/ftn/SCRIP/SCRIP_NC.mk rename to model/src/SCRIP/SCRIP_NC.mk index bed8cccfb..33fb6faf7 100644 --- a/model/ftn/SCRIP/SCRIP_NC.mk +++ b/model/src/SCRIP/SCRIP_NC.mk @@ -71,7 +71,7 @@ $(aPo)/scrip_remap_read.o: SCRIP/scrip_remap_read.f \ $(aPo)/scrip_iounitsmod.o @$(aPb)/ad3 scrip_remap_read -$(aPo)/scrip_interface.o: SCRIP/scrip_interface.ftn \ +$(aPo)/scrip_interface.o: SCRIP/scrip_interface.F90 \ $(aPo)/scrip_kindsmod.o \ $(aPo)/scrip_constants.o \ $(aPo)/scrip_timers.o \ diff --git a/model/ftn/SCRIP/scrip_constants.f b/model/src/SCRIP/scrip_constants.f similarity index 100% rename from model/ftn/SCRIP/scrip_constants.f rename to model/src/SCRIP/scrip_constants.f diff --git a/model/ftn/SCRIP/scrip_errormod.f90 b/model/src/SCRIP/scrip_errormod.f90 similarity index 100% rename from model/ftn/SCRIP/scrip_errormod.f90 rename to model/src/SCRIP/scrip_errormod.f90 diff --git a/model/ftn/SCRIP/scrip_grids.f b/model/src/SCRIP/scrip_grids.f similarity index 100% rename from model/ftn/SCRIP/scrip_grids.f rename to model/src/SCRIP/scrip_grids.f diff --git a/model/ftn/SCRIP/scrip_interface.ftn b/model/src/SCRIP/scrip_interface.F90 similarity index 88% rename from model/ftn/SCRIP/scrip_interface.ftn rename to model/src/SCRIP/scrip_interface.F90 index fd4813428..0e51775c0 100644 --- a/model/ftn/SCRIP/scrip_interface.ftn +++ b/model/src/SCRIP/scrip_interface.F90 @@ -338,8 +338,10 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) use scrip_remap_vars ! common remapping variables use scrip_remap_conservative ! routines for conservative remap -!/SCRIPNC use scrip_remap_write ! routines for remap output -!/SCRIPNC use scrip_remap_read ! routines for remap input +#ifdef W3_SCRIPNC + use scrip_remap_write ! routines for remap output + use scrip_remap_read ! routines for remap input +#endif use scrip_errormod @@ -391,11 +393,15 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) character (12), parameter :: & rtnName = 'SCRIP_driver' -!/SCRIPNC character (LEN=3) :: cdst ! 3 character number of destination map -!/SCRIPNC character (LEN=3) :: csrc ! 3 character number of source map -!/T38 CHARACTER (LEN=10) :: CDATE_TIME(3) -!/T38 INTEGER :: DATE_TIME(8) -!/T38 INTEGER :: ELAPSED_TIME, BEG_TIME, END_TIME +#ifdef W3_SCRIPNC + character (LEN=3) :: cdst ! 3 character number of destination map + character (LEN=3) :: csrc ! 3 character number of source map +#endif +#ifdef W3_T38 + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME, END_TIME +#endif !----------------------------------------------------------------------- ! @@ -403,7 +409,9 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) ! !----------------------------------------------------------------------- -!/T38 if(l_master)write(SCRIP_stdout,*)'subroutine scrip' +#ifdef W3_T38 + if(l_master)write(SCRIP_stdout,*)'subroutine scrip' +#endif call timers_init do n=1,max_timers @@ -419,16 +427,18 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) !----------------------------------------------------------------------- num_maps = 1 -!/SCRIPNC! Note: Only master does I/O, but all processors need to know about -!/SCRIPNC! file existence -!/SCRIPNC interp_file1 = "rmp_src_to_dst_conserv_XXX_XXX.nc" -!/SCRIPNC interp_file2 = 'not_used.nc' -!/SCRIPNC map1_name = 'source to destination Conservative Mapping' -!/SCRIPNC map2_name = 'map not used' -!/SCRIPNC write(cdst, "(i3.3)") dst_num -!/SCRIPNC write(csrc, "(i3.3)") src_num -!/SCRIPNC interp_file1(24:26) = csrc -!/SCRIPNC interp_file1(28:30) = cdst +#ifdef W3_SCRIPNC +! Note: Only master does I/O, but all processors need to know about +! file existence + interp_file1 = "rmp_src_to_dst_conserv_XXX_XXX.nc" + interp_file2 = 'not_used.nc' + map1_name = 'source to destination Conservative Mapping' + map2_name = 'map not used' + write(cdst, "(i3.3)") dst_num + write(csrc, "(i3.3)") src_num + interp_file1(24:26) = csrc + interp_file1(28:30) = cdst +#endif map_method = 'conservative' normalize_opt = 'fracarea' @@ -481,12 +491,16 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) ! !----------------------------------------------------------------------- -!/T38 if(l_master)write(SCRIP_stdout,*)'calling grid_init' +#ifdef W3_T38 + if(l_master)write(SCRIP_stdout,*)'calling grid_init' +#endif call grid_init( errorCode,l_master,l_test) -!/T38 if(l_master)write(SCRIP_stdout, *) 'Computing remappings between: ',grid1_name -!/T38 if(l_master)write(SCRIP_stdout, *) ' and ',grid2_name +#ifdef W3_T38 + if(l_master)write(SCRIP_stdout, *) 'Computing remappings between: ',grid1_name + if(l_master)write(SCRIP_stdout, *) ' and ',grid2_name +#endif !----------------------------------------------------------------------- ! @@ -500,30 +514,44 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) ! ! call appropriate interpolation setup routine based on type of ! remapping requested. or read in remapping data. -!/SCRIPNC!or, read in remapping data. +#ifdef W3_SCRIPNC +!or, read in remapping data. +#endif ! !----------------------------------------------------------------------- -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#endif -!/SCRIPNC if (l_read) then -!/SCRIPNC if(l_master)write(SCRIP_stdout, *) 'Reading remapping data from ', interp_file1 -!/SCRIPNC call read_remap_ww3(map1_name, interp_file1, errorCode) -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) -!/T38 elapsed_time = end_time - beg_time -!/T38 write(0,*) "SCRIP: READING ", elapsed_time, " MSEC" -!/SCRIPNC else +#ifdef W3_SCRIPNC + if (l_read) then + if(l_master)write(SCRIP_stdout, *) 'Reading remapping data from ', interp_file1 + call read_remap_ww3(map1_name, interp_file1, errorCode) +#endif +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: READING ", elapsed_time, " MSEC" +#endif +#ifdef W3_SCRIPNC + else +#endif select case(map_type) case(map_type_conserv) -!/T38 if(l_master)write(SCRIP_stdout,*)'calling remap_conserv' +#ifdef W3_T38 + if(l_master)write(SCRIP_stdout,*)'calling remap_conserv' +#endif call remap_conserv(l_master,l_test) -!/T38 if(l_master)write(SCRIP_stdout,*)'back from remap_conserv' -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) -!/T38 elapsed_time = end_time - beg_time -!/T38 write(0,*) "SCRIP: CALCULATING ", elapsed_time, " MSEC" +#ifdef W3_T38 + if(l_master)write(SCRIP_stdout,*)'back from remap_conserv' + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: CALCULATING ", elapsed_time, " MSEC" +#endif case default call SCRIP_ErrorSet(errorCode, rtnName, 'Invalid Map Type') call SCRIP_driverExit(errorCode, 'Invalid Map Type') @@ -535,8 +563,10 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) ! !----------------------------------------------------------------------- -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#endif if (num_links_map1 /= max_links_map1) then call resize_remap_vars(1, num_links_map1-max_links_map1) @@ -549,33 +579,43 @@ subroutine scrip(src_num, dst_num, l_master, l_read, l_test) !----------------------------------------------------------------------- ! -!/SCRIPNC! write remapping info to a file. +#ifdef W3_SCRIPNC +! write remapping info to a file. +#endif ! !----------------------------------------------------------------------- -!/SCRIPNC if (l_master) then -!/SCRIPNC write(SCRIP_stdout, *) 'Writing remapping data to ', interp_file1 -!/SCRIPNC endif +#ifdef W3_SCRIPNC + if (l_master) then + write(SCRIP_stdout, *) 'Writing remapping data to ', interp_file1 + endif +#endif -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) -!/T38 elapsed_time = end_time - beg_time -!/T38 write(0,*) "SCRIP: RESIZING ", elapsed_time, " MSEC" -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: RESIZING ", elapsed_time, " MSEC" + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#endif ! Use write_remap if you want the extra variables in the .nc files for diagnostics ! Use write_remap_ww3 if you don't want any extra variables in the .nc files -!/SCRIPNC if(l_test)then -!/SCRIPNC call write_remap(map1_name, map2_name, interp_file1, interp_file2, & -!/SCRIPNC output_opt, l_master, errorCode) -!/SCRIPNC else -!/SCRIPNC call write_remap_ww3(map1_name, interp_file1, output_opt, & -!/SCRIPNC l_master, errorCode) -!/SCRIPNC endif +#ifdef W3_SCRIPNC + if(l_test)then + call write_remap(map1_name, map2_name, interp_file1, interp_file2, & + output_opt, l_master, errorCode) + else + call write_remap_ww3(map1_name, interp_file1, output_opt, & + l_master, errorCode) + endif +#endif -!/SCRIPNC end if +#ifdef W3_SCRIPNC + end if +#endif !----------------------------------------------------------------------- diff --git a/model/ftn/SCRIP/scrip_iounitsmod.f90 b/model/src/SCRIP/scrip_iounitsmod.f90 similarity index 100% rename from model/ftn/SCRIP/scrip_iounitsmod.f90 rename to model/src/SCRIP/scrip_iounitsmod.f90 diff --git a/model/ftn/SCRIP/scrip_kindsmod.f90 b/model/src/SCRIP/scrip_kindsmod.f90 similarity index 100% rename from model/ftn/SCRIP/scrip_kindsmod.f90 rename to model/src/SCRIP/scrip_kindsmod.f90 diff --git a/model/ftn/SCRIP/scrip_netcdfmod.f90 b/model/src/SCRIP/scrip_netcdfmod.f90 similarity index 100% rename from model/ftn/SCRIP/scrip_netcdfmod.f90 rename to model/src/SCRIP/scrip_netcdfmod.f90 diff --git a/model/ftn/SCRIP/scrip_remap_conservative.f b/model/src/SCRIP/scrip_remap_conservative.f similarity index 100% rename from model/ftn/SCRIP/scrip_remap_conservative.f rename to model/src/SCRIP/scrip_remap_conservative.f diff --git a/model/ftn/SCRIP/scrip_remap_read.f b/model/src/SCRIP/scrip_remap_read.f similarity index 100% rename from model/ftn/SCRIP/scrip_remap_read.f rename to model/src/SCRIP/scrip_remap_read.f diff --git a/model/ftn/SCRIP/scrip_remap_vars.f b/model/src/SCRIP/scrip_remap_vars.f similarity index 100% rename from model/ftn/SCRIP/scrip_remap_vars.f rename to model/src/SCRIP/scrip_remap_vars.f diff --git a/model/ftn/SCRIP/scrip_remap_write.f b/model/src/SCRIP/scrip_remap_write.f similarity index 100% rename from model/ftn/SCRIP/scrip_remap_write.f rename to model/src/SCRIP/scrip_remap_write.f diff --git a/model/ftn/SCRIP/scrip_timers.f b/model/src/SCRIP/scrip_timers.f similarity index 100% rename from model/ftn/SCRIP/scrip_timers.f rename to model/src/SCRIP/scrip_timers.f diff --git a/model/ftn/constants.ftn b/model/src/constants.F90 similarity index 100% rename from model/ftn/constants.ftn rename to model/src/constants.F90 diff --git a/model/ftn/ctest.ftn b/model/src/ctest.F90 similarity index 100% rename from model/ftn/ctest.ftn rename to model/src/ctest.F90 diff --git a/model/ftn/gx_outf.ftn b/model/src/gx_outf.F90 similarity index 97% rename from model/ftn/gx_outf.ftn rename to model/src/gx_outf.F90 index 88d51b1da..02df371d8 100644 --- a/model/ftn/gx_outf.ftn +++ b/model/src/gx_outf.F90 @@ -121,7 +121,9 @@ PROGRAM GXOUTF USE W3IOGRMD, ONLY: W3IOGR USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 !/ USE W3GDATMD @@ -154,7 +156,9 @@ PROGRAM GXOUTF IX0, IXN, IY0, IYN, TIME0(2), IH0, & IM0, ID0, IID, IJ0, IOTEST, IINC, IU,& TIMEN(2), JLEN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTREQ, DTEST REAL :: FAC, XYMAX CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & @@ -195,7 +199,9 @@ PROGRAM GXOUTF WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) -!/S CALL STRACE (IENT, 'GXOUTF') +#ifdef W3_S + CALL STRACE (IENT, 'GXOUTF') +#endif ! JLEN = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:JLEN)//'gx_outf.inp',STATUS='OLD', & @@ -494,10 +500,12 @@ PROGRAM GXOUTF WRITE (NDSCTL,991) 'wlv ', 0, IU, 'Water Level (m)' IF ( FLREQ(01,06) ) & WRITE (NDSCTL,991) 'ice ', 0, IU, 'Ice Conc. (-) ' -!/IS2 IF (FLREQ(01,09) ) & -!/IS2 WRITE (NDSCTL,991) 'ic1 ', 0, IU, 'Ice thick. (m) ' -!/IS2 IF (FLREQ(01,10) ) & -!/IS2 WRITE (NDSCTL,991) 'ic5 ', 0, IU, 'Floe diam. (m) ' +#ifdef W3_IS2 + IF (FLREQ(01,09) ) & + WRITE (NDSCTL,991) 'ic1 ', 0, IU, 'Ice thick. (m) ' + IF (FLREQ(01,10) ) & + WRITE (NDSCTL,991) 'ic5 ', 0, IU, 'Floe diam. (m) ' +#endif IF ( FLREQ(02,01) ) & WRITE (NDSCTL,991) 'hs ', 0, IU, 'Wave height (m)' IF ( FLREQ(02,02) ) & @@ -692,11 +700,13 @@ PROGRAM GXOUTF ' ========================================='/ & ' WAVEWATCH III GrADS field output '/) ! -!/T 9050 FORMAT ( ' TEST GXOUTF : KPDS : ',13I4/ & -!/T ' ',12I4) -!/T 9051 FORMAT ( ' TEST GXOUTF : KGDS : ',8I6/ & -!/T ' ',8I6/ & -!/T ' ',6I6) +#ifdef W3_T + 9050 FORMAT ( ' TEST GXOUTF : KPDS : ',13I4/ & + ' ',12I4) + 9051 FORMAT ( ' TEST GXOUTF : KGDS : ',8I6/ & + ' ',8I6/ & + ' ',6I6) +#endif ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN GXOUTF : '/ & ' ERROR IN OPENING INPUT FILE'/ & @@ -820,16 +830,22 @@ SUBROUTINE GXEXGO ( NX, NY, NSEA ) INTEGER :: MAPXCL(NY,NX), MAPDRY(NY,NX), & MAPICE(NY,NX), MAPLND(NY,NX), & MAPMSK(NY,NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: X1(NX,NY), XX(NX,NY), XY(NX,NY), & XA(NX,NY,0:NOSWLL) REAL :: VALLND = 0.001 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GXEXGO') +#ifdef W3_S + CALL STRACE (IENT, 'GXEXGO') +#endif ! -!/T WRITE (NDST,9000) ((FLREQ(J,K),J=1,NOGRP), K=1,NGRPP) +#ifdef W3_T + WRITE (NDST,9000) ((FLREQ(J,K),J=1,NOGRP), K=1,NGRPP) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. Preparations @@ -926,7 +942,9 @@ SUBROUTINE GXEXGO ( NX, NY, NSEA ) FLTRI = .FALSE. FLPRT = .FALSE. ! -!/T WRITE (NDST,9020) IDOUT(J,K) +#ifdef W3_T + WRITE (NDST,9020) IDOUT(J,K) +#endif ! ! 2.a Set output arrays and parameters ! @@ -991,15 +1009,19 @@ SUBROUTINE GXEXGO ( NX, NY, NSEA ) ! ! Ice thickness ! -!/IS2 ELSE IF ( J.EQ.1 .AND. K.EQ.11 ) THEN -!/IS2 FLONE = .TRUE. -!/IS2 CALL W3S2XY (NSEA, NSEA, NX, NY, ICEH , MAPSF, X1 ) +#ifdef W3_IS2 + ELSE IF ( J.EQ.1 .AND. K.EQ.11 ) THEN + FLONE = .TRUE. + CALL W3S2XY (NSEA, NSEA, NX, NY, ICEH , MAPSF, X1 ) +#endif ! ! Average sea ice floe diameter ! -!/IS2 ELSE IF ( J.EQ.1 .AND. K.EQ.12) THEN -!/IS2 FLONE = .TRUE. -!/IS2 CALL W3S2XY (NSEA, NSEA, NX, NY, ICEF , MAPSF, X1 ) +#ifdef W3_IS2 + ELSE IF ( J.EQ.1 .AND. K.EQ.12) THEN + FLONE = .TRUE. + CALL W3S2XY (NSEA, NSEA, NX, NY, ICEF , MAPSF, X1 ) +#endif ! ! ! Significant wave height @@ -1393,9 +1415,13 @@ SUBROUTINE GXEXGO ( NX, NY, NSEA ) 999 FORMAT (/' *** WAVEWATCH III ERROR IN GXEXGO :'/ & ' PLEASE UPDATE FIELDS !!! '/) ! -!/T 9000 FORMAT (' TEST GXEXGO : FLAGS :',40L2) +#ifdef W3_T + 9000 FORMAT (' TEST GXEXGO : FLAGS :',40L2) +#endif ! -!/T 9020 FORMAT (' TEST GXEXGO : OUTPUT FIELD : ',A) +#ifdef W3_T + 9020 FORMAT (' TEST GXEXGO : OUTPUT FIELD : ',A) +#endif !/ !/ End of GXEXGO ----------------------------------------------------- / !/ diff --git a/model/ftn/gx_outp.ftn b/model/src/gx_outp.F90 similarity index 73% rename from model/ftn/gx_outp.ftn rename to model/src/gx_outp.F90 index 8d8c4c663..e9def5d37 100644 --- a/model/ftn/gx_outp.ftn +++ b/model/src/gx_outp.F90 @@ -138,12 +138,16 @@ PROGRAM GXOUTP !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG USE W3WDATMD, ONLY: W3SETW, W3NDAT -!/NL1 USE W3ADATMD, ONLY: W3SETA, W3NAUX +#ifdef W3_NL1 + USE W3ADATMD, ONLY: W3SETA, W3NAUX +#endif USE W3ODATMD, ONLY: W3SETO, W3NOUT USE W3IOGRMD, ONLY: W3IOGR USE W3IOPOMD, ONLY: W3IOPO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 !/ USE W3GDATMD @@ -151,7 +155,9 @@ PROGRAM GXOUTP USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE, & GRDID, ICEO, ICEHO, ICEFO -!/FLX5 USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#ifdef W3_FLX5 + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif ! IMPLICIT NONE !/ @@ -164,7 +170,9 @@ PROGRAM GXOUTP NREQ, IPOINT, NLEV, IOUT, TIME0(2), & IH0, IM0, ID0, IID, IJ0, IINC, IK, & IREQ, TIMEN(2), J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTREQ, DTEST REAL :: UNDEFP = -99.E20 REAL :: FACT @@ -197,8 +205,10 @@ PROGRAM GXOUTP CALL W3SETG ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) CALL W3SETW ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -215,7 +225,9 @@ PROGRAM GXOUTP WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) -!/S CALL STRACE (IENT, 'GXOUTP') +#ifdef W3_S + CALL STRACE (IENT, 'GXOUTP') +#endif ! J = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:J)//'gx_outp.inp',STATUS='OLD', & @@ -619,35 +631,89 @@ SUBROUTINE GXEXPO ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/FLX1 USE W3FLX1MD -!/FLX2 USE W3FLX2MD -!/FLX3 USE W3FLX3MD -!/FLX4 USE W3FLX4MD -!/FLX5 USE W3FLX5MD -!/LN1 USE W3SLN1MD -!/ST1 USE W3SRC1MD -!/ST2 USE W3SRC2MD -!/ST3 USE W3SRC3MD -!/ST4 USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 -!/ST6 USE W3SRC6MD -!/ST6 USE W3SWLDMD, ONLY : W3SWL6 -!/ST6 USE W3GDATMD, ONLY : SWL6S6 -!/NL1 USE W3SNL1MD -!/NL2 USE W3SNL2MD -!/NL3 USE W3SNL3MD -!/NL4 USE W3SNL4MD -!/NLS USE W3SNLSMD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/IC4 USE W3SIC4MD -!/IC5 USE W3SIC5MD -!/DB1 USE W3SDB1MD -!/BS1 USE W3SBS1MD -!/IS2 USE W3SIS2MD +#ifdef W3_FLX1 + USE W3FLX1MD +#endif +#ifdef W3_FLX2 + USE W3FLX2MD +#endif +#ifdef W3_FLX3 + USE W3FLX3MD +#endif +#ifdef W3_FLX4 + USE W3FLX4MD +#endif +#ifdef W3_FLX5 + USE W3FLX5MD +#endif +#ifdef W3_LN1 + USE W3SLN1MD +#endif +#ifdef W3_ST1 + USE W3SRC1MD +#endif +#ifdef W3_ST2 + USE W3SRC2MD +#endif +#ifdef W3_ST3 + USE W3SRC3MD +#endif +#ifdef W3_ST4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 +#endif +#ifdef W3_ST6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 +#endif +#ifdef W3_NL1 + USE W3SNL1MD +#endif +#ifdef W3_NL2 + USE W3SNL2MD +#endif +#ifdef W3_NL3 + USE W3SNL3MD +#endif +#ifdef W3_NL4 + USE W3SNL4MD +#endif +#ifdef W3_NLS + USE W3SNLSMD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_IC4 + USE W3SIC4MD +#endif +#ifdef W3_IC5 + USE W3SIC5MD +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BS1 + USE W3SBS1MD +#endif +#ifdef W3_IS2 + USE W3SIS2MD +#endif !/ USE W3DISPMD, ONLY: LIU_FORWARD_DISPERSION, NAR1D, DFAC, N1MAX, & ECG1, EWN1, DSIE @@ -659,7 +725,9 @@ SUBROUTINE GXEXPO !/ INTEGER :: J, I1, I2, IK, ITH, ISPEC, IKM, IKL, & IKH, ITT, IX, IY, ISEA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: XL, XH, XL2, XH2, DEPTH, SQRTH, UDIR,& UDIRR, UABS, CDIR, SIX, R1, R2, ET, & EWN, ETR, ETX, ETY, EBND, EBX, EBY, & @@ -668,20 +736,42 @@ SUBROUTINE GXEXPO FACTOR, CD, USTAR, FHIGH, ZWND, ICE, & USTD, Z0, CHARN, EMEAN, FMEAN, WNMEAN,& ICETHICK, ICECON, ICEF -!/FLX5 REAL ::TAUA, TAUADIR, RHOAIR -!/IS2 REAL :: ICEDMAX -!/ST1 REAL :: AMAX, FH1, FH2 -!/ST2 REAL :: AMAX, ALPHA(NK), FPI -!/ST3 REAL :: FMEANS, FMEANWS, TAUWX, TAUWY, AMAX, & -!/ST3 TAUWNX, TAUWNY -!/ST4 REAL :: FMEANWS, TAUWX, TAUWY, AMAX, & -!/ST4 TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN -!/ST6 REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY -!/BS1 REAL :: TAUSCX, TAUSCY -!/BT3 REAL :: D50 -!/BT4 REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) -!/STAB2 REAL :: STAB0, STAB, THARG1, THARG2, COR1, & -!/STAB2 COR2, ASFAC +#ifdef W3_FLX5 + REAL ::TAUA, TAUADIR, RHOAIR +#endif +#ifdef W3_IS2 + REAL :: ICEDMAX +#endif +#ifdef W3_ST1 + REAL :: AMAX, FH1, FH2 +#endif +#ifdef W3_ST2 + REAL :: AMAX, ALPHA(NK), FPI +#endif +#ifdef W3_ST3 + REAL :: FMEANS, FMEANWS, TAUWX, TAUWY, AMAX, & + TAUWNX, TAUWNY +#endif +#ifdef W3_ST4 + REAL :: FMEANWS, TAUWX, TAUWY, AMAX, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN +#endif +#ifdef W3_ST6 + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY +#endif +#ifdef W3_BS1 + REAL :: TAUSCX, TAUSCY +#endif +#ifdef W3_BT3 + REAL :: D50 +#endif +#ifdef W3_BT4 + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) +#endif +#ifdef W3_STAB2 + REAL :: STAB0, STAB, THARG1, THARG2, COR1, & + COR2, ASFAC +#endif REAL :: HSMIN = 0.05 REAL :: WN(NK), CG(NK), E(NK,NTH), E1(NK), & APM(NK), THBND(NK), SPBND(NK), & @@ -695,14 +785,20 @@ SUBROUTINE GXEXPO XBT(NTH,NK), XBS(NTH,NK), XXX(NTH,NK),& XWL(NTH,NK), XIS(NTH,NK) LOGICAL :: LBREAK -!/ST3 LOGICAL :: LLWS(NTH,NK) -!/ST4 LOGICAL :: LLWS(NTH,NK) -!/ST4 REAL :: LAMBDA(NSPEC) +#ifdef W3_ST3 + LOGICAL :: LLWS(NTH,NK) +#endif +#ifdef W3_ST4 + LOGICAL :: LLWS(NTH,NK) + REAL :: LAMBDA(NSPEC) +#endif CHARACTER :: DTME21*23 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GXEXPO') +#ifdef W3_S + CALL STRACE (IENT, 'GXEXPO') +#endif ! XL = 1./XFR - 1. XH = XFR - 1. @@ -722,8 +818,10 @@ SUBROUTINE GXEXPO XIS = 0. XXX = 0. ! -!/T WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) -!/T WRITE (NDST,9001) FLSRCE +#ifdef W3_T + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) FLSRCE +#endif ! ! Output of time ! @@ -736,7 +834,9 @@ SUBROUTINE GXEXPO DO J=1, NOPTS IF ( FLREQ(J) ) THEN ! -!/T WRITE (NDST,9002) PTNME(J) +#ifdef W3_T + WRITE (NDST,9002) PTNME(J) +#endif ! ! 2. Calculate grid parameters using and inlined version of WAVNU1. ! @@ -745,26 +845,38 @@ SUBROUTINE GXEXPO UDIR = MOD ( 270. - WDO(J)*RADE , 360. ) UDIRR = WDO(J) UABS = MAX ( 0.001 , WAO(J) ) -!/FLX5 TAUA = MAX ( 0.001 , TAUAO(J)) -!/FLX5 TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) -!/FLX5 RHOAIR = MAX ( 0. , DAIRO(J)) +#ifdef W3_FLX5 + TAUA = MAX ( 0.001 , TAUAO(J)) + TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) + RHOAIR = MAX ( 0. , DAIRO(J)) +#endif CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) -!/IS2 ICEDMAX = MAX ( 0., ICEFO(J)) -!/IC2 ICEF = 0. -!/IS2 ICEF = ICEDMAX +#ifdef W3_IS2 + ICEDMAX = MAX ( 0., ICEFO(J)) +#endif +#ifdef W3_IC2 + ICEF = 0. +#endif +#ifdef W3_IS2 + ICEF = ICEDMAX +#endif ICETHICK = MAX (0., ICEHO(J)) ICECON = MAX (0., ICEO(J)) ! -!/STAB2 STAB0 = ZWIND * GRAV / 273. -!/STAB2 STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 -!/STAB2 STAB = MAX ( -1. , MIN ( 1. , STAB ) ) -!/STAB2 THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) -!/STAB2 THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) -!/STAB2 COR1 = CCNG * TANH(THARG1) -!/STAB2 COR2 = CCPS * TANH(THARG2) -!/STAB2 ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -! -!/T WRITE (NDST,9010) DEPTH +#ifdef W3_STAB2 + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif +! +#ifdef W3_T + WRITE (NDST,9010) DEPTH +#endif DO IK=1, NK SIX = SIG(IK) * SQRTH I1 = INT(SIX/DSIE) @@ -778,7 +890,9 @@ SUBROUTINE GXEXPO WN(IK) = SIG(IK)*SIG(IK)/GRAV CG(IK) = 0.5 * GRAV / SIG(IK) END IF -!/T WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#ifdef W3_T + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#endif ! END DO @@ -898,152 +1012,260 @@ SUBROUTINE GXEXPO END DO END DO ! -!/STAB2 UABS = UABS / ASFAC -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST3 ZWND = ZZWND -!/ST3 TAUWX = 0. -!/ST3 TAUWY = 0. -!/ST3 LLWS(:,:) = .TRUE. +#ifdef W3_STAB2 + UABS = UABS / ASFAC +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST3 + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:,:) = .TRUE. +#endif USTAR = 1. -!/ST4 ZWND = ZZWND -!/ST4 TAUWX = 0. -!/ST4 TAUWY = 0. -!/ST6 ZWND = 10. -! -!/ST0 FHIGH = SIG(NK) -!/ST1 CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST1 FH1 = FXFM * FMEAN -!/ST1 FH2 = FXPM / USTAR -!/ST1 FHIGH = MAX ( FH1 , FH2 ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST6 CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -! -!/FLX1 CALL W3FLX1 ( ZWND, UABS, UDIRR, & -!/FLX1 USTAR, USTD, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & -!/FLX5 RHOAIR, USTAR, USTD, Z0, CD ) +#ifdef W3_ST4 + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif +! +#ifdef W3_ST0 + FHIGH = SIG(NK) +#endif +#ifdef W3_ST1 + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) +#endif +#ifdef W3_ST2 + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif +! +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD ) +#endif ! DO ITT=1, 3 -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XWI, DIA ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST3 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & -!/ST3 TAUWNX, TAUWNY, & -!/ST3 ICE, XWI, DIA, LLWS, IX, IY ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST4 CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST4 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & -!/ST4 TAUWNX, TAUWNY, XWI, DIA, LLWS, IX, IY, LAMBDA ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XWI, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & + TAUWNX, TAUWNY, & + ICE, XWI, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) +#endif +#ifdef W3_ST4 + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, & + TAUWNX, TAUWNY, XWI, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif END DO ! -!/ST2 FHIGH = XFC * FPI +#ifdef W3_ST2 + FHIGH = XFC * FPI +#endif ! IF ( FLSRCE(2) ) THEN -!/LN1 CALL W3SLN1 ( WN, FHIGH, USTAR, UDIRR, XLN ) -! -!/ST1 CALL W3SIN1 (A, WN2, USTAR, UDIRR, XWI, DIA ) -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XWI, DIA ) -!/ST3 CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST3 ASO(J), UDIRR, Z0, CD, & -!/ST3 TAUWX, TAUWY, TAUWNX, TAUWNY, & -!/ST3 ICE, XWI, DIA, LLWS, IX, IY ) -!/ST4 CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST4 ASO(J), UDIRR, Z0, CD, & -!/ST4 TAUWX, TAUWY, TAUWNX, TAUWNY, & -!/ST4 XWI, DIA, LLWS, IX, IY, LAMBDA ) -!/ST6 CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, & -!/ST6 DAIR, TAUWX, TAUWY, TAUWNX, TAUWNY, XWI, DIA ) +#ifdef W3_LN1 + CALL W3SLN1 ( WN, FHIGH, USTAR, UDIRR, XLN ) +#endif +! +#ifdef W3_ST1 + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XWI, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XWI, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SIN3 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, & + ICE, XWI, DIA, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, & + TAUWX, TAUWY, TAUWNX, TAUWNY, & + XWI, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_ST6 + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, & + DAIR, TAUWX, TAUWY, TAUWNX, TAUWNY, XWI, DIA ) +#endif END IF IF ( FLSRCE(3) ) THEN -!/NL1 CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) -!/NL2 CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) -!/NL3 CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) -!/NL4 CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#ifdef W3_NL1 + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL2 + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL3 + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL4 + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif !!/NLS CALL W3SNLS ( A, CG, WN, DEPTH, UABS, 900., & !!/NLS SNL=XNL, AA=DIA ) ! END IF IF ( FLSRCE(4) ) THEN -!/ST1 CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, XDS, DIA ) -!/ST2 CALL W3SDS2 ( A, CG, WN, FPI, USTAR, ALPHA, XDS, DIA ) -!/ST3 CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & -!/ST3 USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) -!/ST4 CALL W3SDS4 ( A, WN, CG, & -!/ST4 USTAR, USTD, DEPTH, DAIR, XDS, DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) -!/ST6 CALL W3SDS6 ( A, CG, WN, XDS, DIA ) -!/ST6 IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) -! -!/DB1 CALL W3SDB1 ( J, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, & -!/DB1 LBREAK, XDB, DIA ) +#ifdef W3_ST1 + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, XDS, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, ALPHA, XDS, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SDS4 ( A, WN, CG, & + USTAR, USTD, DEPTH, DAIR, XDS, DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) +#endif +#ifdef W3_ST6 + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) +#endif +! +#ifdef W3_DB1 + CALL W3SDB1 ( J, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, & + LBREAK, XDB, DIA ) +#endif ! END IF IF ( FLSRCE(5) ) THEN -!/BT1 CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) +#ifdef W3_BT1 + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) +#endif -!/IC1 CALL W3SIC1 ( A, DEPTH, CG, IX, IY, XBT, DIA ) -!/IC2 CALL W3SIC2 ( A, DEPTH, ICETHICK, ICEF ,CG, WN, IX, IY, XBT, DIA, WN_R, & -!/IC2 CG_ICE, ALPHA_LIU, R ) -!/IC3 CALL W3SIC3 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) -!/IC4 CALL W3SIC4 ( A, DEPTH, CG, IX, IY, XBT, DIA ) -!/IC5 CALL W3SIC5 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) +#ifdef W3_IC1 + CALL W3SIC1 ( A, DEPTH, CG, IX, IY, XBT, DIA ) +#endif +#ifdef W3_IC2 + CALL W3SIC2 ( A, DEPTH, ICETHICK, ICEF ,CG, WN, IX, IY, XBT, DIA, WN_R, & + CG_ICE, ALPHA_LIU, R ) +#endif +#ifdef W3_IC3 + CALL W3SIC3 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) +#endif +#ifdef W3_IC4 + CALL W3SIC4 ( A, DEPTH, CG, IX, IY, XBT, DIA ) +#endif +#ifdef W3_IC5 + CALL W3SIC5 ( A, DEPTH, CG, WN, IX, IY, XBT, DIA ) +#endif -!/BT4 IX=1 ! to be fixed later -!/BT4 IY=1 ! to be fixed later -!/BT4 ISEA=1 ! to be fixed later -!/BT4 D50 = SED_D50(ISEA) -!/BT4 PSIC= SED_PSIC(ISEA) +#ifdef W3_BT4 + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) +#endif -!/BT4 CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & -!/BT4 BEDFORM, XBT, DIA, IX, IY ) +#ifdef W3_BT4 + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) +#endif ! -!/BT8 CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) +#ifdef W3_BT8 + CALL W3SBT8 ( A, DEPTH, XBT, DIA, IX, IY ) +#endif -!/BS1 CALL W3SBS1 ( A, CG, WN, DEPTH, CAO(J)*COS(CDO(J)), & -!/BS1 CAO(J)*SIN(CDO(J)), & -!/BS1 TAUSCX, TAUSCY, XBS, DIA ) +#ifdef W3_BS1 + CALL W3SBS1 ( A, CG, WN, DEPTH, CAO(J)*COS(CDO(J)), & + CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) +#endif END IF IF ( FLSRCE(6) ) THEN -!/IS2 CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, IX, IY, & -!/IS2 XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#ifdef W3_IS2 + CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, IX, IY, & + XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#endif END IF ! -!/STAB2 UABS = UABS * ASFAC +#ifdef W3_STAB2 + UABS = UABS * ASFAC +#endif ! DO IK=1, NK FACTOR = TPI / CG(IK) * SIG(IK) @@ -1053,7 +1275,9 @@ SUBROUTINE GXEXPO SWI(IK,ITH) = ( XWI(ITH,IK) + XLN(ITH,IK) ) * FACTOR SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR -!/ST6 SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#ifdef W3_ST6 + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#endif SBT(IK,ITH) = ( XBT(ITH,IK) + XBS(ITH,IK) ) * FACTOR SIS(IK,ITH) = XIS(ITH,IK) * FACTOR STT(IK,ITH) = XXX(ITH,IK) * FACTOR @@ -1109,11 +1333,13 @@ SUBROUTINE GXEXPO 941 FORMAT (A10,1X,2F8.1,f7.1,3F7.1,F8.2,3F7.2,F6.2,2X,A) ! -!/T 9000 FORMAT (' TEST GXEXPO : FLAGS :',40L2) -!/T 9001 FORMAT (' TEST GXEXPO : FLSRCE :',6L2) -!/T 9002 FORMAT (' TEST GXEXPO : OUTPUT POINT : ',A) -!/T 9010 FORMAT (' TEST GXEXPO : DEPTH =',F7.1,' IK, T, K, CG :') -!/T 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#ifdef W3_T + 9000 FORMAT (' TEST GXEXPO : FLAGS :',40L2) + 9001 FORMAT (' TEST GXEXPO : FLSRCE :',6L2) + 9002 FORMAT (' TEST GXEXPO : OUTPUT POINT : ',A) + 9010 FORMAT (' TEST GXEXPO : DEPTH =',F7.1,' IK, T, K, CG :') + 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif !/ !/ End of GXEXPO ----------------------------------------------------- / !/ diff --git a/model/ftn/mod_constants.f90 b/model/src/mod_constants.f90 similarity index 100% rename from model/ftn/mod_constants.f90 rename to model/src/mod_constants.f90 diff --git a/model/ftn/mod_fileio.f90 b/model/src/mod_fileio.f90 similarity index 100% rename from model/ftn/mod_fileio.f90 rename to model/src/mod_fileio.f90 diff --git a/model/ftn/mod_xnl4v5.f90 b/model/src/mod_xnl4v5.f90 similarity index 100% rename from model/ftn/mod_xnl4v5.f90 rename to model/src/mod_xnl4v5.f90 diff --git a/model/ftn/pdlib_field_vec.ftn b/model/src/pdlib_field_vec.F90 similarity index 87% rename from model/ftn/pdlib_field_vec.ftn rename to model/src/pdlib_field_vec.F90 index cd68e1ea5..3435cc1b0 100644 --- a/model/ftn/pdlib_field_vec.ftn +++ b/model/src/pdlib_field_vec.F90 @@ -95,7 +95,9 @@ SUBROUTINE GET_ARRAY_SIZE(TheSize) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY: FLOGRD, FLOGR2, NOSWLL, NOEXTR, & NOGRP, NGRPP @@ -430,7 +432,9 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowDatapool, only: istatus @@ -442,7 +446,9 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) USE W3GDATMD, ONLY: NSEAL USE W3ADATMD, ONLY: NSEALM USE W3SERVMD, ONLY : EXTCDE -!/TIMINGS USE W3PARALL, ONLY: PRINT_MY_TIME +#ifdef W3_TIMINGS + USE W3PARALL, ONLY: PRINT_MY_TIME +#endif use yowNodepool, only: ListNP, ListNPA, ListIPLG IMPLICIT NONE INCLUDE "mpif.h" @@ -453,7 +459,9 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -474,17 +482,25 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) integer IPloc, IPglob, pos integer NbMatch, idx integer ListFirst(NAPROC) -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! -!/DEBUGIO WRITE(740+IAPROC,*) 'UNST_PDLIB_READ, Beginning of function' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'UNST_PDLIB_READ, Beginning of function' + FLUSH(740+IAPROC) +#endif LRECL = MAX ( LRB*NSPEC , & LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) -!/DEBUGIO WRITE(740+IAPROC,*) 'UNST_PDLIB_READ, LRB=', LRB, ' LRECL=', LRECL -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'UNST_PDLIB_READ, LRB=', LRB, ' LRECL=', LRECL + FLUSH(740+IAPROC) +#endif IF (IAPROC .gt. NAPROC) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'Leaving bc rank IAPROC > NAPROC=', NAPROC -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Leaving bc rank IAPROC > NAPROC=', NAPROC + FLUSH(740+IAPROC) +#endif RETURN END IF ListFirst(1)=0 @@ -508,10 +524,14 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) DO iBlock=1,nbBlock iFirst = 1 + (iBlock - 1)*BlockSize iEnd = MIN(iBlock * BlockSize, NSEA) -!/TIMINGS CALL PRINT_MY_TIME("Beginning of iBlock value treatment") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Beginning of iBlock value treatment") +#endif -!/DEBUGIO WRITE(740+IAPROC,*) 'R : iBlock=', iBlock, '/', nbBlock, 'iFirst=', iFirst, 'iEnd=', iEnd -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'R : iBlock=', iBlock, '/', nbBlock, 'iFirst=', iFirst, 'iEnd=', iEnd + FLUSH(740+IAPROC) +#endif ! Let's try to get the indexes right. ! We have 1 <= IB <= len = iEnd + 1 - iFirst ! We have iFirst - 1 = (iBlock - 1)*BlockSize @@ -519,7 +539,9 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) ! and thus iFirst <= ISEA <= iEnd len=iEnd + 1 - iFirst IF (IAPROC .eq. 1) THEN -!/TIMINGS CALL PRINT_MY_TIME("Before data reading") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before data reading") +#endif DO IB=1,len ISEA = (iBlock - 1)*BlockSize + IB NREC = ISEA + 2 @@ -528,10 +550,14 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) !!/DEBUGIO FLUSH(740+IAPROC) READ (NDREAD, POS=RPOS, IOSTAT=IERR) (DATAread(I,IB), I=1,NSPEC) END DO -!/TIMINGS CALL PRINT_MY_TIME("After data reading") -!/DEBUGIO WRITE(740+IAPROC,*) 'After the block of reads' -!/DEBUGIO WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, ' sum(DATAread)=', sum(DATAread) -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After data reading") +#endif +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After the block of reads' + WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, ' sum(DATAread)=', sum(DATAread) + FLUSH(740+IAPROC) +#endif DO iProc=2,NAPROC NbMatch=0 DO IPloc=1,ListNPA(iProc) @@ -540,8 +566,10 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) NbMatch = NbMatch+1 END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'Sending to iProc=', iProc, ' NbMatch=', NbMatch -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Sending to iProc=', iProc, ' NbMatch=', NbMatch + FLUSH(740+IAPROC) +#endif IF (NbMatch .gt. 0) THEN allocate(ArrSend(NSPEC,NbMatch), stat=istat) ArrSend = 0. @@ -565,7 +593,9 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) VA(:,IPloc) = DATAread(:,pos) END IF END DO -!/TIMINGS CALL PRINT_MY_TIME("After the sending") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After the sending") +#endif ELSE NbMatch=0 DO IPloc=1,ListNPA(IAPROC) @@ -574,8 +604,10 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) NbMatch = NbMatch+1 END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'Receiving NbMatch=', NbMatch -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Receiving NbMatch=', NbMatch + FLUSH(740+IAPROC) +#endif IF (NbMatch .gt. 0) THEN allocate(ArrSend(NSPEC,NbMatch), stat=istat) CALL MPI_RECV(ArrSend,NSPEC*NbMatch,MPI_REAL, 0, 37, MPI_COMM_WAVE, istatus, ierr) @@ -590,17 +622,21 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) deallocate(ArrSend) END IF END IF -!/TIMINGS CALL PRINT_MY_TIME("Beginning of iBlock value treatment") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Beginning of iBlock value treatment") +#endif END DO IF (IAPROC .eq. 1) THEN deallocate(DATAread) END IF -!/DEBUGIO IF (IAPROC .le. NAPROC) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, ' sum(VA)=', sum(VA) -!/DEBUGIO FLUSH(740+IAPROC) -!/DEBUGIO END IF -!/DEBUGIO WRITE(740+IAPROC,*) 'Exiting READ_FROM_FILE' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + IF (IAPROC .le. NAPROC) THEN + WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, ' sum(VA)=', sum(VA) + FLUSH(740+IAPROC) + END IF + WRITE(740+IAPROC,*) 'Exiting READ_FROM_FILE' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) @@ -648,7 +684,9 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowDatapool, only: istatus USE yowNodepool, only: ListNP, ListNPA, ListIPLG @@ -668,7 +706,9 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -690,37 +730,53 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) INTEGER IERR_MPI REAL(KIND=LRB) WRITEBUFF(NSPEC) REAL, allocatable :: DATAsend(:,:) -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') -!/DEBUGIO WRITE(740+IAPROC,*) 'Beginning of UNST_PDLIB_WRITE_TO_FILE IAPROC=', IAPROC, 'NAPRST=', NAPRST -!/DEBUGIO FLUSH(740+IAPROC) -!/DEBUGIO WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Beginning of UNST_PDLIB_WRITE_TO_FILE IAPROC=', IAPROC, 'NAPRST=', NAPRST + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) + FLUSH(740+IAPROC) +#endif ListFirst(1) = 0 DO IPROC=2,NAPROC ListFirst(iProc)=ListFirst(iProc-1) + ListNPA(iProc-1) END DO ! -!/DEBUGIO WRITE(740+IAPROC,*) 'NX=', NX, ' NY=', NY, ' NSEA=', NSEA -!/DEBUGIO WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'NX=', NX, ' NY=', NY, ' NSEA=', NSEA + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC +#endif LRECL = MAX ( LRB*NSPEC , & LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) -!/DEBUGIO WRITE(740+IAPROC,*) 'UNST_PDLIB_WRITE, LRB=', LRB, ' LRECL=', LRECL -!/DEBUGIO WRITE(740+IAPROC,*) 'NDWRITE=', NDWRITE, 'NAPROC=', NAPROC, 'NTPROC=', NTPROC -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'UNST_PDLIB_WRITE, LRB=', LRB, ' LRECL=', LRECL + WRITE(740+IAPROC,*) 'NDWRITE=', NDWRITE, 'NAPROC=', NAPROC, 'NTPROC=', NTPROC + FLUSH(740+IAPROC) +#endif nbBlock=NSEA / BlockSize + 1 -!/DEBUGIO WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' BlockSize=', BlockSize +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' BlockSize=', BlockSize +#endif DO iBlock=1,nbBlock iFirst= 1 + (iBlock - 1)*BlockSize iEnd= MIN(iBlock * BlockSize, NSEA) len=iEnd + 1 - iFirst -!/DEBUGIO WRITE(740+IAPROC,*) 'W : iBlock=', iBlock, '/', nbBlock, 'iFirst=', iFirst, 'iEnd=', iEnd, ' len=', len -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W : iBlock=', iBlock, '/', nbBlock, 'iFirst=', iFirst, 'iEnd=', iEnd, ' len=', len + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. NAPRST) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'The Node is a restart writing node' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'The Node is a restart writing node' + FLUSH(740+IAPROC) +#endif IF (IAPROC .le. NAPROC) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'It is also a running node' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'It is also a running node' + FLUSH(740+IAPROC) +#endif DO JSEA=1,NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) IF ((iFirst .le. ISEA).and.(ISEA .le. iEnd)) THEN @@ -729,15 +785,21 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) END IF END DO END IF -!/DEBUGIO WRITE(740+IAPROC,*) 'Now iterating over all the nodes for RECV' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Now iterating over all the nodes for RECV' + FLUSH(740+IAPROC) +#endif DO iProc=1,NAPROC -!/DEBUGIO WRITE(740+IAPROC,*) 'iProc=', iProc, ' / ', NAPROC -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'iProc=', iProc, ' / ', NAPROC + FLUSH(740+IAPROC) +#endif IF (iProc .ne. IAPROC) THEN NPAloc=ListNPA(iProc) -!/DEBUGIO WRITE(740+IAPROC,*) 'We found NPAloc=', NPAloc -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'We found NPAloc=', NPAloc + FLUSH(740+IAPROC) +#endif NbMatch=0 DO IPloc=1,NPAloc IPglob = ListIPLG(ListFirst(iProc) + IPloc) @@ -747,11 +809,15 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) END DO IF (NbMatch .gt. 0) THEN allocate(DATArecv(NSPEC, NbMatch), stat=istat) -!/DEBUGIO WRITE(740+IAPROC,*) 'After allocation and before reception, istat=', istat -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After allocation and before reception, istat=', istat + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(DATArecv,NSPEC*NbMatch,MPI_REAL, iProc-1, 101, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGIO WRITE(740+IAPROC,*) 'After reception, ierr=', ierr -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After reception, ierr=', ierr + FLUSH(740+IAPROC) +#endif idx=0 DO IPloc=1,NPAloc IPglob = ListIPLG(IPloc + ListFirst(iProc)) @@ -762,17 +828,23 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) DATAwrite(:, pos) = DATArecv(:, idx) END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'After assignation' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After assignation' + FLUSH(740+IAPROC) +#endif deallocate(DATArecv, stat=istat) -!/DEBUGIO WRITE(740+IAPROC,*) 'After assignation istat=', istat -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After assignation istat=', istat + FLUSH(740+IAPROC) +#endif END IF END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'Before the actual write down' -!/DEBUGIO WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, 'Sum DATAwrite=', sum(DATAwrite) -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Before the actual write down' + WRITE(740+IAPROC,*) 'iBlock=', iBlock, '/', nbBlock, 'Sum DATAwrite=', sum(DATAwrite) + FLUSH(740+IAPROC) +#endif DO ISEA=iFirst,iEnd idx = ISEA - iFirst + 1 NREC = ISEA + 2 @@ -783,14 +855,20 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) WRITEBUFF(1:NSPEC) = DATAwrite(1:NSPEC, idx) WRITE(NDWRITE, POS=RPOS) WRITEBUFF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'After the write down' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After the write down' + FLUSH(740+IAPROC) +#endif ELSE -!/DEBUGIO WRITE(740+IAPROC,*) 'We are a node different from NAPRST' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'We are a node different from NAPRST' + FLUSH(740+IAPROC) +#endif IF (IAPROC .le. NAPROC) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'We are a computing node' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'We are a computing node' + FLUSH(740+IAPROC) +#endif NbMatch=0 DO IPloc=1,ListNPA(IAPROC) IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) @@ -798,15 +876,21 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) NbMatch=NbMatch+1 END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'NbMatch=', NbMatch -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'NbMatch=', NbMatch + FLUSH(740+IAPROC) +#endif IF (NbMatch .gt. 0) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'We are actually a computing node so we have something to send' -!/DEBUGIO WRITE(740+IAPROC,*) 'Sending message of length NSEAL=', NSEAL -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'We are actually a computing node so we have something to send' + WRITE(740+IAPROC,*) 'Sending message of length NSEAL=', NSEAL + FLUSH(740+IAPROC) +#endif allocate(DATAsend(NSPEC,NbMatch), stat=istat) -!/DEBUGIO WRITE(740+IAPROC,*) 'After allocation of DATAsend, istat=', istat -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After allocation of DATAsend, istat=', istat + FLUSH(740+IAPROC) +#endif idx=0 DO IPloc=1,ListNPA(IAPROC) IPglob = ListIPLG(ListFirst(IAPROC) + IPloc) @@ -815,25 +899,35 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) DATAsend(:,idx)=VA(:,IPloc) END IF END DO -!/DEBUGIO WRITE(740+IAPROC,*) 'After assignation of DATAsend' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After assignation of DATAsend' + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(DATAsend,NSPEC*NbMatch,MPI_REAL, NAPRST-1, 101, MPI_COMM_WAVE, ierr) -!/DEBUGIO WRITE(740+IAPROC,*) 'After sending of DATAsend, ierr=', ierr -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After sending of DATAsend, ierr=', ierr + FLUSH(740+IAPROC) +#endif deallocate(DATAsend, stat=istat) -!/DEBUGIO WRITE(740+IAPROC,*) 'After deallocation of DATAsend, istat=', istat -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After deallocation of DATAsend, istat=', istat + FLUSH(740+IAPROC) +#endif END IF END IF -!/DEBUGIO WRITE(740+IAPROC,*) 'After the IAPROC test' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'After the IAPROC test' + FLUSH(740+IAPROC) +#endif END IF END DO !!/DEBUGIO WRITE(740+IAPROC,*) 'Before the MPI_BARRIER' !!/DEBUGIO FLUSH(740+IAPROC) ! CALL MPI_BARRIER(MPI_COMM_WAVE, IERR_MPI) -!/DEBUGIO WRITE(740+IAPROC,*) 'Exiting the UNST_PDLIB_WRITE_TO_FILE' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Exiting the UNST_PDLIB_WRITE_TO_FILE' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) @@ -919,7 +1013,9 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) IP(4), I, J, JSEA, ITARG, IB, & JSEA0, JSEAN, NSEAB, IBOFF, & ISEA, ISPROC, K, NRQMAX -!/S INTEGER, SAVE :: IENT +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif LOGICAL :: FLGRDALL(NOGRP,NGRPP) REAL, allocatable :: ARRexch(:,:), ARRexch_loc(:,:) REAL, allocatable :: ARRtotal(:,:) @@ -927,9 +1023,11 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) INTEGER :: eEnt(1), IPROC INTEGER :: TheSize, NSEAL_loc INTEGER, SAVE :: indexOutput -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Beginning of output, indexOutput=', indexOutput -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NAPFLD=', NAPFLD -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Beginning of output, indexOutput=', indexOutput + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NAPFLD=', NAPFLD + FLUSH(740+IAPROC) +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -942,13 +1040,17 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) NRQGO2 = 0 IT0 = NSPEC IROOT = NAPFLD - 1 -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Entering DO_OUTPUT_EXCHANGES' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Entering DO_OUTPUT_EXCHANGES' + FLUSH(740+IAPROC) +#endif IF ( FLOUT(1) .OR. FLOUT(7) ) THEN CALL GET_ARRAY_SIZE(TheSize) IF ( IAPROC .LE. NAPROC ) THEN -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Allocating and filling' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Allocating and filling' + FLUSH(740+IAPROC) +#endif allocate(ARRexch(TheSize, NSEAL), ARRpos(NSEAL)) DO JSEA=1,NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -1352,8 +1454,10 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) END DO END DO END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Before assigning field values' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Before assigning field values' + FLUSH(740+IAPROC) +#endif ! ! Now synchronizing the data ! It must be possible to ensure that the output @@ -1367,47 +1471,71 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) END DO END IF END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Before ARRexch operations' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Before ARRexch operations' + FLUSH(740+IAPROC) +#endif IF ((IAPROC .le. NAPROC).and.(IAPROC.ne.NAPFLD)) THEN -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Case 1' -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'NSEAL=', NSEAL -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' NAPFLD=', NAPFLD -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Case 1' + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' NAPFLD=', NAPFLD + FLUSH(740+IAPROC) +#endif eEnt(1)=NSEAL CALL MPI_SEND(eEnt,1,MPI_INTEGER, NAPFLD-1, 23, MPI_COMM_WAVE, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_SEND 1' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_SEND 1' + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ARRpos,NSEAL,MPI_INTEGER, NAPFLD-1, 29, MPI_COMM_WAVE, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_SEND 2' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_SEND 2' + FLUSH(740+IAPROC) +#endif CALL MPI_SEND(ARRexch,NSEAL*TheSize,MPI_REAL, NAPFLD-1, 37, MPI_COMM_WAVE, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_SEND 3' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_SEND 3' + FLUSH(740+IAPROC) +#endif deallocate(ARRpos, ARRexch) END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Case 2' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Case 2' + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. NAPFLD) THEN -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Case 2a' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Case 2a' + FLUSH(740+IAPROC) +#endif DO IPROC=1,NAPROC IF (IPROC .ne. IAPROC) THEN -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'IPROC=', IPROC -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'IPROC=', IPROC + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(eEnt,1,MPI_INTEGER, IPROC-1, 23, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_RECV 1' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_RECV 1' + FLUSH(740+IAPROC) +#endif NSEAL_loc=eEnt(1) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'NSEAL_loc=', NSEAL_loc -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'NSEAL_loc=', NSEAL_loc + FLUSH(740+IAPROC) +#endif allocate(ARRpos_loc(NSEAL_loc), ARRexch_loc(TheSize, NSEAL_loc)) CALL MPI_RECV(ARRpos_loc,NSEAL_loc,MPI_INTEGER, IPROC-1, 29, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_RECV 2' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_RECV 2' + FLUSH(740+IAPROC) +#endif CALL MPI_RECV(ARRexch_loc,NSEAL_loc*TheSize,MPI_INTEGER, IPROC-1, 37, MPI_COMM_WAVE, istatus, ierr) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After MPI_RECV 3' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After MPI_RECV 3' + FLUSH(740+IAPROC) +#endif DO I=1,NSEAL_loc ARRtotal(:,ARRpos_loc(I)) = ARRexch_loc(:,I) END DO @@ -1415,14 +1543,18 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) END IF END DO END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After ARRexch operations' -!/DEBUGOUTPUT FLUSH(740+IAPROC) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'NAPFLD=', NAPFLD -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After ARRexch operations' + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'NAPFLD=', NAPFLD + FLUSH(740+IAPROC) +#endif IF ( IAPROC .EQ. NAPFLD ) THEN ! CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Call W3XETA from DO_OUTPUT_EXCHANGES' -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Call W3XETA from DO_OUTPUT_EXCHANGES' + FLUSH(740+IAPROC) +#endif CALL W3XETA ( IMOD, NDSE, NDST ) IH = 0 IF ( FLGRDALL( 2, 1) ) THEN @@ -1823,11 +1955,15 @@ SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) END DO CALL W3SETA ( IMOD, NDSE, NDST ) END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'After IAPROC = NAPFLD test' -!/DEBUGOUTPUT FLUSH(740+IAPROC) - END IF -!/DEBUGOUTPUT WRITE(740+IAPROC,*) 'Ending of output, indexOutput=', indexOutput -!/DEBUGOUTPUT FLUSH(740+IAPROC) +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'After IAPROC = NAPFLD test' + FLUSH(740+IAPROC) +#endif + END IF +#ifdef W3_DEBUGOUTPUT + WRITE(740+IAPROC,*) 'Ending of output, indexOutput=', indexOutput + FLUSH(740+IAPROC) +#endif indexOutput=indexOutput+1 END SUBROUTINE DO_OUTPUT_EXCHANGES !/ ------------------------------------------------------------------- / diff --git a/model/ftn/serv_xnl4v5.f90 b/model/src/serv_xnl4v5.f90 similarity index 100% rename from model/ftn/serv_xnl4v5.f90 rename to model/src/serv_xnl4v5.f90 diff --git a/model/ftn/w3adatmd.ftn b/model/src/w3adatmd.F90 similarity index 84% rename from model/ftn/w3adatmd.ftn rename to model/src/w3adatmd.F90 index b6179a888..c079d4812 100644 --- a/model/ftn/w3adatmd.ftn +++ b/model/src/w3adatmd.F90 @@ -1,7 +1,9 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / MODULE W3ADATMD -!/MEMCHECK USE MallocInfo_m +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | @@ -347,7 +349,9 @@ MODULE W3ADATMD !/ Conventional declarations !/ INTEGER :: NADATA = -1, IADATA = -1 -!/MPI INTEGER, PARAMETER :: MPIBUF = 6 +#ifdef W3_MPI + INTEGER, PARAMETER :: MPIBUF = 6 +#endif !/ !/ Data structure WADAT !/ @@ -356,7 +360,9 @@ MODULE W3ADATMD ! The grid ! REAL, POINTER :: CG(:,:), WN(:,:) -!/IC3 REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) +#ifdef W3_IC3 + REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) +#endif ! ! Arrays for processing model input ! @@ -468,50 +474,66 @@ MODULE W3ADATMD REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) -!/SMC REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) -! -!/PR1 INTEGER, POINTER :: IS0(:), IS2(:) -!/PR1 REAL, POINTER :: FACVX(:), FACVY(:) -! -!/PR2 INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & -!/PR2 NACT, NMXY -!/PR2 INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & -!/PR2 MAPXY(:), MAPTH2(:), MAPWN2(:) -! -!/PR3 INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & -!/PR3 NACT, NCENT -!/PR3 INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & -!/PR3 MAPCXY(:), MAPTH2(:), MAPWN2(:) -!/PR3 LOGICAL, POINTER :: MAPTRN(:) +#ifdef W3_SMC + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) +#endif +! +#ifdef W3_PR1 + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) +#endif +! +#ifdef W3_PR2 + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPXY(:), MAPTH2(:), MAPWN2(:) +#endif +! +#ifdef W3_PR3 + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) +#endif ! ! Warning Defined but not set if UGTYPE .EQ. .T. INTEGER, POINTER :: ITER(:,:) ! -!/NL1 INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY -!/NL1 INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & -!/NL1 IM11(:), IM12(:), IM13(:), IM14(:), & -!/NL1 IP21(:), IP22(:), IP23(:), IP24(:), & -!/NL1 IM21(:), IM22(:), IM23(:), IM24(:), & -!/NL1 IC11(:), IC12(:), IC21(:), IC22(:), & -!/NL1 IC31(:), IC32(:), IC41(:), IC42(:), & -!/NL1 IC51(:), IC52(:), IC61(:), IC62(:), & -!/NL1 IC71(:), IC72(:), IC81(:), IC82(:) -!/NL1 REAL :: DAL1, DAL2, DAL3, & -!/NL1 AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & -!/NL1 AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & -!/NL1 SWG5, SWG6, SWG7, SWG8 -!/NL1 REAL, POINTER :: AF11(:) -!/NL1 LOGICAL :: NLINIT +#ifdef W3_NL1 + INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & + IM11(:), IM12(:), IM13(:), IM14(:), & + IP21(:), IP22(:), IP23(:), IP24(:), & + IM21(:), IM22(:), IM23(:), IM24(:), & + IC11(:), IC12(:), IC21(:), IC22(:), & + IC31(:), IC32(:), IC41(:), IC42(:), & + IC51(:), IC52(:), IC61(:), IC62(:), & + IC71(:), IC72(:), IC81(:), IC82(:) + REAL :: DAL1, DAL2, DAL3, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & + AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & + SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL :: NLINIT +#endif ! INTEGER, POINTER :: IAPPRO(:) -!/MPI INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & -!/MPI WW3_FIELD_VEC, WW3_SPEC_VEC, & -!/MPI NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, & -!/MPI NSPLOC -!/PDLIB INTEGER :: NBFIELD, PDLIB_MPI_TYPE -!/MPI INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) -!/MPI INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) -!/MPI REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#ifdef W3_MPI + INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & + WW3_FIELD_VEC, WW3_SPEC_VEC, & + NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, & + NSPLOC +#endif +#ifdef W3_PDLIB + INTEGER :: NBFIELD, PDLIB_MPI_TYPE +#endif +#ifdef W3_MPI + INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#endif REAL, POINTER :: SPPNT(:,:,:) ! INTEGER :: ITIME, IPASS, IDLAST, NSEALM @@ -581,55 +603,69 @@ MODULE W3ADATMD REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) -!/SMC REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) -! -!/PR1 INTEGER, POINTER :: IS0(:), IS2(:) -!/PR1 REAL, POINTER :: FACVX(:), FACVY(:) -! -!/PR2 INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & -!/PR2 NACT, NMXY -!/PR2 INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & -!/PR2 MAPXY(:), MAPTH2(:), MAPWN2(:) -! -!/PR3 INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & -!/PR3 NACT, NCENT -!/PR3 INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & -!/PR3 MAPCXY(:), MAPTH2(:), MAPWN2(:) -!/PR3 LOGICAL, POINTER :: MAPTRN(:) +#ifdef W3_SMC + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) +#endif +! +#ifdef W3_PR1 + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) +#endif +! +#ifdef W3_PR2 + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPXY(:), MAPTH2(:), MAPWN2(:) +#endif +! +#ifdef W3_PR3 + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & + NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & + MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) +#endif ! INTEGER, POINTER :: ITER(:,:) ! -!/NL1 INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY -!/NL1 INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & -!/NL1 IM11(:), IM12(:), IM13(:), IM14(:), & -!/NL1 IP21(:), IP22(:), IP23(:), IP24(:), & -!/NL1 IM21(:), IM22(:), IM23(:), IM24(:), & -!/NL1 IC11(:), IC12(:), IC21(:), IC22(:), & -!/NL1 IC31(:), IC32(:), IC41(:), IC42(:), & -!/NL1 IC51(:), IC52(:), IC61(:), IC62(:), & -!/NL1 IC71(:), IC72(:), IC81(:), IC82(:) -!/NL1 REAL, POINTER :: DAL1, DAL2, DAL3, & -!/NL1 AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & -!/NL1 AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & -!/NL1 SWG5, SWG6, SWG7, SWG8 -!/NL1 REAL, POINTER :: AF11(:) -!/NL1 LOGICAL, POINTER :: NLINIT +#ifdef W3_NL1 + INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & + IM11(:), IM12(:), IM13(:), IM14(:), & + IP21(:), IP22(:), IP23(:), IP24(:), & + IM21(:), IM22(:), IM23(:), IM24(:), & + IC11(:), IC12(:), IC21(:), IC22(:), & + IC31(:), IC32(:), IC41(:), IC42(:), & + IC51(:), IC52(:), IC61(:), IC62(:), & + IC71(:), IC72(:), IC81(:), IC82(:) + REAL, POINTER :: DAL1, DAL2, DAL3, & + AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & + AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & + SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL, POINTER :: NLINIT +#endif ! INTEGER, POINTER :: IAPPRO(:) -!/MPI INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & -!/MPI WW3_FIELD_VEC, WW3_SPEC_VEC, & -!/MPI NRQSG1, NRQSG2, IBFLOC, ISPLOC, & -!/MPI NSPLOC -!/MPI INTEGER, POINTER :: BSTAT(:), BISPL(:) -!/MPI INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) -!/MPI REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & + WW3_FIELD_VEC, WW3_SPEC_VEC, & + NRQSG1, NRQSG2, IBFLOC, ISPLOC, & + NSPLOC + INTEGER, POINTER :: BSTAT(:), BISPL(:) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) +#endif REAL, POINTER :: SPPNT(:,:,:) ! INTEGER, POINTER :: ITIME, IPASS, IDLAST, NSEALM REAL, POINTER :: ALPHA(:,:) LOGICAL, POINTER :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND -!/MEMCHECK type(MallInfo_t) :: mallinfos +#ifdef W3_MEMCHECK + type(MallInfo_t) :: mallinfos +#endif !/ CONTAINS @@ -690,7 +726,9 @@ SUBROUTINE W3NAUX ( NDSE, NDST ) USE W3GDATMD, ONLY: NGRIDS USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: IAPROC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -703,9 +741,13 @@ SUBROUTINE W3NAUX ( NDSE, NDST ) !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3NAUX') +#ifdef W3_S + CALL STRACE (IENT, 'W3NAUX') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -735,10 +777,14 @@ SUBROUTINE W3NAUX ( NDSE, NDST ) WADATS(I)%AINIT = .FALSE. WADATS(I)%AINIT2 = .FALSE. WADATS(I)%FL_ALL = .FALSE. -!/NL1 WADATS(I)%NLINIT = .FALSE. +#ifdef W3_NL1 + WADATS(I)%NLINIT = .FALSE. +#endif END DO ! -!/T WRITE (NDST,9000) NGRIDS +#ifdef W3_T + WRITE (NDST,9000) NGRIDS +#endif ! RETURN ! @@ -748,7 +794,9 @@ SUBROUTINE W3NAUX ( NDSE, NDST ) ' NGRIDS = ',I10/ & ' RUN W3NMOD FIRST'/) ! -!/T 9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') +#ifdef W3_T + 9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') +#endif !/ !/ End of W3NAUX ----------------------------------------------------- / !/ @@ -842,7 +890,9 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2 USE W3IDATMD, ONLY: FLCUR, FLWIND, FLTAUA, FLRHOA USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -856,16 +906,22 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) !/ Local parameters !/ INTEGER :: JGRID, NXXX, NSEAL_tmp -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DIMA') +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMA') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status ! -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 0' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif IF ( PRESENT(D_ONLY) ) THEN FL_ALL = .NOT. D_ONLY @@ -888,14 +944,18 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays @@ -932,9 +992,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%TAUA(:) =0. WADATS(IMOD)%TAUADIR(:)=0. -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! Water level WLV stored in W3WDATMD ! Ice concentration ICE stored in W3WDATMD @@ -988,24 +1050,32 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%WBT = UNDEF WADATS(IMOD)%WNMEAN = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 3) Frequency-dependent standard parameters ! ! For the 3D arrays: the allocation is performed only if these arrays are allowed ! by specific variables defined through the mod_def file ! and read by w3iogr, which is called before W3DIMA. -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before the EF allocation' -!/DEBUGINIT WRITE(740+IAPROC,*) 'E3DF=', E3DF(1,1) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before the EF allocation' + WRITE(740+IAPROC,*) 'E3DF=', E3DF(1,1) +#endif IF ( E3DF(1,1).GT.0 ) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Now the allocation' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Now the allocation' +#endif ALLOCATE(WADATS(IMOD)%EF(NSEALM,E3DF(2,1):E3DF(3,1)), & STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) END IF -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + FLUSH(740+IAPROC) +#endif IF ( E3DF(1,2).GT.0 ) THEN ALLOCATE(WADATS(IMOD)%TH1M(NSEALM,E3DF(2,2):E3DF(3,2)), & STAT=ISTAT ) @@ -1033,9 +1103,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) IF ( E3DF(1,4).GT.0 ) WADATS(IMOD)%TH2M = UNDEF IF ( E3DF(1,5).GT.0 ) WADATS(IMOD)%STH2M = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 4) Spectral Partitions parameters @@ -1104,9 +1176,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%TAUWNY = UNDEF WADATS(IMOD)%WHITECAP = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 6) Wave-ocean layer @@ -1171,9 +1245,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) IF ( US3DF(1).GT.0 ) WADATS(IMOD)%US3D = UNDEF IF ( USSPF(1).GT.0 ) WADATS(IMOD)%USSP = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 7) Wave-bottom layer ! @@ -1192,9 +1268,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%PHIBBL = UNDEF WADATS(IMOD)%TAUBBL = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 8) Spectrum parameters ! @@ -1210,9 +1288,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%MSCX = UNDEF WADATS(IMOD)%MSCY = UNDEF WADATS(IMOD)%MSCD = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 8' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 9) Numerical diagnostics ! @@ -1230,9 +1310,11 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%CFLTHMAX = UNDEF WADATS(IMOD)%CFLKMAX = UNDEF -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 9' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 10) User defined ! @@ -1244,22 +1326,28 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ALLOCATE ( WADATS(IMOD)%WN(0:NK+1,0:NSEA), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/IC3 ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) -!/IC3 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC3 ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) -!/IC3 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_IC3 + ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 10' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 10' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! IF ( FL_ALL ) THEN ! ALLOCATE ( WADATS(IMOD)%CG(0:NK+1,0:NSEA), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/IC3 ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) -!/IC3 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_IC3 + ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! IF ( FLCUR ) THEN @@ -1331,43 +1419,51 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%DCXDY = 0. WADATS(IMOD)%DCYDY = 0. ! -!/SMC ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & -!/SMC WADATS(IMOD)%DHDY(NSEA) , & -!/SMC WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) -!/SMC CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_SMC + ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & + WADATS(IMOD)%DHDY(NSEA) , & + WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! ALLOCATE ( WADATS(IMOD)%ALPHA(NK,NSEAL) , STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) ! -!/PR1 ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & -!/PR1 WADATS(IMOD)%IS2(NSPEC) , & -!/PR1 WADATS(IMOD)%FACVX(NY*NX) , & -!/PR1 WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) -!/PR1 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_PR1 + ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & + WADATS(IMOD)%IS2(NSPEC) , & + WADATS(IMOD)%FACVX(NY*NX) , & + WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! -!/PR2 ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & -!/PR2 WADATS(IMOD)%MAPY2(NY*NX) , & -!/PR2 WADATS(IMOD)%MAPAXY(NY*NX) , & -!/PR2 WADATS(IMOD)%MAPXY(NSEA) , & -!/PR2 WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & -!/PR2 WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) -!/PR2 CHECK_ALLOC_STATUS ( ISTAT ) -!/PR2 WADATS(IMOD)%MAPTH2 = 0 +#ifdef W3_PR2 + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif ! IF (GTYPE .EQ. UNGTYPE) THEN ALLOCATE( WADATS(IMOD)%ITER(NK,NTH), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) END IF ! -!/PR3 ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & -!/PR3 WADATS(IMOD)%MAPY2(NY*NX) , & -!/PR3 WADATS(IMOD)%MAPAXY(NY*NX) , & -!/PR3 WADATS(IMOD)%MAPCXY(NSEA) , & -!/PR3 WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & -!/PR3 WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & -!/PR3 WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) -!/PR3 CHECK_ALLOC_STATUS ( ISTAT ) -!/PR3 WADATS(IMOD)%MAPTH2 = 0 +#ifdef W3_PR3 + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPCXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & + WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif ! ALLOCATE ( WADATS(IMOD)%IAPPRO(NSPEC) , & WADATS(IMOD)%SPPNT(NTH,NK,4), STAT=ISTAT ) @@ -1377,38 +1473,50 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ! WADATS(IMOD)%AINIT = .TRUE. -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 11' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 11' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETA ( IMOD, NDSE, NDST ) -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 12' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA 12' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary ! IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA END' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3DIMA END' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! RETURN ! @@ -1421,10 +1529,12 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ' NADATA = ',I10/) 1003 FORMAT (/' *** ERROR W3DIMA : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3DIMA : MODEL ',I4) -!/T 9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DIMA : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DIMA : MODEL ',I4) + 9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DIMA : POINTERS RESET') + 9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') +#endif !/ !/ End of W3DIMA ----------------------------------------------------- / !/ @@ -1458,7 +1568,9 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2, & NOGRP, NGRPP USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1472,9 +1584,13 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) !/ Local parameters !/ INTEGER :: JGRID, NXXX, I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3XDMA') +#ifdef W3_S + CALL STRACE (IENT, 'W3XDMA') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1494,7 +1610,9 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -2274,17 +2392,21 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) ! WADATS(IMOD)%AINIT2 = .TRUE. ! -!/T WRITE (NDST,9001) -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary ! IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'W3XDMA' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'W3XDMA' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! RETURN ! @@ -2297,10 +2419,12 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) ' NADATA = ',I10/) 1003 FORMAT (/' *** ERROR W3XDMA : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3XDMA : MODEL ',I4) -!/T 9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3XDMA : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3XDMA : MODEL ',I4) + 9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3XDMA : POINTERS RESET') + 9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') +#endif !/ !/ End of W3XDMA ----------------------------------------------------- / !/ @@ -2375,7 +2499,9 @@ SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) NSPEC, NTH, GTYPE, UNGTYPE USE W3ODATMD, ONLY: NAPROC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -2387,9 +2513,13 @@ SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DMNL') +#ifdef W3_S + CALL STRACE (IENT, 'W3DMNL') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -2404,69 +2534,85 @@ SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) CALL EXTCDE (2) END IF ! -!/NL1 IF ( WADATS(IMOD)%NLINIT ) THEN -!/NL1 WRITE (NDSE,1003) -!/NL1 CALL EXTCDE (3) -!/NL1 END IF +#ifdef W3_NL1 + IF ( WADATS(IMOD)%NLINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF +#endif ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays ! -!/NL1 ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & -!/NL1 WADATS(IMOD)%IP12(NSPX), & -!/NL1 WADATS(IMOD)%IP13(NSPX), & -!/NL1 WADATS(IMOD)%IP14(NSPX), & -!/NL1 WADATS(IMOD)%IM11(NSPX), & -!/NL1 WADATS(IMOD)%IM12(NSPX), & -!/NL1 WADATS(IMOD)%IM13(NSPX), & -!/NL1 WADATS(IMOD)%IM14(NSPX), & -!/NL1 WADATS(IMOD)%IP21(NSPX), & -!/NL1 WADATS(IMOD)%IP22(NSPX), & -!/NL1 WADATS(IMOD)%IP23(NSPX), & -!/NL1 WADATS(IMOD)%IP24(NSPX), & -!/NL1 WADATS(IMOD)%IM21(NSPX), & -!/NL1 WADATS(IMOD)%IM22(NSPX), & -!/NL1 WADATS(IMOD)%IM23(NSPX), & -!/NL1 WADATS(IMOD)%IM24(NSPX), & -!/NL1 WADATS(IMOD)%IC11(NSP) , & -!/NL1 WADATS(IMOD)%IC12(NSP) , & -!/NL1 WADATS(IMOD)%IC21(NSP) , & -!/NL1 WADATS(IMOD)%IC22(NSP) , & -!/NL1 WADATS(IMOD)%IC31(NSP) , & -!/NL1 WADATS(IMOD)%IC32(NSP) , & -!/NL1 WADATS(IMOD)%IC41(NSP) , & -!/NL1 WADATS(IMOD)%IC42(NSP) , & -!/NL1 WADATS(IMOD)%IC51(NSP) , & -!/NL1 WADATS(IMOD)%IC52(NSP) , & -!/NL1 WADATS(IMOD)%IC61(NSP) , & -!/NL1 WADATS(IMOD)%IC62(NSP) , & -!/NL1 WADATS(IMOD)%IC71(NSP) , & -!/NL1 WADATS(IMOD)%IC72(NSP) , & -!/NL1 WADATS(IMOD)%IC81(NSP) , & -!/NL1 WADATS(IMOD)%IC82(NSP) , & -!/NL1 WADATS(IMOD)%AF11(NSPX), & -!/NL1 STAT=ISTAT ) -!/NL1 CHECK_ALLOC_STATUS ( ISTAT ) -! -!/NL1 WADATS(IMOD)%NLINIT = .TRUE. -! -!/T WRITE (NDST,9001) +#ifdef W3_NL1 + ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & + WADATS(IMOD)%IP12(NSPX), & + WADATS(IMOD)%IP13(NSPX), & + WADATS(IMOD)%IP14(NSPX), & + WADATS(IMOD)%IM11(NSPX), & + WADATS(IMOD)%IM12(NSPX), & + WADATS(IMOD)%IM13(NSPX), & + WADATS(IMOD)%IM14(NSPX), & + WADATS(IMOD)%IP21(NSPX), & + WADATS(IMOD)%IP22(NSPX), & + WADATS(IMOD)%IP23(NSPX), & + WADATS(IMOD)%IP24(NSPX), & + WADATS(IMOD)%IM21(NSPX), & + WADATS(IMOD)%IM22(NSPX), & + WADATS(IMOD)%IM23(NSPX), & + WADATS(IMOD)%IM24(NSPX), & + WADATS(IMOD)%IC11(NSP) , & + WADATS(IMOD)%IC12(NSP) , & + WADATS(IMOD)%IC21(NSP) , & + WADATS(IMOD)%IC22(NSP) , & + WADATS(IMOD)%IC31(NSP) , & + WADATS(IMOD)%IC32(NSP) , & + WADATS(IMOD)%IC41(NSP) , & + WADATS(IMOD)%IC42(NSP) , & + WADATS(IMOD)%IC51(NSP) , & + WADATS(IMOD)%IC52(NSP) , & + WADATS(IMOD)%IC61(NSP) , & + WADATS(IMOD)%IC62(NSP) , & + WADATS(IMOD)%IC71(NSP) , & + WADATS(IMOD)%IC72(NSP) , & + WADATS(IMOD)%IC81(NSP) , & + WADATS(IMOD)%IC82(NSP) , & + WADATS(IMOD)%AF11(NSPX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_NL1 + WADATS(IMOD)%NLINIT = .TRUE. +#endif +! +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETA ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid ! -!/NL1 NSPECX = NSPX +#ifdef W3_NL1 + NSPECX = NSPX +#endif ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! RETURN ! @@ -2477,12 +2623,16 @@ SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) 1002 FORMAT (/' *** ERROR W3DMNL : ILLEGAL MODEL NUMBER *** '/ & ' IMOD = ',I10/ & ' NADATA = ',I10/) -!/NL1 1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') +#ifdef W3_NL1 + 1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') +#endif ! -!/T 9000 FORMAT (' TEST W3DMNL : MODEL ',I4) -!/T 9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DMNL : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DMNL : MODEL ',I4) + 9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DMNL : POINTERS RESET') + 9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') +#endif !/ !/ End of W3DMNL ----------------------------------------------------- / !/ @@ -2558,7 +2708,9 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -2570,9 +2722,13 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3SETA') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETA') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -2587,7 +2743,9 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model numbers @@ -2607,61 +2765,69 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) AINIT2 => WADATS(IMOD)%AINIT2 FL_ALL => WADATS(IMOD)%FL_ALL ! -!/PR2 NMX0 => WADATS(IMOD)%NMX0 -!/PR2 NMX1 => WADATS(IMOD)%NMX1 -!/PR2 NMX2 => WADATS(IMOD)%NMX2 -!/PR2 NMY0 => WADATS(IMOD)%NMY0 -!/PR2 NMY1 => WADATS(IMOD)%NMY1 -!/PR2 NMY2 => WADATS(IMOD)%NMY2 -!/PR2 NACT => WADATS(IMOD)%NACT -!/PR2 NMXY => WADATS(IMOD)%NMXY -! -!/PR3 NMX0 => WADATS(IMOD)%NMX0 -!/PR3 NMX1 => WADATS(IMOD)%NMX1 -!/PR3 NMX2 => WADATS(IMOD)%NMX2 -!/PR3 NMY0 => WADATS(IMOD)%NMY0 -!/PR3 NMY1 => WADATS(IMOD)%NMY1 -!/PR3 NMY2 => WADATS(IMOD)%NMY2 -!/PR3 NACT => WADATS(IMOD)%NACT -!/PR3 NCENT => WADATS(IMOD)%NCENT -! -!/NL1 NFR => WADATS(IMOD)%NFR -!/NL1 NFRHGH => WADATS(IMOD)%NFRHGH -!/NL1 NFRCHG => WADATS(IMOD)%NFRCHG -!/NL1 NSPECX => WADATS(IMOD)%NSPECX -!/NL1 NSPECY => WADATS(IMOD)%NSPECY -!/NL1 DAL1 => WADATS(IMOD)%DAL1 -!/NL1 DAL2 => WADATS(IMOD)%DAL2 -!/NL1 DAL3 => WADATS(IMOD)%DAL3 -!/NL1 AWG1 => WADATS(IMOD)%AWG1 -!/NL1 AWG2 => WADATS(IMOD)%AWG2 -!/NL1 AWG3 => WADATS(IMOD)%AWG3 -!/NL1 AWG4 => WADATS(IMOD)%AWG4 -!/NL1 AWG5 => WADATS(IMOD)%AWG5 -!/NL1 AWG6 => WADATS(IMOD)%AWG6 -!/NL1 AWG7 => WADATS(IMOD)%AWG7 -!/NL1 AWG8 => WADATS(IMOD)%AWG8 -!/NL1 SWG1 => WADATS(IMOD)%SWG1 -!/NL1 SWG2 => WADATS(IMOD)%SWG2 -!/NL1 SWG3 => WADATS(IMOD)%SWG3 -!/NL1 SWG4 => WADATS(IMOD)%SWG4 -!/NL1 SWG5 => WADATS(IMOD)%SWG5 -!/NL1 SWG6 => WADATS(IMOD)%SWG6 -!/NL1 SWG7 => WADATS(IMOD)%SWG7 -!/NL1 SWG8 => WADATS(IMOD)%SWG8 -!/NL1 NLINIT => WADATS(IMOD)%NLINIT -! -!/MPI MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE -!/MPI MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP -!/MPI WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC -!/MPI WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC -!/MPI NRQSG1 => WADATS(IMOD)%NRQSG1 -!/MPI NRQSG2 => WADATS(IMOD)%NRQSG2 -!/MPI IBFLOC => WADATS(IMOD)%IBFLOC -!/MPI ISPLOC => WADATS(IMOD)%ISPLOC -!/MPI NSPLOC => WADATS(IMOD)%NSPLOC -!/MPI BSTAT => WADATS(IMOD)%BSTAT -!/MPI BISPL => WADATS(IMOD)%BISPL +#ifdef W3_PR2 + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NMXY => WADATS(IMOD)%NMXY +#endif +! +#ifdef W3_PR3 + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NCENT => WADATS(IMOD)%NCENT +#endif +! +#ifdef W3_NL1 + NFR => WADATS(IMOD)%NFR + NFRHGH => WADATS(IMOD)%NFRHGH + NFRCHG => WADATS(IMOD)%NFRCHG + NSPECX => WADATS(IMOD)%NSPECX + NSPECY => WADATS(IMOD)%NSPECY + DAL1 => WADATS(IMOD)%DAL1 + DAL2 => WADATS(IMOD)%DAL2 + DAL3 => WADATS(IMOD)%DAL3 + AWG1 => WADATS(IMOD)%AWG1 + AWG2 => WADATS(IMOD)%AWG2 + AWG3 => WADATS(IMOD)%AWG3 + AWG4 => WADATS(IMOD)%AWG4 + AWG5 => WADATS(IMOD)%AWG5 + AWG6 => WADATS(IMOD)%AWG6 + AWG7 => WADATS(IMOD)%AWG7 + AWG8 => WADATS(IMOD)%AWG8 + SWG1 => WADATS(IMOD)%SWG1 + SWG2 => WADATS(IMOD)%SWG2 + SWG3 => WADATS(IMOD)%SWG3 + SWG4 => WADATS(IMOD)%SWG4 + SWG5 => WADATS(IMOD)%SWG5 + SWG6 => WADATS(IMOD)%SWG6 + SWG7 => WADATS(IMOD)%SWG7 + SWG8 => WADATS(IMOD)%SWG8 + NLINIT => WADATS(IMOD)%NLINIT +#endif +! +#ifdef W3_MPI + MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE + MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP + WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC + WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC + NRQSG1 => WADATS(IMOD)%NRQSG1 + NRQSG2 => WADATS(IMOD)%NRQSG2 + IBFLOC => WADATS(IMOD)%IBFLOC + ISPLOC => WADATS(IMOD)%ISPLOC + NSPLOC => WADATS(IMOD)%NSPLOC + BSTAT => WADATS(IMOD)%BSTAT + BISPL => WADATS(IMOD)%BISPL +#endif ! IF ( AINIT ) THEN ! @@ -2777,13 +2943,17 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) USERO => WADATS(IMOD)%USERO ! WN => WADATS(IMOD)%WN -!/IC3 IC3WN_R=> WADATS(IMOD)%IC3WN_R -!/IC3 IC3WN_I=> WADATS(IMOD)%IC3WN_I +#ifdef W3_IC3 + IC3WN_R=> WADATS(IMOD)%IC3WN_R + IC3WN_I=> WADATS(IMOD)%IC3WN_I +#endif ! IF ( FL_ALL ) THEN ! CG => WADATS(IMOD)%CG -!/IC3 IC3CG => WADATS(IMOD)%IC3CG +#ifdef W3_IC3 + IC3CG => WADATS(IMOD)%IC3CG +#endif ! ATRNX => WADATS(IMOD)%ATRNX ATRNY => WADATS(IMOD)%ATRNY @@ -2797,9 +2967,11 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) DCXDY => WADATS(IMOD)%DCXDY DCYDY => WADATS(IMOD)%DCYDY ! -!/SMC DHDX => WADATS(IMOD)%DHDX -!/SMC DHDY => WADATS(IMOD)%DHDY -!/SMC DHLMT => WADATS(IMOD)%DHLMT +#ifdef W3_SMC + DHDX => WADATS(IMOD)%DHDX + DHDY => WADATS(IMOD)%DHDY + DHLMT => WADATS(IMOD)%DHLMT +#endif ! ALPHA => WADATS(IMOD)%ALPHA ! @@ -2831,25 +3003,31 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) RAI => WADATS(IMOD)%RAI END IF ! -!/PR1 IS0 => WADATS(IMOD)%IS0 -!/PR1 IS2 => WADATS(IMOD)%IS2 -!/PR1 FACVX => WADATS(IMOD)%FACVX -!/PR1 FACVY => WADATS(IMOD)%FACVY -! -!/PR2 MAPX2 => WADATS(IMOD)%MAPX2 -!/PR2 MAPY2 => WADATS(IMOD)%MAPY2 -!/PR2 MAPAXY => WADATS(IMOD)%MAPAXY -!/PR2 MAPXY => WADATS(IMOD)%MAPXY -!/PR2 MAPTH2 => WADATS(IMOD)%MAPTH2 -!/PR2 MAPWN2 => WADATS(IMOD)%MAPWN2 -! -!/PR3 MAPX2 => WADATS(IMOD)%MAPX2 -!/PR3 MAPY2 => WADATS(IMOD)%MAPY2 -!/PR3 MAPAXY => WADATS(IMOD)%MAPAXY -!/PR3 MAPCXY => WADATS(IMOD)%MAPCXY -!/PR3 MAPTH2 => WADATS(IMOD)%MAPTH2 -!/PR3 MAPWN2 => WADATS(IMOD)%MAPWN2 -!/PR3 MAPTRN => WADATS(IMOD)%MAPTRN +#ifdef W3_PR1 + IS0 => WADATS(IMOD)%IS0 + IS2 => WADATS(IMOD)%IS2 + FACVX => WADATS(IMOD)%FACVX + FACVY => WADATS(IMOD)%FACVY +#endif +! +#ifdef W3_PR2 + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPXY => WADATS(IMOD)%MAPXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 +#endif +! +#ifdef W3_PR3 + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPCXY => WADATS(IMOD)%MAPCXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 + MAPTRN => WADATS(IMOD)%MAPTRN +#endif ! IF (GTYPE .EQ. UNGTYPE) ITER => WADATS(IMOD)%ITER ! @@ -2860,49 +3038,55 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) ! END IF ! -!/NL1 IF ( NLINIT ) THEN -!/NL1 IP11 => WADATS(IMOD)%IP11 -!/NL1 IP12 => WADATS(IMOD)%IP12 -!/NL1 IP13 => WADATS(IMOD)%IP13 -!/NL1 IP14 => WADATS(IMOD)%IP14 -!/NL1 IM11 => WADATS(IMOD)%IM11 -!/NL1 IM12 => WADATS(IMOD)%IM12 -!/NL1 IM13 => WADATS(IMOD)%IM13 -!/NL1 IM14 => WADATS(IMOD)%IM14 -!/NL1 IP21 => WADATS(IMOD)%IP21 -!/NL1 IP22 => WADATS(IMOD)%IP22 -!/NL1 IP23 => WADATS(IMOD)%IP23 -!/NL1 IP24 => WADATS(IMOD)%IP24 -!/NL1 IM21 => WADATS(IMOD)%IM21 -!/NL1 IM22 => WADATS(IMOD)%IM22 -!/NL1 IM23 => WADATS(IMOD)%IM23 -!/NL1 IM24 => WADATS(IMOD)%IM24 -!/NL1 IC11 => WADATS(IMOD)%IC11 -!/NL1 IC12 => WADATS(IMOD)%IC12 -!/NL1 IC21 => WADATS(IMOD)%IC21 -!/NL1 IC22 => WADATS(IMOD)%IC22 -!/NL1 IC31 => WADATS(IMOD)%IC31 -!/NL1 IC32 => WADATS(IMOD)%IC32 -!/NL1 IC41 => WADATS(IMOD)%IC41 -!/NL1 IC42 => WADATS(IMOD)%IC42 -!/NL1 IC51 => WADATS(IMOD)%IC51 -!/NL1 IC52 => WADATS(IMOD)%IC52 -!/NL1 IC61 => WADATS(IMOD)%IC61 -!/NL1 IC62 => WADATS(IMOD)%IC62 -!/NL1 IC71 => WADATS(IMOD)%IC71 -!/NL1 IC72 => WADATS(IMOD)%IC72 -!/NL1 IC81 => WADATS(IMOD)%IC81 -!/NL1 IC82 => WADATS(IMOD)%IC82 -!/NL1 AF11 => WADATS(IMOD)%AF11 -!/NL1 END IF +#ifdef W3_NL1 + IF ( NLINIT ) THEN + IP11 => WADATS(IMOD)%IP11 + IP12 => WADATS(IMOD)%IP12 + IP13 => WADATS(IMOD)%IP13 + IP14 => WADATS(IMOD)%IP14 + IM11 => WADATS(IMOD)%IM11 + IM12 => WADATS(IMOD)%IM12 + IM13 => WADATS(IMOD)%IM13 + IM14 => WADATS(IMOD)%IM14 + IP21 => WADATS(IMOD)%IP21 + IP22 => WADATS(IMOD)%IP22 + IP23 => WADATS(IMOD)%IP23 + IP24 => WADATS(IMOD)%IP24 + IM21 => WADATS(IMOD)%IM21 + IM22 => WADATS(IMOD)%IM22 + IM23 => WADATS(IMOD)%IM23 + IM24 => WADATS(IMOD)%IM24 + IC11 => WADATS(IMOD)%IC11 + IC12 => WADATS(IMOD)%IC12 + IC21 => WADATS(IMOD)%IC21 + IC22 => WADATS(IMOD)%IC22 + IC31 => WADATS(IMOD)%IC31 + IC32 => WADATS(IMOD)%IC32 + IC41 => WADATS(IMOD)%IC41 + IC42 => WADATS(IMOD)%IC42 + IC51 => WADATS(IMOD)%IC51 + IC52 => WADATS(IMOD)%IC52 + IC61 => WADATS(IMOD)%IC61 + IC62 => WADATS(IMOD)%IC62 + IC71 => WADATS(IMOD)%IC71 + IC72 => WADATS(IMOD)%IC72 + IC81 => WADATS(IMOD)%IC81 + IC82 => WADATS(IMOD)%IC82 + AF11 => WADATS(IMOD)%AF11 + END IF +#endif -!/MPI IF ( NRQSG1 .NE. 0 ) THEN -!/MPI IRQSG1 => WADATS(IMOD)%IRQSG1 -!/MPI IRQSG2 => WADATS(IMOD)%IRQSG2 -!/MPI END IF +#ifdef W3_MPI + IF ( NRQSG1 .NE. 0 ) THEN + IRQSG1 => WADATS(IMOD)%IRQSG1 + IRQSG2 => WADATS(IMOD)%IRQSG2 + END IF +#endif ! -!/MPI GSTORE => WADATS(IMOD)%GSTORE -!/MPI SSTORE => WADATS(IMOD)%SSTORE +#ifdef W3_MPI + GSTORE => WADATS(IMOD)%GSTORE + SSTORE => WADATS(IMOD)%SSTORE +#endif ! RETURN ! @@ -2914,7 +3098,9 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) ' IMOD = ',I10/ & ' NADATA = ',I10/) ! -!/T 9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') +#endif !/ !/ End of W3SETA ----------------------------------------------------- / !/ @@ -2945,7 +3131,9 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -2957,9 +3145,13 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3XETA') +#ifdef W3_S + CALL STRACE (IENT, 'W3XETA') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -2974,7 +3166,9 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model numbers @@ -3097,7 +3291,9 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) ' IMOD = ',I10/ & ' NADATA = ',I10/) ! -!/T 9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') +#endif !/ !/ End of W3XETA ----------------------------------------------------- / !/ diff --git a/model/ftn/w3agcmmd.ftn b/model/src/w3agcmmd.F90 similarity index 100% rename from model/ftn/w3agcmmd.ftn rename to model/src/w3agcmmd.F90 diff --git a/model/ftn/w3arrymd.ftn b/model/src/w3arrymd.F90 similarity index 93% rename from model/ftn/w3arrymd.ftn rename to model/src/w3arrymd.F90 index cecd00088..de3cbe5ec 100644 --- a/model/ftn/w3arrymd.ftn +++ b/model/src/w3arrymd.F90 @@ -144,7 +144,9 @@ SUBROUTINE INA2R (ARRAY, MX, MY, LX, HX, LY, HY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3SERVMD, ONLY: EXTCDE ! IMPLICIT NONE @@ -162,14 +164,20 @@ SUBROUTINE INA2R (ARRAY, MX, MY, LX, HX, LY, HY, & !/ Local parameters !/ INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INA2R') +#ifdef W3_S + CALL STRACE (IENT, 'INA2R') +#endif ! -!/T WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & -!/T IDFM, RFORM, IDLA, VSC, VOF +#ifdef W3_T + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF +#endif ! IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN IIDFM = 1 @@ -274,7 +282,9 @@ SUBROUTINE INA2R (ARRAY, MX, MY, LX, HX, LY, HY, & ' ERROR IN READING FROM FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST INA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +#ifdef W3_T + 9000 FORMAT (' TEST INA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +#endif !/ !/ End of INA2R ----------------------------------------------------- / !/ @@ -305,7 +315,9 @@ SUBROUTINE INA2I (ARRAY, MX, MY, LX, HX, LY, HY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3SERVMD, ONLY: EXTCDE ! IMPLICIT NONE @@ -322,14 +334,20 @@ SUBROUTINE INA2I (ARRAY, MX, MY, LX, HX, LY, HY, & !/ Local parameters !/ INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INA2I') +#ifdef W3_S + CALL STRACE (IENT, 'INA2I') +#endif ! -!/T WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & -!/T IDFM, RFORM, IDLA, VSC, VOF +#ifdef W3_T + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF +#endif ! IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN IIDFM = 1 @@ -434,7 +452,9 @@ SUBROUTINE INA2I (ARRAY, MX, MY, LX, HX, LY, HY, & ' ERROR IN READING FROM FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST INA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +#ifdef W3_T + 9000 FORMAT (' TEST INA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +#endif !/ !/ End of INA2I ----------------------------------------------------- / !/ @@ -471,7 +491,9 @@ SUBROUTINE OUTA2R (ARRAY, MX, MY, LX, HX, LY, HY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3SERVMD, ONLY: EXTCDE ! IMPLICIT NONE @@ -488,14 +510,20 @@ SUBROUTINE OUTA2R (ARRAY, MX, MY, LX, HX, LY, HY, & !/ Local parameters !/ INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'OUTA2R') +#ifdef W3_S + CALL STRACE (IENT, 'OUTA2R') +#endif ! -!/T WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & -!/T IDFM, RFORM, IDLA, VSC, VOF +#ifdef W3_T + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF +#endif ! IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN IIDFM = 1 @@ -586,7 +614,9 @@ SUBROUTINE OUTA2R (ARRAY, MX, MY, LX, HX, LY, HY, & ' ERROR IN WRITING TO FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST OUTA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +#ifdef W3_T + 9000 FORMAT (' TEST OUTA2R : INPUT :'/6X,8I4,2I3,1X,A,I3,2E12.4) +#endif !/ !/ End of OUTA2R ----------------------------------------------------- / !/ @@ -616,7 +646,9 @@ SUBROUTINE OUTA2I (ARRAY, MX, MY, LX, HX, LY, HY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3SERVMD, ONLY: EXTCDE ! IMPLICIT NONE @@ -633,14 +665,20 @@ SUBROUTINE OUTA2I (ARRAY, MX, MY, LX, HX, LY, HY, & !/ Local parameters !/ INTEGER :: IIDFM, IIDLA, IX, IY, ISTAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'OUTA2I') +#ifdef W3_S + CALL STRACE (IENT, 'OUTA2I') +#endif ! -!/T WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & -!/T IDFM, RFORM, IDLA, VSC, VOF +#ifdef W3_T + WRITE (NDST,9000) MX, MY, LX, HX, LY, HY, NDS, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF +#endif ! IF (IDFM.LT.1 .OR. IDFM.GT.3) THEN IIDFM = 1 @@ -731,7 +769,9 @@ SUBROUTINE OUTA2I (ARRAY, MX, MY, LX, HX, LY, HY, & ' ERROR IN WRITING TO FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST OUTA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +#ifdef W3_T + 9000 FORMAT (' TEST OUTA2I : INPUT :'/6X,8I4,2I3,1X,A,I3,2I5) +#endif !/ !/ End of OUTA2I ----------------------------------------------------- / !/ @@ -757,7 +797,9 @@ SUBROUTINE OUTREA (NDS,ARRAY,DIM,ANAME) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -772,11 +814,15 @@ SUBROUTINE OUTREA (NDS,ARRAY,DIM,ANAME) !/ Local parameters !/ INTEGER :: I, K -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'OUTREA') +#ifdef W3_S + CALL STRACE (IENT, 'OUTREA') +#endif ! WRITE (NDS,8000) ANAME ! @@ -865,7 +911,9 @@ SUBROUTINE OUTINT ( NDS, IARRAY, DIM, ANAME ) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -879,11 +927,15 @@ SUBROUTINE OUTINT ( NDS, IARRAY, DIM, ANAME ) !/ Local parameters !/ INTEGER :: I, K -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'OUTINT') +#ifdef W3_S + CALL STRACE (IENT, 'OUTINT') +#endif ! WRITE (NDS,8000) ANAME ! @@ -975,7 +1027,9 @@ SUBROUTINE OUTMAT (NDS,A,MX,NX,NY,MNAME) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -990,11 +1044,15 @@ SUBROUTINE OUTMAT (NDS,A,MX,NX,NY,MNAME) !/ Local parameters !/ INTEGER :: LBLOK, NBLOK, IBLOK, IX, IX1, IX2, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'OUTMAT') +#ifdef W3_S + CALL STRACE (IENT, 'OUTMAT') +#endif ! WRITE(NDS,8000) MNAME ! @@ -1117,7 +1175,9 @@ SUBROUTINE PRTBLK (NDS, NX, NY, MX, F, MAP, MAP0, FSC, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1133,7 +1193,9 @@ SUBROUTINE PRTBLK (NDS, NX, NY, MX, F, MAP, MAP0, FSC, & !/ Local parameters !/ INTEGER :: IX, IY, JJ, JM, K1, LX, I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FMAX, RR LOGICAL :: FLSCLE CHARACTER :: PNUM*5, STRA*5, PNUM2*2, STRA3*3 @@ -1141,7 +1203,9 @@ SUBROUTINE PRTBLK (NDS, NX, NY, MX, F, MAP, MAP0, FSC, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'PRTBLK') +#ifdef W3_S + CALL STRACE (IENT, 'PRTBLK') +#endif ! ! Check scaling ! @@ -1370,7 +1434,9 @@ SUBROUTINE PRT1DS (NDS, NFR, E, FR, UFR, NLINES, FTOPI, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1386,7 +1452,9 @@ SUBROUTINE PRT1DS (NDS, NFR, E, FR, UFR, NLINES, FTOPI, & !/ Local parameters !/ INTEGER :: NFRB, IFR, IL, IL0 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, SAVE :: TOPFAC = 1.1 REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & EMAX, EMIN, EXTR, FLOC @@ -1396,7 +1464,9 @@ SUBROUTINE PRT1DS (NDS, NFR, E, FR, UFR, NLINES, FTOPI, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'PRT1DS') +#ifdef W3_S + CALL STRACE (IENT, 'PRT1DS') +#endif ! FTOP = FTOPI ! @@ -1626,7 +1696,9 @@ SUBROUTINE PRT1DM (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1645,7 +1717,9 @@ SUBROUTINE PRT1DM (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, & INTEGER, PARAMETER :: NFRMAX = 100 INTEGER, PARAMETER :: NFM2 = NFRMAX+1 INTEGER :: NFRB, IFR, IE, IL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, SAVE :: TOPFAC = 1.1 REAL :: FTOP, RLINES, FACFR, FSC, FLINE, & EMAX, EMIN, EXTR, FLOC @@ -1655,35 +1729,39 @@ SUBROUTINE PRT1DM (NDS, NFR, NE, E, FR, UFR, NLINES, FTOPI, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'PRT1DM') +#ifdef W3_S + CALL STRACE (IENT, 'PRT1DM') +#endif ! ! Test output, echo input ! -!/T WRITE (*,*) -!/T WRITE (*,*) 'TEST OUTPUT PRT1DM, ECHO OF INPUT' -!/T WRITE (*,*) '=======================================', & -!/T '=======================================' -!/T WRITE (*,*) 'File unit number : ', NDS -!/T WRITE (*,*) 'Number of frequencies : ', NFR -!/T WRITE (*,*) 'Number of spectra : ', NE -!/T DO IE=1, NE -!/T WRITE (*,*) 'Spectral densities spectrum ', IE -!/T WRITE (*,'(6X,8E9.2)') (E(IFR,IE),IFR=1,NFR) -!/T END DO -!/T WRITE (*,*) 'Frequencies' -!/T WRITE (*,'(6X,8E9.2)') (FR(IFR),IFR=1,NFR) -!/T WRITE (*,*) 'Frequency type : ', UFR -!/T WRITE (*,*) 'NLINES : ', NLINES -!/T WRITE (*,*) 'FTOPI : ', FTOPI -!/T WRITE (*,*) 'Names of spectra : ', PRVAR(1) -!/T DO IE=2, NE -!/T WRITE (*,*) ' ', PRVAR(IE) -!/T END DO -!/T WRITE (*,*) 'Units of spectra : ', PRUNIT -!/T WRITE (*,*) 'Name of location : ', PNTNME -!/T WRITE (*,*) '=======================================', & -!/T '=======================================' -!/T WRITE (*,*) +#ifdef W3_T + WRITE (*,*) + WRITE (*,*) 'TEST OUTPUT PRT1DM, ECHO OF INPUT' + WRITE (*,*) '=======================================', & + '=======================================' + WRITE (*,*) 'File unit number : ', NDS + WRITE (*,*) 'Number of frequencies : ', NFR + WRITE (*,*) 'Number of spectra : ', NE + DO IE=1, NE + WRITE (*,*) 'Spectral densities spectrum ', IE + WRITE (*,'(6X,8E9.2)') (E(IFR,IE),IFR=1,NFR) + END DO + WRITE (*,*) 'Frequencies' + WRITE (*,'(6X,8E9.2)') (FR(IFR),IFR=1,NFR) + WRITE (*,*) 'Frequency type : ', UFR + WRITE (*,*) 'NLINES : ', NLINES + WRITE (*,*) 'FTOPI : ', FTOPI + WRITE (*,*) 'Names of spectra : ', PRVAR(1) + DO IE=2, NE + WRITE (*,*) ' ', PRVAR(IE) + END DO + WRITE (*,*) 'Units of spectra : ', PRUNIT + WRITE (*,*) 'Name of location : ', PNTNME + WRITE (*,*) '=======================================', & + '=======================================' + WRITE (*,*) +#endif ! FTOP = FTOPI NFRB = MIN (NFR,50) @@ -1941,7 +2019,9 @@ SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1957,7 +2037,9 @@ SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & !/ Local parameters !/ INTEGER :: IFR, ITH, NFRB, INTANG, ITHSEC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: FLSCLE REAL :: FACFR, EMAX, EMIN, DTHDEG, RR, RRC CHARACTER :: PNUM*5, STRA*5, STRANG*5, PNUM2*2, & @@ -1966,10 +2048,14 @@ SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'PRT2DS') +#ifdef W3_S + CALL STRACE (IENT, 'PRT2DS') +#endif ! -!/T WRITE (NDS,9000) NDS, NFR0, NFR, NTH, UFR, FACSP, FSC, & -!/T RRCUT, PRVAR, PRUNIT, PNTNME +#ifdef W3_T + WRITE (NDS,9000) NDS, NFR0, NFR, NTH, UFR, FACSP, FSC, & + RRCUT, PRVAR, PRUNIT, PNTNME +#endif ! ! initialisations ! @@ -2181,17 +2267,19 @@ SUBROUTINE PRT2DS (NDS, NFR0, NFR, NTH, E, FR, UFR, FACSP, FSC, & ! 950 FORMAT (' ') ! -!/T 9000 FORMAT ( ' TEST PRT2DS : ECHO OF INPUT PARAMETERS'/ & -!/T ' NDS :',I6/ & -!/T ' NFR0, NFR :',2I6/ & -!/T ' NTH :',I6/ & -!/T ' UFR : ',A/ & -!/T ' FACSP :',E10.3/ & -!/T ' FSC :',E10.3/ & -!/T ' RRCUT :',E10.3/ & -!/T ' PRVAR : ',A/ & -!/T ' PRUNIT : ',A/ & -!/T ' PNTNME : ',A) +#ifdef W3_T + 9000 FORMAT ( ' TEST PRT2DS : ECHO OF INPUT PARAMETERS'/ & + ' NDS :',I6/ & + ' NFR0, NFR :',2I6/ & + ' NTH :',I6/ & + ' UFR : ',A/ & + ' FACSP :',E10.3/ & + ' FSC :',E10.3/ & + ' RRCUT :',E10.3/ & + ' PRVAR : ',A/ & + ' PRUNIT : ',A/ & + ' PNTNME : ',A) +#endif !/ !/ Internal subroutine ANGSTR ---------------------------------------- / !/ @@ -2220,7 +2308,9 @@ SUBROUTINE ANGSTR (IANG, SANG, ILEN, INUM) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ diff --git a/model/ftn/w3bullmd.ftn b/model/src/w3bullmd.F90 similarity index 91% rename from model/ftn/w3bullmd.ftn rename to model/src/w3bullmd.F90 index 42d9abf9a..9bf9997a2 100644 --- a/model/ftn/w3bullmd.ftn +++ b/model/src/w3bullmd.F90 @@ -29,7 +29,9 @@ MODULE W3BULLMD DMT(NPTAB,2) CHARACTER(LEN=129) :: ASCBLINE CHARACTER(LEN=664) :: CSVBLINE -!/NCO CHARACTER(LEN=67) :: CASCBLINE +#ifdef W3_NCO + CHARACTER(LEN=67) :: CASCBLINE +#endif LOGICAL :: IYY(NPMAX) !/ !/ Conventional declarations @@ -115,7 +117,9 @@ SUBROUTINE W3BULL & ! !/ ------------------------------------------------------------------- / ! USE CONSTANTS -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -132,7 +136,9 @@ SUBROUTINE W3BULL & ! -------------------------------------------------------------------- / ! 1. Initializations ! -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DHSMAX, DTPMAX, & DDMMAX, DDWMAX, AGEMIN PARAMETER ( DHSMAX = 1.50 ) @@ -155,16 +161,22 @@ SUBROUTINE W3BULL & TPD(NPMAX), WDD(NPMAX) LOGICAL :: FLAG(NPMAX) CHARACTER(LEN=129) :: BLANK, TAIL !, ASCBLINE -!/NCO CHARACTER(LEN=67) :: CBLANK, CTAIL !, CASCBLINE +#ifdef W3_NCO + CHARACTER(LEN=67) :: CBLANK, CTAIL !, CASCBLINE +#endif CHARACTER(LEN=15) :: PART -!/NCO CHARACTER(LEN=9) :: CPART +#ifdef W3_NCO + CHARACTER(LEN=9) :: CPART +#endif CHARACTER(LEN=664) :: BLANK2 !,CSVBLINE CHARACTER :: STIME*8,FORM*20,FORM1*2 CHARACTER(LEN=16) :: PART2 !/ !/ ------------------------------------------------------------------- / ! -!/S CALL STRACE (IENT, 'XXXXXX') +#ifdef W3_S + CALL STRACE (IENT, 'XXXXXX') +#endif ! ! 1.a Constants etc. ! @@ -187,11 +199,13 @@ SUBROUTINE W3BULL & BLANK( 81:120) = ' | | ' BLANK(120:129) = ' |' ASCBLINE = BLANK -!/NCO CTAIL( 1:40) = '----------------------------------------' -!/NCO CTAIL(41:67) = '---------------------------' -!/NCO CBLANK( 1:40) = ' ' -!/NCO CBLANK(41:67) = ' ' -!/NCO CASCBLINE = CBLANK +#ifdef W3_NCO + CTAIL( 1:40) = '----------------------------------------' + CTAIL(41:67) = '---------------------------' + CBLANK( 1:40) = ' ' + CBLANK(41:67) = ' ' + CASCBLINE = CBLANK +#endif ! BLANK2( 1: 40)=' , , , , , , , , ' BLANK2( 41: 88)=', , , , , , , , , ' @@ -258,7 +272,9 @@ SUBROUTINE W3BULL & ! ASCBLINE = BLANK CSVBLINE = BLANK2 -!/NCO CASCBLINE = CBLANK +#ifdef W3_NCO + CASCBLINE = CBLANK +#endif ! ! Fill the variable forecast time with hrs relative to reference time IF ( TIMEV(1) .LE. 0 ) TIMEV = TIME @@ -286,9 +302,11 @@ SUBROUTINE W3BULL & IF ( HSTOT .GT. 0. ) WRITE (ASCBLINE(10:14),'(F5.2)') HSTOT WRITE (ASCBLINE(16:17),'(I2)') NPART - NZERO ! -!/NCO WRITE (CASCBLINE(1:2),'(I2.2)') MOD(TIME(1),100) -!/NCO WRITE (CASCBLINE(3:4),'(I2.2)') TIME(2)/10000 -!/NCO IF ( HSTOT .GT. 0. ) WRITE (CASCBLINE(6:7),'(I2)') NINT(HSTOT/0.3048) +#ifdef W3_NCO + WRITE (CASCBLINE(1:2),'(I2.2)') MOD(TIME(1),100) + WRITE (CASCBLINE(3:4),'(I2.2)') TIME(2)/10000 + IF ( HSTOT .GT. 0. ) WRITE (CASCBLINE(6:7),'(I2)') NINT(HSTOT/0.3048) +#endif ! IF ( NPART.EQ.0 .OR. HSTOT.LT.0.1 ) GOTO 699 ! @@ -352,10 +370,12 @@ SUBROUTINE W3BULL & ! WRITE (PART,'(1X,F5.2,F5.1,I4)') & HSP(IPNOW), TPP(IPNOW), NINT(DMP(IPNOW)) -!/NCO WRITE (CPART,'(I2,1X,I2.2,1X,I3.3)') & -!/NCO NINT(HSP(IPNOW)/0.3048), & -!/NCO NINT(TPP(IPNOW)), & -!/NCO NINT(MOD(DMP(IPNOW)+180.,360.)) +#ifdef W3_NCO + WRITE (CPART,'(I2,1X,I2.2,1X,I3.3)') & + NINT(HSP(IPNOW)/0.3048), & + NINT(TPP(IPNOW)), & + NINT(MOD(DMP(IPNOW)+180.,360.)) +#endif DELDW = MOD ( ABS ( UDIR - DMP(IPNOW) ) , 360. ) IF ( DELDW .GT. 180. ) DELDW = 360. - DELDW AFR = 2.*PI/TPP(IPNOW) @@ -363,7 +383,9 @@ SUBROUTINE W3BULL & IF ( DELDW.LT.DDWMAX .AND. AGE.GT.AGEMIN ) PART(1:1) = '*' ! ASCBLINE(5+ITAB*18:19+ITAB*18) = PART -!/NCO CASCBLINE(ITAB*10-1:ITAB*10+7) = CPART +#ifdef W3_NCO + CASCBLINE(ITAB*10-1:ITAB*10+7) = CPART +#endif ! DO IFLD=1,NPTAB IF(ITAB.EQ.IFLD)THEN diff --git a/model/ftn/w3canomd.ftn b/model/src/w3canomd.F90 similarity index 98% rename from model/ftn/w3canomd.ftn rename to model/src/w3canomd.F90 index 2f2b9a1c1..c7594b655 100644 --- a/model/ftn/w3canomd.ftn +++ b/model/src/w3canomd.F90 @@ -93,16 +93,24 @@ MODULE W3CANOMD INTEGER :: NDEPTH REAL :: DEPTHA ! first depth in table REAL, SAVE , PRIVATE, ALLOCATABLE :: OMEGA(:) -!/OMPG/!$omp threadprivate( OMEGA ) +#ifdef W3_OMPG +!$omp threadprivate( OMEGA ) +#endif INTEGER, SAVE , PRIVATE :: COUNTER = 0 -!/OMPG/!$omp threadprivate( COUNTER ) +#ifdef W3_OMPG +!$omp threadprivate( COUNTER ) +#endif ! Tables for non-linear coefficients ... REAL, SAVE , PRIVATE, ALLOCATABLE :: TA(:,:,:,:),TB(:,:,:,:),TC_QL(:,:,:,:),& TT_4M(:,:,:,:),TT_4P(:,:,:,:),TFAKH(:,:), & TFAK(:,:) -!/OMPG/!$omp threadprivate( TA, TB, TC_QL, TT_4M, TT_4P, TFAKH, TFAK ) +#ifdef W3_OMPG +!$omp threadprivate( TA, TB, TC_QL, TT_4M, TT_4P, TFAKH, TFAK ) +#endif INTEGER, SAVE, PRIVATE, ALLOCATABLE :: IM_P(:,:),IM_M(:,:) -!/OMPG/!$omp threadprivate( IM_P, IM_M ) +#ifdef W3_OMPG +!$omp threadprivate( IM_P, IM_M ) +#endif ! @@ -185,7 +193,9 @@ SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION) USE W3DISPMD USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DTH, IGPARS -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ ! IMPLICIT NONE @@ -204,19 +214,29 @@ SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION) !/ INTEGER :: ISPEC, IK, ITH, M REAL :: CO1, ATOE, DPTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL, SAVE :: FIRST = .TRUE. -!/OMPG/!$omp threadprivate( FIRST ) +#ifdef W3_OMPG +!$omp threadprivate( FIRST ) +#endif REAL, ALLOCATABLE, SAVE :: FR(:), DFIM(:) REAL, ALLOCATABLE, SAVE :: F1(:,:), F3(:,:) -!/OMPG/!$omp threadprivate( FR, DFIM, F1, F3 ) +#ifdef W3_OMPG +!$omp threadprivate( FR, DFIM, F1, F3 ) +#endif INTEGER, SAVE :: NFRE, NANG INTEGER, SAVE :: NFREH, NANGH -!/OMPG/!$omp threadprivate( NFRE, NANG, NFREH, NANGH ) +#ifdef W3_OMPG +!$omp threadprivate( NFRE, NANG, NFREH, NANGH ) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3ADD2NDORDER') +#ifdef W3_S + CALL STRACE (IENT, 'W3ADD2NDORDER') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -283,7 +303,9 @@ SUBROUTINE W3ADD2NDORDER(E,DEPTH,WN,CG,IACTION) !WRITE(101,'(I3,100G16.8)') SIG(IK)*ZPI,(F3(ITH,IK),ITH=1,NTH) END DO -!/T PRINT*,' END CAL_SEC_ORDER_SPEC' +#ifdef W3_T + PRINT*,' END CAL_SEC_ORDER_SPEC' +#endif RETURN END SUBROUTINE W3ADD2NDORDER @@ -349,12 +371,16 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & INTEGER MDW,M,K, K0,M0,MP,KP,MM,KM,KL,KLL,ML,JD INTEGER, SAVE :: MR, MA,NMAX -!/OMPG/!$omp threadprivate( MR, MA, NMAX ) +#ifdef W3_OMPG +!$omp threadprivate( MR, MA, NMAX ) +#endif ! PARAMETER (NFREH=32,NANGH=36) INTEGER, SAVE :: INDEP -!/OMPG/!$omp threadprivate( INDEP ) +#ifdef W3_OMPG +!$omp threadprivate( INDEP ) +#endif REAL,ALLOCATABLE :: PF1(:,:),PF3(:,:) @@ -365,7 +391,9 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & C2,XM,XK REAL, SAVE :: OMSTART REAL, SAVE :: XMR,XMA, DELTHH, CO1 -!/OMPG/!$omp threadprivate( OMSTART, XMR,XMA, DELTHH, CO1 ) +#ifdef W3_OMPG +!$omp threadprivate( OMSTART, XMR,XMA, DELTHH, CO1 ) +#endif REAL :: F13(NFREH,NANGH) REAL :: SUM0,AKMEAN REAL :: DELOM(NFREH),THH(NANGH),DFDTH(NFREH) @@ -380,7 +408,9 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & ! ---------------------------------------------------- ! -!/T PRINT*,' START SECOND-ORDER CALC.' +#ifdef W3_T + PRINT*,' START SECOND-ORDER CALC.' +#endif DOUBLEP = .TRUE. ! @@ -435,7 +465,9 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & ! NMAX = XMR*(1+NINT(LOG(2.*OMEGA(NFREH)/OMSTART)/LOG(1.+FRAC))) NMAX = NMAX+1 -!/T PRINT*,' NMAX = ',NMAX +#ifdef W3_T + PRINT*,' NMAX = ',NMAX +#endif DEPTHD = 1.1 @@ -486,8 +518,10 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & !*** 2.21 NO INTERPOLATION. ! ---------------------- ! -!/T PRINT*,' NO THINNING AND INTERPOLATION' -!/T PRINT*,'nanG:',NANG,NMAX,NFRE,NDEPTH,DEPTHA,DEPTHD,DPTH,'##',DELTH,DELTHH +#ifdef W3_T + PRINT*,' NO THINNING AND INTERPOLATION' + PRINT*,'nanG:',NANG,NMAX,NFRE,NDEPTH,DEPTHA,DEPTHD,DPTH,'##',DELTH,DELTHH +#endif CALL SECSPOM(F1,F3,NFRE,NANG,NMAX,NDEPTH,& DEPTHA,DEPTHD,OMSTART,FRAC,MR,DFDTH,OMEGA,& @@ -592,8 +626,10 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & BB1 = MAX(BB1,EPSMIN) F = OMEGA(M)/ZPI -!/T WRITE(6,62) M,F,AA1,BB1,DELTHH -!/T WRITE(80,62) M,F,AA1,BB1,DELTHH +#ifdef W3_T + WRITE(6,62) M,F,AA1,BB1,DELTHH + WRITE(80,62) M,F,AA1,BB1,DELTHH +#endif ENDDO DO M=1,NFREH @@ -604,7 +640,9 @@ SUBROUTINE CAL_SEC_ORDER_SPEC(F1,F3,NFRE,NANG,FR,DFIM,TH,DELTH, & ENDIF ! -!/T 62 FORMAT(I4,9F16.9) +#ifdef W3_T + 62 FORMAT(I4,9F16.9) +#endif ! RETURN END SUBROUTINE CAL_SEC_ORDER_SPEC diff --git a/model/ftn/w3cspcmd.ftn b/model/src/w3cspcmd.F90 similarity index 86% rename from model/ftn/w3cspcmd.ftn rename to model/src/w3cspcmd.F90 index e2038ddca..15594b2ae 100644 --- a/model/ftn/w3cspcmd.ftn +++ b/model/src/w3cspcmd.F90 @@ -182,7 +182,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & USE CONSTANTS ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -199,7 +201,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & !/ INTEGER :: I, NRMAX, J, I1, L1, J1, I2, L2, J2, & ISP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: LOW, HGH, RLOW, RHGH, BLOW, BHGH, & FRAC, AUX1, AUX2, R1, R2, FACT LOGICAL :: FOUND @@ -212,7 +216,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & REAL, POINTER :: DTH1, DTH2, RDTH(:,:), FRQ1(:), & FRQ2(:), XDF1, XDF2, RDFR(:,:) !/ -!/S CALL STRACE (IENT, 'W3CSPC') +#ifdef W3_S + CALL STRACE (IENT, 'W3CSPC') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -236,8 +242,10 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ! ! 0.b Test output ! -!/T WRITE (NDST,9000) NSP, NFR1, NTH1, XF1, FR1, TH1*RADE, & -!/T NFR2, NTH2, XF2, FR2, TH2*RADE, FTL +#ifdef W3_T + WRITE (NDST,9000) NSP, NFR1, NTH1, XF1, FR1, TH1*RADE, & + NFR2, NTH2, XF2, FR2, TH2*RADE, FTL +#endif ! ! -------------------------------------------------------------------- / ! 1. Search stored interpolation data for match @@ -252,10 +260,12 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & CURRENT => CURRENT%NEXT END IF ! -!/T1 WRITE (NDST,9010) I, CURRENT%NFR1, CURRENT%NTH1, & -!/T1 CURRENT%XF1, CURRENT%FR1, CURRENT%TH1*RADE, & -!/T1 CURRENT%NFR2, CURRENT%NTH2, & -!/T1 CURRENT%XF2, CURRENT%FR2, CURRENT%TH2*RADE +#ifdef W3_T1 + WRITE (NDST,9010) I, CURRENT%NFR1, CURRENT%NTH1, & + CURRENT%XF1, CURRENT%FR1, CURRENT%TH1*RADE, & + CURRENT%NFR2, CURRENT%NTH2, & + CURRENT%XF2, CURRENT%FR2, CURRENT%TH2*RADE +#endif ! FOUND = CURRENT%NFR1.EQ.NFR1 .AND. CURRENT%NFR2.EQ.NFR2 .AND. & CURRENT%NTH1.EQ.NTH1 .AND. CURRENT%NTH2.EQ.NTH2 .AND. & @@ -272,7 +282,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ! IF ( FOUND ) THEN ! -!/T WRITE (NDST,9020) I +#ifdef W3_T + WRITE (NDST,9020) I +#endif ! DTH1 => CURRENT%DTH1 DTH2 => CURRENT%DTH2 @@ -292,7 +304,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ELSE ! NCASES = NCASES + 1 -!/T WRITE (NDST,9021) NCASES +#ifdef W3_T + WRITE (NDST,9021) NCASES +#endif ! ! 2.b.1 Point and allocate as necessary ! @@ -441,22 +455,26 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ! ! 2.c Test output ! -!/T2 WRITE (NDST,9022) -!/T2 DO I=1, NTH1 -!/T2 WRITE (NDST,9024) I, IDTH(0,I), & -!/T2 (IDTH(J,I),RDTH(J,I),J=1,IDTH(0,I)) -!/T2 END DO -!/T2 WRITE (NDST,9023) NFR2T -!/T2 DO I=1, NFR1 -!/T2 WRITE (NDST,9024) I, IDFR(0,I), & -!/T2 (IDFR(J,I),RDFR(J,I),J=1,IDFR(0,I)) -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9022) + DO I=1, NTH1 + WRITE (NDST,9024) I, IDTH(0,I), & + (IDTH(J,I),RDTH(J,I),J=1,IDTH(0,I)) + END DO + WRITE (NDST,9023) NFR2T + DO I=1, NFR1 + WRITE (NDST,9024) I, IDFR(0,I), & + (IDFR(J,I),RDFR(J,I),J=1,IDFR(0,I)) + END DO +#endif ! ! -------------------------------------------------------------------- / ! 3. Convert ! 3.a Discrete energies ! -!/T WRITE (NDST,9030) +#ifdef W3_T + WRITE (NDST,9030) +#endif ! SP2 = 0. ! @@ -477,7 +495,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ! ! 3.b Energy densities ! -!/T WRITE (NDST,9031) +#ifdef W3_T + WRITE (NDST,9031) +#endif ! DO J2=1, NFR2 DO J1=1, NTH2 @@ -488,7 +508,9 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & ! ! 3.c Add the tail ! -!/T WRITE (NDST,9032) +#ifdef W3_T + WRITE (NDST,9032) +#endif ! DO J2=NFR2T, NFR2 SP2(:,J2,:) = FTL * SP2(:,J2-1,:) @@ -504,25 +526,35 @@ SUBROUTINE W3CSPC ( SP1, NFR1, NTH1, XF1, FR1, TH1, & 901 FORMAT (/' *** ERROR W3CSPC: NEGATIVE NUMBER OF SPECTRA ***'/) 902 FORMAT (/' *** WARNING W3CSPC: NO SPECTRA ***'/) ! -!/T 9000 FORMAT ( ' TEST W3CSPC : NR. OF SPECTRA : ',I8/ & -!/T ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & -!/T ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1/ & -!/T ' TAIL FACTOR : ',F8.5) -! -!/T1 9010 FORMAT ( ' TEST W3CSPC : TEST INFO CASE : ',I8/ & -!/T1 ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & -!/T1 ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1) -! -!/T 9020 FORMAT ( ' TEST W3CSPC : USING STORED DATA FOR CASE',I4) -!/T 9021 FORMAT ( ' TEST W3CSPC : COMPUTING DATA FOR CASE',I4) -!/T2 9022 FORMAT ( ' TEST W3CSPC : DIRECTIONAL DISTRIBUTION DATA') -!/T2 9023 FORMAT ( ' TEST W3CSPC : FREQUENCY DISTRIBUTION DATA, ', & -!/T2 'TAIL AT',I4) -!/T2 9024 FORMAT ( ' ',I4,I4,' :',10(I4,F5.2) ) -! -!/T 9030 FORMAT ( ' TEST W3CSPC : STARTING CONVERSION') -!/T 9031 FORMAT ( ' TEST W3CSPC : ENERGIES TO DENSITIES') -!/T 9032 FORMAT ( ' TEST W3CSPC : ADD TAIL') +#ifdef W3_T + 9000 FORMAT ( ' TEST W3CSPC : NR. OF SPECTRA : ',I8/ & + ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' TAIL FACTOR : ',F8.5) +#endif +! +#ifdef W3_T1 + 9010 FORMAT ( ' TEST W3CSPC : TEST INFO CASE : ',I8/ & + ' INPUT SPECTRA : ',2I4,2F8.4,F6.1/ & + ' OUTPUT SPECTRA : ',2I4,2F8.4,F6.1) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST W3CSPC : USING STORED DATA FOR CASE',I4) + 9021 FORMAT ( ' TEST W3CSPC : COMPUTING DATA FOR CASE',I4) +#endif +#ifdef W3_T2 + 9022 FORMAT ( ' TEST W3CSPC : DIRECTIONAL DISTRIBUTION DATA') + 9023 FORMAT ( ' TEST W3CSPC : FREQUENCY DISTRIBUTION DATA, ', & + 'TAIL AT',I4) + 9024 FORMAT ( ' ',I4,I4,' :',10(I4,F5.2) ) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST W3CSPC : STARTING CONVERSION') + 9031 FORMAT ( ' TEST W3CSPC : ENERGIES TO DENSITIES') + 9032 FORMAT ( ' TEST W3CSPC : ADD TAIL') +#endif !/ !/ End of W3CSPC ----------------------------------------------------- / !/ diff --git a/model/ftn/w3dispmd.ftn b/model/src/w3dispmd.F90 similarity index 96% rename from model/ftn/w3dispmd.ftn rename to model/src/w3dispmd.F90 index 2d642041a..52de9b176 100644 --- a/model/ftn/w3dispmd.ftn +++ b/model/src/w3dispmd.F90 @@ -152,7 +152,9 @@ SUBROUTINE WAVNU1 (SI,H,K,CG) !/ ------------------------------------------------------------------- / !/ USE CONSTANTS, ONLY : GRAV -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -166,12 +168,16 @@ SUBROUTINE WAVNU1 (SI,H,K,CG) !/ Local parameters !/ INTEGER :: I1, I2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SQRTH, SIX, R1, R2 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'WAVNU1') +#ifdef W3_S + CALL STRACE (IENT, 'WAVNU1') +#endif ! SQRTH = SQRT(H) SIX = SI * SQRTH @@ -242,7 +248,9 @@ SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON) !/ ------------------------------------------------------------------- / !/ USE CONSTANTS, ONLY : GRAV -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -258,13 +266,17 @@ SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON) !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: F, W0, FD, DIF, RDIF, KOLD !REAL :: KTEST1, CGTEST1, KTEST2, CGTEST2 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'WAVNU2') +#ifdef W3_S + CALL STRACE (IENT, 'WAVNU2') +#endif ! ! Initialisations : ! @@ -517,7 +529,9 @@ SUBROUTINE DISTAB !/ ------------------------------------------------------------------- / !/ USE CONSTANTS, ONLY : GRAV -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -525,12 +539,16 @@ SUBROUTINE DISTAB !/ Local parameters !/ INTEGER :: I, ICON -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DEPTH, CG, SIMAX, SI, K !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'DISTAB') +#ifdef W3_S + CALL STRACE (IENT, 'DISTAB') +#endif ! ! Calculate parameters ----------------------------------------------- * ! @@ -670,7 +688,9 @@ SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & USE W3SERVMD, ONLY: EXTCDE USE W3GDATMD, ONLY: NK, IICEHDISP, IICEDDISP, IICEFDISP, IICEHMIN ! USE W3DISPMD, ONLY: WAVNU1 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -684,7 +704,9 @@ SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK REAL, PARAMETER :: FERRORMAX=1.0E-5 ! maximum acceptable error INTEGER, PARAMETER :: N_ITER=20 ! number of iterations prior to @@ -708,7 +730,9 @@ SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'LIU_FORWARD_DISPERSION') +#ifdef W3_S + CALL STRACE (IENT, 'LIU_FORWARD_DISPERSION') +#endif ! !/ 0) --- Initialize/allocate variables ------------------------------ / @@ -780,11 +804,13 @@ SUBROUTINE LIU_FORWARD_DISPERSION (H_ICE,VISC,H_WDEPTH,SIGMA & GET_CG,FDUMMY,CG(IK),ALPHA(IK)) END DO ! -!/T38 WRITE(*,*)'FORWARD OUT: K_SOLUTION,CG,ALPHA = ', & -!/T38 K_SOLUTION,CG,ALPHA -!/T38 IF (H_ICE==1.0)THEN -!/T38 WRITE(*,*)FWANTED,ALPHA -!/T38 ENDIF +#ifdef W3_T38 + WRITE(*,*)'FORWARD OUT: K_SOLUTION,CG,ALPHA = ', & + K_SOLUTION,CG,ALPHA + IF (H_ICE==1.0)THEN + WRITE(*,*)FWANTED,ALPHA + ENDIF +#endif ! 800 FORMAT (/' *** WAVEWATCH III ERROR IN ' & 'W3SIC2_LIU_FORWARD_DISPERSION : ' / & @@ -926,7 +952,9 @@ SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: DWAT, TPI, GRAV USE W3GDATMD, ONLY: NK -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -939,7 +967,9 @@ SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, PARAMETER :: E = 6.0E+9 ! Young's modulus of elasticity REAL, PARAMETER :: S = 0.3 ! "s", Poisson's ratio REAL :: DICE ! "dice", density of ice @@ -953,7 +983,9 @@ SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'LIU_REVERSE_DISPERSION') +#ifdef W3_S + CALL STRACE (IENT, 'LIU_REVERSE_DISPERSION') +#endif ! !/ 0) --- Initialize essential parameters ---------------------------- / CG = 0. @@ -961,8 +993,10 @@ SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & FREQ = 0. DICE = DWAT * 0.9 ! from Liu 1991 pg 4606 -!/T38 WRITE(*,*)'REVERSE IN: H_ICE,VISC,H_WDEPTH,KWN,GET_CG = ', & -!/T38 H_ICE,VISC,H_WDEPTH,KWN,GET_CG +#ifdef W3_T38 + WRITE(*,*)'REVERSE IN: H_ICE,VISC,H_WDEPTH,KWN,GET_CG = ', & + H_ICE,VISC,H_WDEPTH,KWN,GET_CG +#endif ! !/ 1) --- Calculate frequency ---------------------------------------- / @@ -992,7 +1026,9 @@ SUBROUTINE LIU_REVERSE_DISPERSION (H_ICE,VISC,H_WDEPTH,KWN & / (CG * SQRT(2.0) * (1 + KWN * M)) ENDIF -!/T38 WRITE(*,*)'REVERSE OUT: FREQ,CG,ALPHA = ',FREQ,CG,ALPHA +#ifdef W3_T38 + WRITE(*,*)'REVERSE OUT: FREQ,CG,ALPHA = ',FREQ,CG,ALPHA +#endif !/ !/ End of LIU_REVERSE_DISPERSION ------------------------------------- / diff --git a/model/ftn/w3fld1md.ftn b/model/src/w3fld1md.F90 similarity index 98% rename from model/ftn/w3fld1md.ftn rename to model/src/w3fld1md.F90 index f9f8c004f..970e20706 100644 --- a/model/ftn/w3fld1md.ftn +++ b/model/src/w3fld1md.F90 @@ -75,14 +75,18 @@ Module W3FLD1MD PUBLIC ! Tail_Choice: Chose the method to determine the level of the tail INTEGER, SAVE :: Tail_Choice -!/OMPG/!$omp threadprivate(Tail_Choice) +#ifdef W3_OMPG +!$omp threadprivate(Tail_Choice) +#endif REAL, SAVE :: Tail_Level !if Tail_Choice=0, tail is constant REAL, SAVE :: Tail_transition_ratio1! freq/fpi where tail ! adjustment begins REAL, SAVE :: Tail_transition_ratio2! freq/fpi where tail ! adjustment ends -!/OMPG/!$omp threadprivate(Tail_Level) -!/OMPG/!$omp threadprivate(Tail_transition_ratio1,Tail_transition_ratio2) +#ifdef W3_OMPG +!$omp threadprivate(Tail_Level) +!$omp threadprivate(Tail_transition_ratio1,Tail_transition_ratio2) +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -172,7 +176,9 @@ SUBROUTINE W3FLD1( ASPC, FPI, WNDX,WNDY, ZWND, & USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, XFR, TH USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -231,15 +237,21 @@ SUBROUTINE W3FLD1( ASPC, FPI, WNDX,WNDY, ZWND, & TLTED, ZOFK, UPROF, VPROF, & FTILDE, UP1, VP1, UP, VP, & TLTNA, TLTEA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: FSFL1,FSFL2, CRIT1, CRIT2 LOGICAL :: IT_FLAG1, IT_FLAG2 LOGICAL, SAVE :: FIRST = .TRUE. -!/OMPG/!$omp threadprivate( FIRST) +#ifdef W3_OMPG +!$omp threadprivate( FIRST) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLD1') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLD1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -824,7 +836,9 @@ SUBROUTINE INFLD USE W3ODATMD, ONLY: NDSE USE W3GDATMD, ONLY: TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -835,11 +849,15 @@ SUBROUTINE INFLD !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INFLD') +#ifdef W3_S + CALL STRACE (IENT, 'INFLD') +#endif ! ! 1. .... ----------------------------------------------------------- * ! @@ -918,7 +936,9 @@ SUBROUTINE APPENDTAIL(INSPC, WN2, NKT, KA1, KA2, KA3, WNDDIR,SAT) USE W3GDATMD, ONLY: NTH, TH, DTH USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -932,7 +952,9 @@ SUBROUTINE APPENDTAIL(INSPC, WN2, NKT, KA1, KA2, KA3, WNDDIR,SAT) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: BT(NKT), IC, ANGLE2, ANG(NKT),& NORMSPC(NTH), AVG, ANGDIF, M, MAXANG, & MAXAN, MINAN @@ -941,7 +963,9 @@ SUBROUTINE APPENDTAIL(INSPC, WN2, NKT, KA1, KA2, KA3, WNDDIR,SAT) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'APPENDTAIL') +#ifdef W3_S + CALL STRACE (IENT, 'APPENDTAIL') +#endif ! ! 1. .... ----------------------------------------------------------- * ! @@ -1278,7 +1302,9 @@ SUBROUTINE WND2Z0M( W10M , ZNOTM ) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE REAL, INTENT(IN) :: W10M @@ -1304,8 +1330,10 @@ SUBROUTINE WND2Z0M( W10M , ZNOTM ) !Variables from znot_wind10m REAL :: Z10, U10,AAA,TMP -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'WND2Z0M') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'WND2Z0M') +#endif !Values as set in znot_wind10m Z10=10.0 @@ -1396,15 +1424,21 @@ SUBROUTINE WND2SAT(WND10,SAT) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ REAL, INTENT(IN) :: WND10 REAL, INTENT(OUT) :: SAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/S CALL STRACE (IENT, 'WND2SAT') +#ifdef W3_S + CALL STRACE (IENT, 'WND2SAT') +#endif !/ Old HWRF 2015 and ST2 ! SAT =0.000000000001237 * WND10**6 +& ! -0.000000000364155 * WND10**5 +& diff --git a/model/ftn/w3fld2md.ftn b/model/src/w3fld2md.F90 similarity index 98% rename from model/ftn/w3fld2md.ftn rename to model/src/w3fld2md.F90 index dc4a74566..30d247cee 100644 --- a/model/ftn/w3fld2md.ftn +++ b/model/src/w3fld2md.F90 @@ -149,7 +149,9 @@ SUBROUTINE W3FLD2( ASPC,FPI, WNDX,WNDY, ZWND, & USE W3FLD1MD, ONLY: APPENDTAIL,sig2wn,wnd2z0m,infld,tail_choice,& tail_level, tail_transition_ratio1, & tail_transition_ratio2 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -207,13 +209,19 @@ SUBROUTINE W3FLD2( ASPC,FPI, WNDX,WNDY, ZWND, & LOGICAL :: ITERFLAG INTEGER :: ITTOT INTEGER :: COUNT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL, SAVE :: FIRST = .TRUE. -!/OMPG/!$omp threadprivate( FIRST ) +#ifdef W3_OMPG +!$omp threadprivate( FIRST ) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'C3FLD2') +#ifdef W3_S + CALL STRACE (IENT, 'C3FLD2') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -640,14 +648,20 @@ SUBROUTINE WND2SAT(WND10,SAT) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE REAL, INTENT(IN) :: WND10 REAL, INTENT(OUT) :: SAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/S CALL STRACE (IENT, 'WND2SAT') +#ifdef W3_S + CALL STRACE (IENT, 'WND2SAT') +#endif ! ! ST2, previous HWRF relationship: ! SAT =0.000000000000349* WND10**6 +& diff --git a/model/ftn/w3fldsmd.ftn b/model/src/w3fldsmd.F90 similarity index 81% rename from model/ftn/w3fldsmd.ftn rename to model/src/w3fldsmd.F90 index 84f8da101..71e17e01f 100644 --- a/model/ftn/w3fldsmd.ftn +++ b/model/src/w3fldsmd.F90 @@ -196,9 +196,13 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/DEBUGFLS USE W3ODATMD, only : IAPROC +#ifdef W3_DEBUGFLS + USE W3ODATMD, only : IAPROC +#endif IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / @@ -219,7 +223,9 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & !/ INTEGER :: NXT, NYT, GTYPET, I INTEGER :: FILLER(3) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: WRITE CHARACTER(LEN=3) :: TSFLD CHARACTER(LEN=11) :: FORM = 'UNFORMATTED' @@ -234,14 +240,20 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDO') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDO') +#endif ! -!/T WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, & -!/T NX, NY, GTYPE, IERR +#ifdef W3_T + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, & + NX, NY, GTYPE, IERR +#endif ! ! test input parameters ---------------------------------------------- * ! -!/TIDE TIDEOK = .TRUE. +#ifdef W3_TIDE + TIDEOK = .TRUE. +#endif FILLER(:)=0 IF ( PRESENT(TIDEFLAGIN) ) THEN TIDEFLAG = TIDEFLAGIN @@ -330,28 +342,42 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & ! WRITE = INXOUT .EQ. 'WRITE' ! -!/T WRITE (NDST,9001) WRITE, FNAME(:I) +#ifdef W3_T + WRITE (NDST,9001) WRITE, FNAME(:I) +#endif ! ! Open file ---------------------------------------------------------- * ! -!/DEBUGFLS WRITE(740+IAPROC,*) 'W3FLDSMD 1 : WRITE=', WRITE +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) 'W3FLDSMD 1 : WRITE=', WRITE +#endif IF ( WRITE ) THEN -!/DEBUGFLS WRITE(740+IAPROC,*) 'W3FLDSMD 2 : WRITE=', WRITE +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) 'W3FLDSMD 2 : WRITE=', WRITE +#endif IF ( PRESENT(FPRE) ) THEN -!/DEBUGFLS WRITE(740+IAPROC,*) '1 : W3FLDSMD FNAME=', FNAME(:I) +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '1 : W3FLDSMD FNAME=', FNAME(:I) +#endif OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM,ERR=803, & IOSTAT=IERR) ELSE -!/DEBUGFLS WRITE(740+IAPROC,*) '2 : W3FLDSMD FNAME=', FNAME(:I) +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '2 : W3FLDSMD FNAME=', FNAME(:I) +#endif OPEN (NDS,FILE=FNAME(:I),FORM=FORM,ERR=803,IOSTAT=IERR) END IF ELSE IF ( PRESENT(FPRE) ) THEN -!/DEBUGFLS WRITE(740+IAPROC,*) '3 : W3FLDSMD FNAME=', FNAME(:I) +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '3 : W3FLDSMD FNAME=', FNAME(:I) +#endif OPEN (NDS,FILE=FPRE//FNAME(:I),FORM=FORM, & STATUS='OLD',ERR=803,IOSTAT=IERR) ELSE -!/DEBUGFLS WRITE(740+IAPROC,*) '4 : W3FLDSMD FNAME=', FNAME(:I) +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '4 : W3FLDSMD FNAME=', FNAME(:I) +#endif OPEN (NDS,FILE=FNAME(:I),FORM=FORM, & STATUS='OLD',ERR=803,IOSTAT=IERR) END IF @@ -359,7 +385,9 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & ! ! Process test data -------------------------------------------------- * ! -!/DEBUGFLS WRITE(740+IAPROC,*) 'WRITE=', WRITE +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) 'WRITE=', WRITE +#endif IF ( WRITE ) THEN IF ( FDHDR ) THEN IF ( FORM .EQ. 'UNFORMATTED' ) THEN @@ -378,18 +406,22 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & IF ( FORM .EQ. 'UNFORMATTED' ) THEN READ (NDS,END=806,ERR=805,IOSTAT=IERR) & TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG -!/DEBUGFLS WRITE(740+IAPROC,*) '1: NXT=', NXT, ' NYT=', NYT -!/DEBUGFLS WRITE(740+IAPROC,*) '1: TSSTR=', TSSTR -!/DEBUGFLS WRITE(740+IAPROC,*) '1: TSFLD=', TSFLD -!/DEBUGFLS WRITE(740+IAPROC,*) '1: NXT=', NXT, ' NYT=', NYT -!/DEBUGFLS WRITE(740+IAPROC,*) '1: GTYPET=', GTYPET -!/DEBUGFLS WRITE(740+IAPROC,*) '1: FILLER=', FILLER -!/DEBUGFLS WRITE(740+IAPROC,*) '1: TIDEFLAG=', TIDEFLAG +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '1: NXT=', NXT, ' NYT=', NYT + WRITE(740+IAPROC,*) '1: TSSTR=', TSSTR + WRITE(740+IAPROC,*) '1: TSFLD=', TSFLD + WRITE(740+IAPROC,*) '1: NXT=', NXT, ' NYT=', NYT + WRITE(740+IAPROC,*) '1: GTYPET=', GTYPET + WRITE(740+IAPROC,*) '1: FILLER=', FILLER + WRITE(740+IAPROC,*) '1: TIDEFLAG=', TIDEFLAG +#endif ELSE READ (NDS,900,END=806,ERR=805,IOSTAT=IERR) & TSSTR, TSFLD, NXT, NYT, GTYPET, FILLER(1:2), TIDEFLAG -!/DEBUGFLS WRITE(740+IAPROC,*) '2: NXT=', NXT, ' NYT=', NYT -!/DEBUGFLS WRITE(740+IAPROC,*) '2: NXT=', NXT, ' NYT=', NYT +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) '2: NXT=', NXT, ' NYT=', NYT + WRITE(740+IAPROC,*) '2: NXT=', NXT, ' NYT=', NYT +#endif END IF IF ((FILLER(1).NE.0.OR.FILLER(2).NE.0).AND.TIDEFLAG.GE.0) TIDEFLAG=0 IF (TIDEFLAG.NE.0.AND.(.NOT.TIDEOK)) THEN @@ -400,14 +432,18 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & IF (( IDFLD.EQ.'WND' .AND. TSFLD.EQ.'WNS') .OR. & ( IDFLD.EQ.'ICE' .AND. TSFLD.EQ.'ISI') ) THEN IDFLD = TSFLD -!/T WRITE (NDST,9002) IDFLD +#ifdef W3_T + WRITE (NDST,9002) IDFLD +#endif END IF IF ( IDFLD .NE. TSFLD ) GOTO 808 IF ( IDFLD(1:2) .NE. 'DT' ) THEN IF ( NX.NE.NXT .OR. NY.NE.NYT ) THEN -!/DEBUGFLS WRITE(740+IAPROC,*) 'Dimension error' -!/DEBUGFLS WRITE(740+IAPROC,*) 'NX =', NX , ' NY =', NY -!/DEBUGFLS WRITE(740+IAPROC,*) 'NXT=', NXT, ' NYT=', NYT +#ifdef W3_DEBUGFLS + WRITE(740+IAPROC,*) 'Dimension error' + WRITE(740+IAPROC,*) 'NX =', NX , ' NY =', NY + WRITE(740+IAPROC,*) 'NXT=', NXT, ' NYT=', NYT +#endif GOTO 809 ELSE NX = NXT @@ -510,17 +546,19 @@ SUBROUTINE W3FLDO ( INXOUT, IDFLD, NDS, NDST, NDSE, NX, NY, & ' FILLER indicates use of tidal constituents',3I4, /& ' For this the code should be compiled with TIDE switch'/) ! -!/T 9000 FORMAT (' TEST W3FLDO : INXOUT : ',A/ & -!/T ' IDFLD : ',A/ & -!/T ' NDS : ',I2/ & -!/T ' NDST : ',I2/ & -!/T ' NDSE : ',I2/ & -!/T ' NX, NY : ',I9,3X,I9/ & -!/T ' GTYPE : ',I2/ & -!/T ' IERR : ',I2) -!/T 9001 FORMAT (' WRITE : ',L2/ & -!/T ' FNAME : [',A,']') -!/T 9002 FORMAT (' NEW IDFLD : ',A) +#ifdef W3_T + 9000 FORMAT (' TEST W3FLDO : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS : ',I2/ & + ' NDST : ',I2/ & + ' NDSE : ',I2/ & + ' NX, NY : ',I9,3X,I9/ & + ' GTYPE : ',I2/ & + ' IERR : ',I2) + 9001 FORMAT (' WRITE : ',L2/ & + ' FNAME : [',A,']') + 9002 FORMAT (' NEW IDFLD : ',A) +#endif !/ !/ End of W3FLDO ---------------------------------------------------- / !/ @@ -609,9 +647,13 @@ SUBROUTINE W3FLDTIDE1 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IERR ) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/TIDE USE W3TIDEMD +#ifdef W3_TIDE + USE W3TIDEMD +#endif USE W3IDATMD IMPLICIT NONE !/ @@ -626,14 +668,18 @@ SUBROUTINE W3FLDTIDE1 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IERR ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: WRITE INTEGER :: I, IX ! !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDTIDE1') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDTIDE1') +#endif ! ! test input parameters ---------------------------------------------- * ! @@ -646,14 +692,16 @@ SUBROUTINE W3FLDTIDE1 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IERR ) IDFLD.NE.'ISI' ) GOTO 802 WRITE = INXOUT .EQ. 'WRITE' -!/TIDE IF ( WRITE ) THEN -!/TIDE WRITE (NDS,ERR=804,IOSTAT=IERR) & -!/TIDE TIDE_MF -!/TIDE ELSE -!/TIDE READ (NDS,END=806,ERR=805,IOSTAT=IERR) & -!/TIDE TIDE_MF -!/TIDE NTIDE = TIDE_MF -!/TIDE END IF +#ifdef W3_TIDE + IF ( WRITE ) THEN + WRITE (NDS,ERR=804,IOSTAT=IERR) & + TIDE_MF + ELSE + READ (NDS,END=806,ERR=805,IOSTAT=IERR) & + TIDE_MF + NTIDE = TIDE_MF + END IF +#endif ! ! ! File OK ------------------------------------------------------------ * @@ -791,9 +839,13 @@ SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/TIDE USE W3TIDEMD +#ifdef W3_TIDE + USE W3TIDEMD +#endif USE W3IDATMD IMPLICIT NONE !/ @@ -808,14 +860,18 @@ SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: WRITE INTEGER :: I, IX, TIDE_MF1 CHARACTER(LEN=100) :: LIST(70) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDTIDE2') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDTIDE2') +#endif ! ! test input parameters ---------------------------------------------- * ! @@ -828,44 +884,48 @@ SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) IDFLD.NE.'ISI' ) GOTO 802 WRITE = INXOUT .EQ. 'WRITE' -!/TIDE IF ( WRITE ) THEN -!/TIDE WRITE (NDS,ERR=804,IOSTAT=IERR) & -!/TIDE TIDE_FREQC(:),TIDECON_NAME(:),TIDAL_CONST(:,:,:,:,:) -!/TIDE ELSE -!/TIDE IF (.NOT. ALLOCATED(TIDAL_CONST)) ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) -!/TIDE IF (.NOT. ALLOCATED(TIDE_FREQC)) ALLOCATE(TIDE_FREQC(TIDE_MF)) -!/TIDE IF (.NOT. ALLOCATED(TIDECON_NAMEI)) ALLOCATE(TIDECON_NAMEI(TIDE_MF)) -!/TIDE READ (NDS,END=806,ERR=805,IOSTAT=IERR) & -!/TIDE TIDE_FREQC,TIDECON_NAMEI(:),TIDAL_CONST(:,:,:,:,:) -!/TIDE LIST(:)='' -!/TIDE TIDE_MF1=TIDE_MF -!/TIDE DO I=1,TIDE_MF -!/TIDE LIST(I)=TIDECON_NAMEI(I) -!/TIDE END DO -!/TIDE CALL TIDE_FIND_INDICES_ANALYSIS(LIST) -!/TIDE IF (TIDE_MF1.NE.TIDE_MF) GOTO 807 -!/TIDE CALL TIDE_SET_INDICES -!/TIDE IF(IDFLD.EQ.'LEV') THEN -!/TIDE IF (IDAT.EQ.1) WLTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) -!/TIDE ELSE -!/TIDE IF (IDAT.EQ.1) CXTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) -!/TIDE IF (IDAT.EQ.1) CYTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,2,:) -!/TIDE END IF -!/TIDE END IF -!/TIDET DO I=1,NTIDE -!/TIDET WRITE(NDST,*) 'Tidal constituents for IX = 1:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(1,1,I,1,1),TIDAL_CONST(1,1,I,1,2), & -!/TIDET '##',TIDAL_CONST(1,1,I,2,1),TIDAL_CONST(1,1,I,2,2) -!/TIDET END DO -!/TIDET DO I=1,NTIDE -!/TIDET WRITE(NDST,*) 'Tidal constituents for IX = 2:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(2,1,I,1,1),TIDAL_CONST(2,1,I,1,2), & -!/TIDET '##',TIDAL_CONST(2,1,I,2,1),TIDAL_CONST(2,1,I,2,2) -!/TIDET END DO -!/TIDET DO IX=1,NX -!/TIDET IF (IDFLD.EQ.'CUR') WRITE (989,'(I10,X,176F10.3)') IX,CXTIDE(IX,1,:,1),CYTIDE(IX,1,:,1), & -!/TIDET CXTIDE(IX,1,:,2),CYTIDE(IX,1,:,2) -!/TIDET END DO -!/TIDET IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,1) -!/TIDET IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,2) +#ifdef W3_TIDE + IF ( WRITE ) THEN + WRITE (NDS,ERR=804,IOSTAT=IERR) & + TIDE_FREQC(:),TIDECON_NAME(:),TIDAL_CONST(:,:,:,:,:) + ELSE + IF (.NOT. ALLOCATED(TIDAL_CONST)) ALLOCATE(TIDAL_CONST(NX,NY,TIDE_MF,2,2)) + IF (.NOT. ALLOCATED(TIDE_FREQC)) ALLOCATE(TIDE_FREQC(TIDE_MF)) + IF (.NOT. ALLOCATED(TIDECON_NAMEI)) ALLOCATE(TIDECON_NAMEI(TIDE_MF)) + READ (NDS,END=806,ERR=805,IOSTAT=IERR) & + TIDE_FREQC,TIDECON_NAMEI(:),TIDAL_CONST(:,:,:,:,:) + LIST(:)='' + TIDE_MF1=TIDE_MF + DO I=1,TIDE_MF + LIST(I)=TIDECON_NAMEI(I) + END DO + CALL TIDE_FIND_INDICES_ANALYSIS(LIST) + IF (TIDE_MF1.NE.TIDE_MF) GOTO 807 + CALL TIDE_SET_INDICES + IF(IDFLD.EQ.'LEV') THEN + IF (IDAT.EQ.1) WLTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) + ELSE + IF (IDAT.EQ.1) CXTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,1,:) + IF (IDAT.EQ.1) CYTIDE(:,:,:,:)=TIDAL_CONST(:,:,:,2,:) + END IF + END IF +#endif +#ifdef W3_TIDET + DO I=1,NTIDE + WRITE(NDST,*) 'Tidal constituents for IX = 1:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(1,1,I,1,1),TIDAL_CONST(1,1,I,1,2), & + '##',TIDAL_CONST(1,1,I,2,1),TIDAL_CONST(1,1,I,2,2) + END DO + DO I=1,NTIDE + WRITE(NDST,*) 'Tidal constituents for IX = 2:', IDFLD,' ',TIDECON_NAME(I),TIDAL_CONST(2,1,I,1,1),TIDAL_CONST(2,1,I,1,2), & + '##',TIDAL_CONST(2,1,I,2,1),TIDAL_CONST(2,1,I,2,2) + END DO + DO IX=1,NX + IF (IDFLD.EQ.'CUR') WRITE (989,'(I10,X,176F10.3)') IX,CXTIDE(IX,1,:,1),CYTIDE(IX,1,:,1), & + CXTIDE(IX,1,:,2),CYTIDE(IX,1,:,2) + END DO + IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,1) + IF (IDFLD.EQ.'CUR') WRITE(988,'(F10.3,/)') CXTIDE(:,1,15,2) +#endif ! ! ! File OK ------------------------------------------------------------ * @@ -901,7 +961,9 @@ SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) RETURN ! 807 CONTINUE -!/TIDE IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TIDECON_NAMEI(:) +#ifdef W3_TIDE + IF ( NDSE .GE. 0 ) WRITE (NDSE,1007) TIDECON_NAMEI(:) +#endif IERR = 7 RETURN ! @@ -917,8 +979,10 @@ SUBROUTINE W3FLDTIDE2 ( INXOUT, NDS, NDST, NDSE, NX, NY, IDFLD, IDAT, IERR ) ' ERROR IN READING ',A,' FILE, IOSTAT =',I6/) 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & ' PREMATURE END OF ',A,' FILE'/) -!/TIDE 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & -!/TIDE ' TIDAL CONSTITUENTS NOT RECOGNIZED ',A /) +#ifdef W3_TIDE + 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDTIDE2 : '/ & + ' TIDAL CONSTITUENTS NOT RECOGNIZED ',A /) +#endif !/ !/ End of W3FLDO ---------------------------------------------------- / !/ @@ -928,7 +992,9 @@ END SUBROUTINE W3FLDTIDE2 SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & NX, NY, T0, TN, TF0, FX0, FY0, FA0, & TFN, FXN, FYN, FAN, IERR, FLAGSC & -!/OASIS , COUPL_COMM & +#ifdef W3_OASIS + , COUPL_COMM & +#endif ) !/ !/ +-----------------------------------+ @@ -1039,13 +1105,25 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD -!/OASIS USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 -!/OASACM USE W3AGCMMD, ONLY: RCV_FIELDS_FROM_ATMOS -!/OASOCM USE W3OGCMMD, ONLY: RCV_FIELDS_FROM_OCEAN -!/OASICM USE W3IGCMMD, ONLY: RCV_FIELDS_FROM_ICE -!/OASIS USE W3ODATMD, ONLY: DTOUT +#ifdef W3_OASIS + USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 +#endif +#ifdef W3_OASACM + USE W3AGCMMD, ONLY: RCV_FIELDS_FROM_ATMOS +#endif +#ifdef W3_OASOCM + USE W3OGCMMD, ONLY: RCV_FIELDS_FROM_OCEAN +#endif +#ifdef W3_OASICM + USE W3IGCMMD, ONLY: RCV_FIELDS_FROM_ICE +#endif +#ifdef W3_OASIS + USE W3ODATMD, ONLY: DTOUT +#endif IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / @@ -1061,14 +1139,18 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & CHARACTER, INTENT(IN) :: INXOUT*(*) CHARACTER(LEN=3), INTENT(IN) :: IDFLD LOGICAL, INTENT(INOUT), OPTIONAL :: FLAGSC -!/OASIS INTEGER, INTENT(IN), OPTIONAL :: COUPL_COMM +#ifdef W3_OASIS + INTEGER, INTENT(IN), OPTIONAL :: COUPL_COMM +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: IX, IY, J, ISTAT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTTST LOGICAL :: WRITE, FL2D, FLFRST, FLBE, FLST, & FLINTERP, FLCOUPL @@ -1076,12 +1158,16 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDG') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDG') +#endif !/ IERR = 0 ! -!/T WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & -!/T NX, NY, TF0, TFN, IERR +#ifdef W3_T + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & + NX, NY, TF0, TFN, IERR +#endif ! ! test input parameters ---------------------------------------------- * ! @@ -1121,7 +1207,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & FLFRST = TFN(1) .EQ. -1 ! -!/T WRITE (NDST,9001) WRITE, FL2D, FLBE, FLST, FLFRST +#ifdef W3_T + WRITE (NDST,9001) WRITE, FL2D, FLBE, FLST, FLFRST +#endif ! ! Loop over times / fields ========================================== * ! @@ -1133,7 +1221,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & ! TF0(1) = TFN(1) TF0(2) = TFN(2) -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif ! unless TFN has been changed in the do loop, the following line is essentally ! "if not.flfrst" IF ( TFN(1) .NE. -1 ) THEN @@ -1148,8 +1238,10 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & END DO END IF END DO -!/T ELSE -!/T WRITE (NDST,9021) +#ifdef W3_T + ELSE + WRITE (NDST,9021) +#endif END IF ! END IF @@ -1159,7 +1251,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & ! IF ( WRITE ) THEN ! -!/T WRITE (NDST,9030) TF0 +#ifdef W3_T + WRITE (NDST,9030) TF0 +#endif WRITE (NDS,ERR=803,IOSTAT=ISTAT) TF0 IF ( .NOT. FL2D ) THEN J = 1 @@ -1183,30 +1277,42 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & ! ELSE ! -!/OASIS IF (FLCOUPL) THEN -!/OASIS ! Do not receive coupling fields at the end of the first integration time in case of -!/OASIS ! forcing with a non interpolated field (like lev, ice, ...) -!/OASIS IF ( (ID_OASIS_TIME.EQ.0 .AND. ( FLFRST .OR. CPLT0 )) .OR. & -!/OASIS (ID_OASIS_TIME.GT.0)) THEN -! -!/OASACM ! Getting U10 (FXN) and V10 (FYN) from atmospheric model -!/OASACM CALL RCV_FIELDS_FROM_ATMOS(COUPL_COMM, & -!/OASACM IDFLD, FXN, FYN, FAN) -!/OASOCM ! Getting UCUR (CX), VCUR (CY), WLV from ocean model -!/OASOCM CALL RCV_FIELDS_FROM_OCEAN(COUPL_COMM, & -!/OASOCM IDFLD, FXN, FYN, FAN) -!/OASICM ! Getting ICEF from ice model -!/OASICM CALL RCV_FIELDS_FROM_ICE(COUPL_COMM, & -!/OASICM IDFLD, FXN, FYN, FAN) +#ifdef W3_OASIS + IF (FLCOUPL) THEN + ! Do not receive coupling fields at the end of the first integration time in case of + ! forcing with a non interpolated field (like lev, ice, ...) + IF ( (ID_OASIS_TIME.EQ.0 .AND. ( FLFRST .OR. CPLT0 )) .OR. & + (ID_OASIS_TIME.GT.0)) THEN +#endif +! +#ifdef W3_OASACM + ! Getting U10 (FXN) and V10 (FYN) from atmospheric model + CALL RCV_FIELDS_FROM_ATMOS(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) +#endif +#ifdef W3_OASOCM + ! Getting UCUR (CX), VCUR (CY), WLV from ocean model + CALL RCV_FIELDS_FROM_OCEAN(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) +#endif +#ifdef W3_OASICM + ! Getting ICEF from ice model + CALL RCV_FIELDS_FROM_ICE(COUPL_COMM, & + IDFLD, FXN, FYN, FAN) +#endif -!/OASIS ! Increment the time field TFN to the next coupling time -!/OASIS TFN(1)=T0(1) -!/OASIS TFN(2)=T0(2) -!/OASIS CALL TICK21(TFN,DTOUT(7)) -!/OASIS END IF -!/OASIS ELSE +#ifdef W3_OASIS + ! Increment the time field TFN to the next coupling time + TFN(1)=T0(1) + TFN(2)=T0(2) + CALL TICK21(TFN,DTOUT(7)) + END IF + ELSE +#endif READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TFN -!/T WRITE (NDST,9031) TFN +#ifdef W3_T + WRITE (NDST,9031) TFN +#endif IF ( .NOT. FL2D ) THEN ! note: "J" here does *not* refer to data type, wlev etc. ! It refers to the dimension. @@ -1231,7 +1337,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & IF ( FLST ) READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) & ((FAN(IX,IY),IX=1,NX),IY=1,NY) END IF -!/OASIS END IF +#ifdef W3_OASIS + END IF +#endif ! ! Check time, branch back if necessary ! @@ -1258,7 +1366,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & IF ( .NOT.WRITE .AND. FLINTERP .AND. TF0(1) .EQ. -1 ) THEN ! -!/T WRITE (NDST,9040) +#ifdef W3_T + WRITE (NDST,9040) +#endif TF0(1) = T0(1) TF0(2) = T0(2) ! @@ -1280,11 +1390,13 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & ! 500 CONTINUE ! -!/T IF ( FLINTERP ) THEN -!/T WRITE (NDST,9041) TF0, TFN -!/T ELSE -!/T WRITE (NDST,9042) TFN -!/T END IF +#ifdef W3_T + IF ( FLINTERP ) THEN + WRITE (NDST,9041) TF0, TFN + ELSE + WRITE (NDST,9042) TFN + END IF +#endif ! ! Process fields, end ----------------------------------------------- * ! @@ -1300,7 +1412,9 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & TFN(2) = TN(2) CALL TICK21 ( TFN , 1. ) END IF -!/T WRITE (NDST,9032) TFN, IERR +#ifdef W3_T + WRITE (NDST,9032) TFN, IERR +#endif ! IF ( FLINTERP ) THEN GOTO 300 @@ -1363,32 +1477,40 @@ SUBROUTINE W3FLDG (INXOUT, IDFLD, NDS, NDST, NDSE, MX, MY, & 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDG : '/ & ' ERROR IN READING FIELD ',I1,', IOSTAT =',I6/) ! -!/T 9000 FORMAT (' TEST W3FLDG : INXOUT : ',A/ & -!/T ' IDFLD : ',A/ & -!/T ' NDS(T/E) :',3I4/ & -!/T ' MX, MY :',2I8/ & -!/T ' NX, NY :',2I8/ & -!/T ' TF0 :',I9.8,I7.6/ & -!/T ' TFN :',I9.8,I7.6/ & -!/T ' IERR :',I4) -!/T 9001 FORMAT (' TEST W3FLDG : WRITE :',L4/ & -!/T ' FL2D :',L4/ & -!/T ' FLBE :',L4/ & -!/T ' FLST :',L4/ & -!/T ' FIRST :',L4) -! -!/T 9020 FORMAT (' TEST W3FLDG : FIELD SHIFTED') -!/T 9021 FORMAT (' NO FIELD TO SHIFT') -! -!/T 9030 FORMAT (' TEST W3FLDG : WRITE TIME : ',I8,I7.6) -!/T 9031 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6) -!/T 9032 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6, & -!/T ' EOF (IERR =',I3,')') -! -!/T 9040 FORMAT (' TEST W3FLDG : FILLING IN FIRST FIELD') -!/T 9041 FORMAT (' TEST W3FLDG : FINAL TIMES: ',I8,I7.6/ & -!/T ' ',I8,I7.6) -!/T 9042 FORMAT (' TEST W3FLDG : FINAL TIME : ',I8,I7.6) +#ifdef W3_T + 9000 FORMAT (' TEST W3FLDG : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS(T/E) :',3I4/ & + ' MX, MY :',2I8/ & + ' NX, NY :',2I8/ & + ' TF0 :',I9.8,I7.6/ & + ' TFN :',I9.8,I7.6/ & + ' IERR :',I4) + 9001 FORMAT (' TEST W3FLDG : WRITE :',L4/ & + ' FL2D :',L4/ & + ' FLBE :',L4/ & + ' FLST :',L4/ & + ' FIRST :',L4) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3FLDG : FIELD SHIFTED') + 9021 FORMAT (' NO FIELD TO SHIFT') +#endif +! +#ifdef W3_T + 9030 FORMAT (' TEST W3FLDG : WRITE TIME : ',I8,I7.6) + 9031 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6) + 9032 FORMAT (' TEST W3FLDG : NEW TIME : ',I8,I7.6, & + ' EOF (IERR =',I3,')') +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3FLDG : FILLING IN FIRST FIELD') + 9041 FORMAT (' TEST W3FLDG : FINAL TIMES: ',I8,I7.6/ & + ' ',I8,I7.6) + 9042 FORMAT (' TEST W3FLDG : FINAL TIME : ',I8,I7.6) +#endif !/ !/ End of W3FLDG ----------------------------------------------------- / !/ @@ -1488,7 +1610,9 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD ! IMPLICIT NONE @@ -1507,18 +1631,24 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & !/ Local parameters !/ INTEGER :: ISTAT, NRT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTTST LOGICAL :: WRITE, SIZE !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDD') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDD') +#endif !/ IERR = 0 ! -!/T WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, NR, ND, & -!/T TIME, TD, IERR +#ifdef W3_T + WRITE (NDST,9000) INXOUT, IDFLD, NDS, NDST, NDSE, NR, ND, & + TIME, TD, IERR +#endif ! ! test input parameters ---------------------------------------------- * ! @@ -1532,13 +1662,17 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & WRITE = INXOUT .EQ. 'WRITE' SIZE = INXOUT .EQ. 'SIZE' ! -!/T WRITE (NDST,9001) WRITE, SIZE +#ifdef W3_T + WRITE (NDST,9001) WRITE, SIZE +#endif ! ! Process fields, write --------------------------------------------- * ! IF ( WRITE ) THEN ! -!/T WRITE (NDST,9020) TD, ND +#ifdef W3_T + WRITE (NDST,9020) TD, ND +#endif WRITE (NDS,ERR=803,IOSTAT=ISTAT) TD, ND WRITE (NDS,ERR=804,IOSTAT=ISTAT) DATA ! @@ -1548,7 +1682,9 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & ! 100 CONTINUE READ (NDS,END=800,ERR=805,IOSTAT=ISTAT) TD, NDOUT -!/T WRITE (NDST,9021) TD, NDOUT +#ifdef W3_T + WRITE (NDST,9021) TD, NDOUT +#endif ! ! Check time, read and branch back if necessary ! @@ -1563,7 +1699,9 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & ELSE ! READ (NDS,END=806,ERR=807,IOSTAT=ISTAT) DATA -!/T WRITE (NDST,9030) TD +#ifdef W3_T + WRITE (NDST,9030) TD +#endif END IF ! ! Process fields, end ----------------------------------------------- * @@ -1630,22 +1768,28 @@ SUBROUTINE W3FLDD (INXOUT, IDFLD, NDS, NDST, NDSE, TIME, TD, & 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDD : '/ & ' ERROR IN READING DATA, IOSTAT =',I6/) ! -!/T 9000 FORMAT (' TEST W3FLDD : INXOUT : ',A/ & -!/T ' IDFLD : ',A/ & -!/T ' NDS(T/E) :',3I4/ & -!/T ' NR, ND :',2I4/ & -!/T ' TIME :',I8,I7.6/ & -!/T ' TD :',I8,I7.6/ & -!/T ' IERR :',I4) -!/T 9001 FORMAT (' TEST W3FLDD : WRITE :',L4/ & -!/T ' SIZE :',L4) -! -!/T 9020 FORMAT (' TEST W3FLDD : WRITE TIME : ',I8,I7.6/ & -!/T ' RECORDS : ',I6) -!/T 9021 FORMAT (' TEST W3FLDD : NEW TIME : ',I8,I7.6/ & -!/T ' RECORDS : ',I6) -! -!/T 9030 FORMAT (' TEST W3FLDD : FINAL TIME : ',I8,I7.6) +#ifdef W3_T + 9000 FORMAT (' TEST W3FLDD : INXOUT : ',A/ & + ' IDFLD : ',A/ & + ' NDS(T/E) :',3I4/ & + ' NR, ND :',2I4/ & + ' TIME :',I8,I7.6/ & + ' TD :',I8,I7.6/ & + ' IERR :',I4) + 9001 FORMAT (' TEST W3FLDD : WRITE :',L4/ & + ' SIZE :',L4) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3FLDD : WRITE TIME : ',I8,I7.6/ & + ' RECORDS : ',I6) + 9021 FORMAT (' TEST W3FLDD : NEW TIME : ',I8,I7.6/ & + ' RECORDS : ',I6) +#endif +! +#ifdef W3_T + 9030 FORMAT (' TEST W3FLDD : FINAL TIME : ',I8,I7.6) +#endif !/ !/ End of W3FLDD ----------------------------------------------------- / !/ @@ -1794,7 +1938,9 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & !/ ------------------------------------------------------------------- / !/ USE W3GSRUMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1816,7 +1962,9 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif TYPE(T_GSU) :: GSU INTEGER :: IX, IY, I, J, NNBR, II(4), JJ(4), & MSKC, IFOUND, IMASK, ICOR1 @@ -1829,15 +1977,21 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDP') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDP') +#endif ! -!/T WRITE (NDST,9000) NDSM, NDST, NDSE, MX, MY, NX, NY, ILAND, & -!/T MXI, MYI, NXI, NYI, CLOSED +#ifdef W3_T + WRITE (NDST,9000) NDSM, NDST, NDSE, MX, MY, NX, NY, ILAND, & + MXI, MYI, NXI, NYI, CLOSED +#endif ! ! 1. Initializations ------------------------------------------------ * ! 1.a Initialize counters and factors ! -!/T8 LDBG = .TRUE. +#ifdef W3_T8 + LDBG = .TRUE. +#endif IERR = 0 IFOUND = 0 IMASK = 0 @@ -1868,8 +2022,10 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & PLON => ALON GSU = W3GSUC( .TRUE., FLAGLL, ICLO, PLON, PLAT ) ! -!/T WRITE (NDST,9001) -!/T CALL W3GSUP( GSU, NDST ) +#ifdef W3_T + WRITE (NDST,9001) + CALL W3GSUP( GSU, NDST ) +#endif ! ! 2. Loop over output grid ------------------------------------------ * ! @@ -1878,7 +2034,9 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ! X = TLON(IY,IX) Y = TLAT(IY,IX) -!/T1 WRITE (NDST,9010) IX, IY, X, Y +#ifdef W3_T1 + WRITE (NDST,9010) IX, IY, X, Y +#endif ! ! 2.a Check if sea point ! @@ -1924,14 +2082,16 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & IY1 (IX,IY) = JJ(2) RD22(IX,IY) = RR(2) END IF -!/T IF ( NNBR .EQ. 1 ) THEN -!/T WRITE (NDST,9043) & -!/T IX1(IX,IY), IY1(IX,IY), RD11(IX,IY) -!/T ELSE -!/T WRITE (NDST,9044) & -!/T IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & -!/T IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) -!/T END IF +#ifdef W3_T + IF ( NNBR .EQ. 1 ) THEN + WRITE (NDST,9043) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY) + ELSE + WRITE (NDST,9044) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & + IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) + END IF +#endif ELSE IERR = IERR + 1 WRITE (NDSE,910) IX, IY, X, Y, & @@ -1940,22 +2100,28 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ! END IF ! MSKC ! -!/T WRITE (NDST,9031) & -!/T IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & -!/T IX2(IX,IY), IY1(IX,IY), RD21(IX,IY), & -!/T IX1(IX,IY), IY2(IX,IY), RD12(IX,IY), & -!/T IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) +#ifdef W3_T + WRITE (NDST,9031) & + IX1(IX,IY), IY1(IX,IY), RD11(IX,IY), & + IX2(IX,IY), IY1(IX,IY), RD21(IX,IY), & + IX1(IX,IY), IY2(IX,IY), RD12(IX,IY), & + IX2(IX,IY), IY2(IX,IY), RD22(IX,IY) +#endif ! ! 2.e Update overlay map ! MAPOVR(IX,IY) = MAPOVR(IX,IY) + 1 IFOUND = IFOUND + 1 ! -!/T1 ELSE ! .NOT.INGRID -!/T1 WRITE (NDST,9021) +#ifdef W3_T1 + ELSE ! .NOT.INGRID + WRITE (NDST,9021) +#endif END IF ! INGRID -!/T1 ELSE ! land-point -!/T1 WRITE (NDST,9020) IX, IY, X, Y, 'LAND' +#ifdef W3_T1 + ELSE ! land-point + WRITE (NDST,9020) IX, IY, X, Y, 'LAND' +#endif ENDIF ! sea-point ! ! ... End loop over output grid -------------------------------------- * @@ -1987,31 +2153,39 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ' X-COUNTERS IN INPUT GRID :',2I4/ & ' Y-COUNTERS IN INPUT GRID :',2I4) ! -!/T 9000 FORMAT ( ' TEST W3FLDP : NDSM/T/E : ',3I8/ & -!/T ' MX, MY : ',2I8/ & -!/T ' NX, NY : ',2I8/ & -!/T ' ILAND : ',I8/ & -!/T ' MXI, MYI : ',2I8/ & -!/T ' NXI, NYI : ',2I8/ & -!/T ' CLOSED : ',L8) -!/T 9001 FORMAT ( ' TEST W3FLDP : GRID SEARCH INFO -- OUTPUT FROM W3GSUP') -! -!/T1 9010 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & -!/T1 ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & -!/T1 ' ================================') -! -!/T1 9020 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & -!/T1 ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & -!/T1 ' (',A,')') -!/T1 9021 FORMAT ( ' ***** OUT OF RANGE *****') -! -!/T 9031 FORMAT ( ' TEST W3FLDP : FINAL INTERPOLATION DATA (IX,IY,R)', & -!/T 4(/' ',2I4,f7.3)) -!/T 9043 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & -!/T ' POINT 1 : ',2I4,F6.2) -!/T 9044 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & -!/T ' POINT 1 : ',2I4,F6.2/ & -!/T ' POINT 2 : ',2I4,F6.2) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3FLDP : NDSM/T/E : ',3I8/ & + ' MX, MY : ',2I8/ & + ' NX, NY : ',2I8/ & + ' ILAND : ',I8/ & + ' MXI, MYI : ',2I8/ & + ' NXI, NYI : ',2I8/ & + ' CLOSED : ',L8) + 9001 FORMAT ( ' TEST W3FLDP : GRID SEARCH INFO -- OUTPUT FROM W3GSUP') +#endif +! +#ifdef W3_T1 + 9010 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & + ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & + ' ================================') +#endif +! +#ifdef W3_T1 + 9020 FORMAT ( ' TEST W3FLDP : IX =',I4,' IY =',I4, & + ' LONGITUDE =',F8.2, ' LATITUDE =',F8.2, & + ' (',A,')') + 9021 FORMAT ( ' ***** OUT OF RANGE *****') +#endif +! +#ifdef W3_T + 9031 FORMAT ( ' TEST W3FLDP : FINAL INTERPOLATION DATA (IX,IY,R)', & + 4(/' ',2I4,f7.3)) + 9043 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & + ' POINT 1 : ',2I4,F6.2) + 9044 FORMAT ( ' TEST W3FLDP : CORRECTED INTERPOLATION '/ & + ' POINT 1 : ',2I4,F6.2/ & + ' POINT 2 : ',2I4,F6.2) +#endif !/ !/ End of W3FLDP ----------------------------------------------------- / !/ @@ -2124,7 +2298,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD ! IMPLICIT NONE @@ -2144,28 +2320,36 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & !/ Local parameters !/ INTEGER :: IX, IY, I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: X, Y, DIR, DTTST, DERA LOGICAL :: FLFRST !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDH') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDH') +#endif ! IERR = 0 DERA = ATAN(1.)/45. ! -!/T WRITE (NDST,9000) J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & -!/T NH, NHM, TF0, TFN, IERR +#ifdef W3_T + WRITE (NDST,9000) J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & + NH, NHM, TF0, TFN, IERR +#endif ! ! Test field ID number for validity ! IF ( J.LT.-7 .OR. J .GT.10 ) GOTO 801 FLFRST = TFN(1) .EQ. -1 ! -!/T WRITE (NDST,9001) FLFRST +#ifdef W3_T + WRITE (NDST,9001) FLFRST +#endif ! ! Loop over times / fields ========================================== * ! @@ -2183,7 +2367,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & FY0(IX,IY) = FYN(IX,IY) END DO END DO -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif ELSE IF ( J .EQ. 3 ) THEN DO IX=1, NX DO IY=1, NY @@ -2192,10 +2378,14 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & FS0(IX,IY) = FSN(IX,IY) END DO END DO -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif END IF -!/T ELSE -!/T IF ( J .NE. 1 ) WRITE (NDST,9021) +#ifdef W3_T + ELSE + IF ( J .NE. 1 ) WRITE (NDST,9021) +#endif END IF ! ! New field @@ -2210,7 +2400,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & FSN(IX,IY) = HA(1,J) END DO END DO -!/T WRITE (NDST,9050) HA(1,J) +#ifdef W3_T + WRITE (NDST,9050) HA(1,J) +#endif END IF ! cur IF ( (J .EQ. 2) .OR. (J .EQ. 5) ) THEN @@ -2223,7 +2415,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & FYN(IX,IY) = Y END DO END DO -!/T WRITE (NDST,9050) X, Y +#ifdef W3_T + WRITE (NDST,9050) X, Y +#endif END IF ! wnd IF ( J .EQ. 3 ) THEN @@ -2237,7 +2431,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & FSN(IX,IY) = HS(1,J) END DO END DO -!/T WRITE (NDST,9050) X, Y, HS(1,J) +#ifdef W3_T + WRITE (NDST,9050) X, Y, HS(1,J) +#endif END IF ! ! Shift data arrays @@ -2250,7 +2446,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & HS(I,J) = HS(I+1,J) END DO NH = NH - 1 -!/T WRITE (NDST,9051) TFN +#ifdef W3_T + WRITE (NDST,9051) TFN +#endif ! ELSE ! @@ -2258,7 +2456,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & TFN(2) = TN(2) CALL TICK21 ( TFN , 1. ) IERR = -1 -!/T WRITE (NDST,9052) TFN, IERR +#ifdef W3_T + WRITE (NDST,9052) TFN, IERR +#endif ! END IF ! @@ -2280,7 +2480,9 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & ! Check if first field ! IF ( J.NE.1 .AND. TFN(1) .EQ. -1 ) THEN -!/T WRITE (NDST,9060) +#ifdef W3_T + WRITE (NDST,9060) +#endif TF0(1) = T0(1) TF0(2) = T0(2) ! @@ -2293,11 +2495,13 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & END DO END IF ! -!/T IF ( J .GT. 1 ) THEN -!/T WRITE (NDST,9061) TF0, TFN -!/T ELSE -!/T WRITE (NDST,9062) TFN -!/T END IF +#ifdef W3_T + IF ( J .GT. 1 ) THEN + WRITE (NDST,9061) TF0, TFN + ELSE + WRITE (NDST,9062) TFN + END IF +#endif ! RETURN ! @@ -2313,26 +2517,32 @@ SUBROUTINE W3FLDH (J, NDST, NDSE, MX, MY, NX, NY, T0, TN, & 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDH : '/ & ' ILLEGAL FIELD ID NR : ',I4/) ! -!/T 9000 FORMAT (' TEST W3FLDH : J, NDST/E : ',3I4/ & -!/T ' DIMENSIONS : ',4I4/ & -!/T ' T0 : ',I8,I7.6/ & -!/T ' TN : ',I8,I7.6/ & -!/T ' NH(M) : ',2I4/ & -!/T ' TF0 : ',I8,I7.6/ & -!/T ' TFN, IERR : ',I8,I7.6,I4) -!/T 9001 FORMAT (' TEST W3FLDH : FIRST FIELD : ',L2) -! -!/T 9020 FORMAT (' TEST W3FLDH : FIELD SHIFTED') -!/T 9021 FORMAT (' NO FIELD TO SHIFT') -! -!/T 9050 FORMAT (' TEST W3FLDH : NEW VALUE(S) : ',3F8.2) -!/T 9051 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6) -!/T 9052 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6, & -!/T ' LAST FIELD (IERR =',I3,')') -!/T 9060 FORMAT (' TEST W3FLDH : FILLING IN FIRST FIELD') -!/T 9061 FORMAT (' TEST W3FLDH : FINAL TIMES : ',I8,I7.6/ & -!/T ' ',I8,I7.6) -!/T 9062 FORMAT (' TEST W3FLDH : FINAL TIME : ',I8,I7.6) +#ifdef W3_T + 9000 FORMAT (' TEST W3FLDH : J, NDST/E : ',3I4/ & + ' DIMENSIONS : ',4I4/ & + ' T0 : ',I8,I7.6/ & + ' TN : ',I8,I7.6/ & + ' NH(M) : ',2I4/ & + ' TF0 : ',I8,I7.6/ & + ' TFN, IERR : ',I8,I7.6,I4) + 9001 FORMAT (' TEST W3FLDH : FIRST FIELD : ',L2) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3FLDH : FIELD SHIFTED') + 9021 FORMAT (' NO FIELD TO SHIFT') +#endif +! +#ifdef W3_T + 9050 FORMAT (' TEST W3FLDH : NEW VALUE(S) : ',3F8.2) + 9051 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6) + 9052 FORMAT (' TEST W3FLDH : NEW TIME : ',I8,I7.6, & + ' LAST FIELD (IERR =',I3,')') + 9060 FORMAT (' TEST W3FLDH : FILLING IN FIRST FIELD') + 9061 FORMAT (' TEST W3FLDH : FINAL TIMES : ',I8,I7.6/ & + ' ',I8,I7.6) + 9062 FORMAT (' TEST W3FLDH : FINAL TIME : ',I8,I7.6) +#endif !/ !/ End of W3FLDH ----------------------------------------------------- / !/ @@ -2418,7 +2628,9 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD ! IMPLICIT NONE @@ -2435,25 +2647,33 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTTST, DERA LOGICAL :: FLFRST !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLDM') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLDM') +#endif ! IERR = 0 DERA = ATAN(1.)/45. ! -!/T WRITE (NDST,9000) J, NDST, NDSE, T0, TN, NH, NHM, TF0, TFN, IERR +#ifdef W3_T + WRITE (NDST,9000) J, NDST, NDSE, T0, TN, NH, NHM, TF0, TFN, IERR +#endif ! ! Test field ID number for validity ! IF ( J .NE. 4 ) GOTO 801 FLFRST = TFN(1) .EQ. -1 ! -!/T WRITE (NDST,9001) FLFRST +#ifdef W3_T + WRITE (NDST,9001) FLFRST +#endif ! ! Backward branch point ============================================= * ! @@ -2466,9 +2686,11 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & IF ( TFN(1) .NE. -1 ) THEN A0 = AN D0 = DN -!/T WRITE (NDST,9020) -!/T ELSE -!/T WRITE (NDST,9021) +#ifdef W3_T + WRITE (NDST,9020) + ELSE + WRITE (NDST,9021) +#endif END IF ! ! New field @@ -2478,7 +2700,9 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & TFN(2) = THO(2,J,1) AN = HA(1,J) DN = ( 90. - HD(1,J) ) * DERA -!/T WRITE (NDST,9050) AN, DN +#ifdef W3_T + WRITE (NDST,9050) AN, DN +#endif ! ! Shift data arrays ! @@ -2489,7 +2713,9 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & HD(I,J) = HD(I+1,J) END DO NH = NH - 1 -!/T WRITE (NDST,9051) TFN +#ifdef W3_T + WRITE (NDST,9051) TFN +#endif ! ELSE ! @@ -2497,7 +2723,9 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & TFN(2) = TN(2) CALL TICK21 ( TFN , 1. ) IERR = -1 -!/T WRITE (NDST,9052) TFN, IERR +#ifdef W3_T + WRITE (NDST,9052) TFN, IERR +#endif ! END IF ! @@ -2509,14 +2737,18 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & ! Check if first field ! IF ( TF0(1).EQ.-1 ) THEN -!/T WRITE (NDST,9060) +#ifdef W3_T + WRITE (NDST,9060) +#endif TF0(1) = T0(1) TF0(2) = T0(2) A0 = AN D0 = DN END IF ! -!/T WRITE (NDST,9061) TF0, TFN +#ifdef W3_T + WRITE (NDST,9061) TF0, TFN +#endif ! RETURN ! @@ -2532,24 +2764,30 @@ SUBROUTINE W3FLDM (J, NDST, NDSE, T0, TN, NH, NHM, THO, HA, HD, & 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3FLDM : '/ & ' ILLEGAL FIELD ID NR : ',I4/) ! -!/T 9000 FORMAT (' TEST W3FLDM : J, NDST/E : ',3I4/ & -!/T ' T0 : ',I8,I7.6/ & -!/T ' TN : ',I8,I7.6/ & -!/T ' NH(M) : ',2I4/ & -!/T ' TF0 : ',I8,I7.6/ & -!/T ' TFN, IERR : ',I8,I7.6,I4) -!/T 9001 FORMAT (' TEST W3FLDM : FIRST FIELD : ',L2) -! -!/T 9020 FORMAT (' TEST W3FLDM : FIELD SHIFTED') -!/T 9021 FORMAT (' NO FIELD TO SHIFT') -! -!/T 9050 FORMAT (' TEST W3FLDM : NEW VALUE(S) : ',2F8.2) -!/T 9051 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6) -!/T 9052 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6, & -!/T ' LAST FIELD (IERR =',I3,')') -!/T 9060 FORMAT (' TEST W3FLDM : FILLING IN FIRST FIELD') -!/T 9061 FORMAT (' TEST W3FLDM : FINAL TIMES : ',I8,I7.6/ & -!/T ' ',I8,I7.6) +#ifdef W3_T + 9000 FORMAT (' TEST W3FLDM : J, NDST/E : ',3I4/ & + ' T0 : ',I8,I7.6/ & + ' TN : ',I8,I7.6/ & + ' NH(M) : ',2I4/ & + ' TF0 : ',I8,I7.6/ & + ' TFN, IERR : ',I8,I7.6,I4) + 9001 FORMAT (' TEST W3FLDM : FIRST FIELD : ',L2) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3FLDM : FIELD SHIFTED') + 9021 FORMAT (' NO FIELD TO SHIFT') +#endif +! +#ifdef W3_T + 9050 FORMAT (' TEST W3FLDM : NEW VALUE(S) : ',2F8.2) + 9051 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6) + 9052 FORMAT (' TEST W3FLDM : NEW TIME : ',I8,I7.6, & + ' LAST FIELD (IERR =',I3,')') + 9060 FORMAT (' TEST W3FLDM : FILLING IN FIRST FIELD') + 9061 FORMAT (' TEST W3FLDM : FINAL TIMES : ',I8,I7.6/ & + ' ',I8,I7.6) +#endif !/ !/ End of W3FLDM ----------------------------------------------------- / !/ diff --git a/model/ftn/w3flx1md.ftn b/model/src/w3flx1md.F90 similarity index 96% rename from model/ftn/w3flx1md.ftn rename to model/src/w3flx1md.F90 index 125ae00f2..426384394 100644 --- a/model/ftn/w3flx1md.ftn +++ b/model/src/w3flx1md.F90 @@ -116,7 +116,9 @@ SUBROUTINE W3FLX1 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -129,11 +131,15 @@ SUBROUTINE W3FLX1 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLX1') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLX1') +#endif ! ! 1. Tests ---------------------------------------------------------- * ! diff --git a/model/ftn/w3flx2md.ftn b/model/src/w3flx2md.F90 similarity index 97% rename from model/ftn/w3flx2md.ftn rename to model/src/w3flx2md.F90 index 89bb57f22..825860fba 100644 --- a/model/ftn/w3flx2md.ftn +++ b/model/src/w3flx2md.F90 @@ -123,7 +123,9 @@ SUBROUTINE W3FLX2 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) USE W3GDATMD, ONLY: NITTIN, CINXSI USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 !/ IMPLICIT NONE @@ -139,13 +141,17 @@ SUBROUTINE W3FLX2 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) !/ Local parameters !/ INTEGER :: I1, ITT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & RDCH, AFP !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLX2') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLX2') +#endif ! ! 1. Peak phase velocity -------------------------------------------- * ! diff --git a/model/ftn/w3flx3md.ftn b/model/src/w3flx3md.F90 similarity index 97% rename from model/ftn/w3flx3md.ftn rename to model/src/w3flx3md.F90 index fe976a811..5f797460d 100644 --- a/model/ftn/w3flx3md.ftn +++ b/model/src/w3flx3md.F90 @@ -126,7 +126,9 @@ SUBROUTINE W3FLX3 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) USE W3GDATMD, ONLY: NITTIN, CINXSI, CD_MAX, CAP_ID USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3DISPMD, ONLY: DSIE, N1MAX, EWN1 !/ IMPLICIT NONE @@ -142,13 +144,17 @@ SUBROUTINE W3FLX3 ( ZWIND, DEPTH, FP, U, UDIR, UST, USTD, Z0, CD ) !/ Local parameters !/ INTEGER :: I1, ITT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SQRTH, SIX, R1, WNP, CP, UNZ, ALPHA, & RDCH, AFP !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLX3') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLX3') +#endif ! ! 1. Peak phase velocity -------------------------------------------- * ! diff --git a/model/ftn/w3flx4md.ftn b/model/src/w3flx4md.F90 similarity index 97% rename from model/ftn/w3flx4md.ftn rename to model/src/w3flx4md.F90 index ff3df7bd3..ee23cebef 100644 --- a/model/ftn/w3flx4md.ftn +++ b/model/src/w3flx4md.F90 @@ -126,7 +126,9 @@ SUBROUTINE W3FLX4 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR USE W3GDATMD, ONLY: FLX4A0 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -139,11 +141,15 @@ SUBROUTINE W3FLX4 ( ZWND, U10, U10D, UST, USTD, Z0, CD ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLX4') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLX4') +#endif ! ! 1. Tests ---------------------------------------------------------- * ! diff --git a/model/ftn/w3flx5md.ftn b/model/src/w3flx5md.F90 similarity index 97% rename from model/ftn/w3flx5md.ftn rename to model/src/w3flx5md.F90 index 001a7ffcd..a4c21d2da 100644 --- a/model/ftn/w3flx5md.ftn +++ b/model/src/w3flx5md.F90 @@ -143,7 +143,9 @@ SUBROUTINE W3FLX5 ( ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR, UST, USTD, Z0, CD ) USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR ! USE W3GDATMD, ONLY: FLX5A0 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -157,11 +159,15 @@ SUBROUTINE W3FLX5 ( ZWND, U10, U10D, TAUA, TAUADIR, RHOAIR, UST, USTD, Z0, CD ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLX5') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLX5') +#endif ! ! 1. Tests ---------------------------------------------------------- * ! diff --git a/model/ftn/w3gdatmd.ftn b/model/src/w3gdatmd.F90 similarity index 71% rename from model/ftn/w3gdatmd.ftn rename to model/src/w3gdatmd.F90 index ead30ac9c..5c281eecb 100644 --- a/model/ftn/w3gdatmd.ftn +++ b/model/src/w3gdatmd.F90 @@ -603,7 +603,9 @@ MODULE W3GDATMD INTEGER :: NGRIDS = -1, IGRID = -1, ISGRD = -1, & IPARS = -1, NAUXGR ! -!/IC4 INTEGER, PARAMETER :: NIC4=10 +#ifdef W3_IC4 + INTEGER, PARAMETER :: NIC4=10 +#endif INTEGER, PARAMETER :: RLGTYPE = 1 INTEGER, PARAMETER :: CLGTYPE = 2 INTEGER, PARAMETER :: UNGTYPE = 3 @@ -615,8 +617,10 @@ MODULE W3GDATMD ! ! Dimensions of tables for pre-computing of dissipation ! -!/ST4 INTEGER, PARAMETER :: NKHS=2000, NKD=1300 -!/ST4 INTEGER, PARAMETER :: NDTAB=2000 +#ifdef W3_ST4 + INTEGER, PARAMETER :: NKHS=2000, NKD=1300 + INTEGER, PARAMETER :: NDTAB=2000 +#endif !/ !/ Data structures !/ @@ -626,16 +630,20 @@ MODULE W3GDATMD INTEGER :: RSTYPE = -1 INTEGER :: ICLOSE INTEGER :: NX, NY, NSEA, NSEAL, TRFLAG -!/SEC1 INTEGER :: NITERSEC1 +#ifdef W3_SEC1 + INTEGER :: NITERSEC1 +#endif INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & MAPFS(:,:), MAPSF(:,:) ! -!/SMC !!Li Cell and face arrays for SMC grid. -!/SMC INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct -!/SMC INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC -!/SMC INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) -!/SMC INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) -!/SMC INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) +#ifdef W3_SMC + !!Li Cell and face arrays for SMC grid. + INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) +#endif ! REAL :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & DTMIN, DMIN, CTMAX, FICE0, FICEN, FICEL, & @@ -645,9 +653,11 @@ MODULE W3GDATMD REAL(8) :: GRIDSHIFT ! see notes in WMGHGH -!/RTD REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon -!/RTD REAL, POINTER :: AnglD(:) ! Angle in degree -!/RTD LOGICAL :: FLAGUNR +#ifdef W3_RTD + REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon + REAL, POINTER :: AnglD(:) ! Angle in degree + LOGICAL :: FLAGUNR +#endif REAL , POINTER :: ZB(:) ! BOTTOM GRID, DEFINED ON ISEA REAL , POINTER :: CLATS(:) ! COS(LAT), DEFINED ON SEA POINTS @@ -655,7 +665,9 @@ MODULE W3GDATMD REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY -!/SMC REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#ifdef W3_SMC + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif REAL , POINTER :: SPCBAC(:,:), ANGARC(:) REAL , POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY @@ -674,34 +686,54 @@ MODULE W3GDATMD CHARACTER(LEN=30):: GNAME CHARACTER(LEN=13):: FILEXT LOGICAL :: GUGINIT -!/REF1 REAL, POINTER :: REFLC(:,:) ! reflection coefficient -!/REF1 INTEGER, POINTER :: REFLD(:,:) ! reflection direction +#ifdef W3_REF1 + REAL, POINTER :: REFLC(:,:) ! reflection coefficient + INTEGER, POINTER :: REFLD(:,:) ! reflection direction +#endif INTEGER :: E3DF(3,5), P2MSF(3), US3DF(3), USSPF(2) ! freq. indices for 3D output REAL :: USSP_WN(25) !Max set to 25 decay scales. ! TYPE(T_GSU) :: GSU ! Grid search utility object ! REAL :: FFACBERG ! mutiplicative factor for iceberg mask -!/BT4 REAL, POINTER :: SED_D50(:), SED_PSIC(:) -!/REF1 LOGICAL, POINTER :: RREF(:) -!/REF1 REAL, POINTER :: REFPARS(:) -!/IG1 REAL, POINTER :: IGPARS(:) -!/IC2 REAL, POINTER :: IC2PARS(:) -!/IC3 REAL, POINTER :: IC3PARS(:) -!/IC4 INTEGER, POINTER :: IC4PARS(:) -!/IC4 REAL, POINTER :: IC4_KI(:) -!/IC4 REAL, POINTER :: IC4_FC(:) -!/IC5 REAL, POINTER :: IC5PARS(:) -!/IS2 REAL, POINTER :: IS2PARS(:) +#ifdef W3_BT4 + REAL, POINTER :: SED_D50(:), SED_PSIC(:) +#endif +#ifdef W3_REF1 + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) +#endif +#ifdef W3_IG1 + REAL, POINTER :: IGPARS(:) +#endif +#ifdef W3_IC2 + REAL, POINTER :: IC2PARS(:) +#endif +#ifdef W3_IC3 + REAL, POINTER :: IC3PARS(:) +#endif +#ifdef W3_IC4 + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) +#endif +#ifdef W3_IC5 + REAL, POINTER :: IC5PARS(:) +#endif +#ifdef W3_IS2 + REAL, POINTER :: IS2PARS(:) +#endif ! ! unstructured data ! INTEGER :: NTRI DOUBLE PRECISION, POINTER :: XYB(:,:) INTEGER, POINTER :: TRIGP(:,:) -!/PDLIB INTEGER :: NBND_MAP -!/PDLIB INTEGER, POINTER :: INDEX_MAP(:) -!/PDLIB INTEGER, POINTER :: MAPSTA_LOC(:) +#ifdef W3_PDLIB + INTEGER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) +#endif REAL(8), POINTER :: LEN(:,:),SI(:), IEN(:,:) REAL :: MAXX, MAXY, DXYMAX @@ -709,23 +741,27 @@ MODULE W3GDATMD INTEGER :: COUNTRI,COUNTOT,NNZ, NBEDGE INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & POS_CELL(:), IOBP(:), IOBPD(:,:), IOBDP(:), IOBPA(:), & -!/PDLIB IOBPD_loc(:,:), IOBP_loc(:), & +#ifdef W3_PDLIB + IOBPD_loc(:,:), IOBP_loc(:), & +#endif IAA(:), JAA(:), POSI(:,:), INDEX_CELL(:), & I_DIAG(:), JA_IE(:,:,:) INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) REAL(8), POINTER :: TRIA(:) REAL, POINTER :: CROSSDIFF(:,:) -!/UOST CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW -!/UOST LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) -!/UOST INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) -!/UOST INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) -!/UOST REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) -!/UOST REAL :: UOSTABMULTFACTOR = 100 -!/UOST REAL :: UOSTCELLSIZEFACTOR = 1000 -!/UOST REAL :: UOSTLOCALFACTOR = 1 -!/UOST REAL :: UOSTSHADOWFACTOR = 1 -!/UOST LOGICAL :: UOSTENABLED = .true. +#ifdef W3_UOST + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) + INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) + INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) + REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) + REAL :: UOSTABMULTFACTOR = 100 + REAL :: UOSTCELLSIZEFACTOR = 1000 + REAL :: UOSTLOCALFACTOR = 1 + REAL :: UOSTSHADOWFACTOR = 1 + LOGICAL :: UOSTENABLED = .true. +#endif END TYPE GRID ! @@ -743,140 +779,228 @@ MODULE W3GDATMD TYPE NPAR REAL :: FACP, XREL, XFLT, FXFM, FXPM, & XFT, XFC, FACSD, FHMAX -!/RWND REAL :: RWINDC -!/WCOR REAL :: WWCOR(2) +#ifdef W3_RWND + REAL :: RWINDC +#endif +#ifdef W3_WCOR + REAL :: WWCOR(2) +#endif END TYPE NPAR ! TYPE PROP -!/PR0 REAL :: DUMMY -!/PR1 REAL :: DUMMY -!/PR2 REAL :: DTME, CLATMN -!/PR3 REAL :: WDCG, WDTH -!/SMC REAL :: DTMS, Refran -!/SMC LOGICAL :: FUNO3, FVERG, FSWND, ARCTC +#ifdef W3_PR0 + REAL :: DUMMY +#endif +#ifdef W3_PR1 + REAL :: DUMMY +#endif +#ifdef W3_PR2 + REAL :: DTME, CLATMN +#endif +#ifdef W3_PR3 + REAL :: WDCG, WDTH +#endif +#ifdef W3_SMC + REAL :: DTMS, Refran + LOGICAL :: FUNO3, FVERG, FSWND, ARCTC +#endif END TYPE PROP ! TYPE FLDP REAL :: DUMMY -!/FLD1 INTEGER :: Tail_ID -!/FLD1 REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 -!/FLD2 INTEGER :: Tail_ID -!/FLD2 REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 +#ifdef W3_FLD1 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 +#endif +#ifdef W3_FLD2 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 +#endif END TYPE FLDP TYPE SFLP -!/FLX0 REAL :: DUMMY -!/FLX1 REAL :: DUMMY -!/FLX2 INTEGER :: NITTIN -!/FLX2 REAL :: CINXSI -!/FLX3 INTEGER :: NITTIN, CAP_ID -!/FLX3 REAL :: CINXSI, CD_MAX -!/FLX4 REAL :: FLX4A0 +#ifdef W3_FLX0 + REAL :: DUMMY +#endif +#ifdef W3_FLX1 + REAL :: DUMMY +#endif +#ifdef W3_FLX2 + INTEGER :: NITTIN + REAL :: CINXSI +#endif +#ifdef W3_FLX3 + INTEGER :: NITTIN, CAP_ID + REAL :: CINXSI, CD_MAX +#endif +#ifdef W3_FLX4 + REAL :: FLX4A0 +#endif END TYPE SFLP ! TYPE SLNP -!/SEED REAL :: DUMMY -!/LN0 REAL :: DUMMY -!/LN1 REAL :: SLNC1, FSPM, FSHF +#ifdef W3_SEED + REAL :: DUMMY +#endif +#ifdef W3_LN0 + REAL :: DUMMY +#endif +#ifdef W3_LN1 + REAL :: SLNC1, FSPM, FSHF +#endif END TYPE SLNP ! TYPE SRCP REAL :: WWNMEANPTAIL, SSTXFTFTAIL -!/ST1 REAL :: SINC1, SDSC1 -!/ST2 REAL :: ZWIND, FSWELL, SHSTAB, & -!/ST2 OFSTAB, CCNG, CCPS, FFNG, FFPS, & -!/ST2 CDSA0, CDSA1, CDSA2, SDSALN, & -!/ST2 CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & -!/ST2 XFH, XF1, XF2 -!/ST3 INTEGER :: SSDSISO, SSDSBRFDF -!/ST3 REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& -!/ST3 SSINTHP, TTAUWSHELTER, SSWELLF(1:6), & -!/ST3 SSDSC1, SSDSC2, SSDSC3, SSDSBR, & -!/ST3 SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & -!/ST3 FFXPM, FFXFM, & -!/ST3 SSDSC4, SSDSC5, SSDSC6, DDELTA1, & -!/ST3 DDELTA2, ZZWND -! -!/ST4 INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF -!/ST4 INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) -!/ST4 REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) -!/ST4 REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& -!/ST4 SSINTHP, TTAUWSHELTER, SSWELLF(1:7), & -!/ST4 SSDSC(1:21), SSDSBR, & -!/ST4 SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & -!/ST4 FFXPM, FFXFM, FFXFA, & -!/ST4 SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK,& -!/ST4 SSDSHCK, SSDSABK, SSDSPBK, SSINBR -!/ST4 REAL :: ZZWND -!/ST4 REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) -! -!/ST6 REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & -!/ST6 SIN6WS, SIN6FC -!/ST6 INTEGER :: SDS6P1, SDS6P2 -!/ST6 LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 +#ifdef W3_ST1 + REAL :: SINC1, SDSC1 +#endif +#ifdef W3_ST2 + REAL :: ZWIND, FSWELL, SHSTAB, & + OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & + XFH, XF1, XF2 +#endif +#ifdef W3_ST3 + INTEGER :: SSDSISO, SSDSBRFDF + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& + SSINTHP, TTAUWSHELTER, SSWELLF(1:6), & + SSDSC1, SSDSC2, SSDSC3, SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM, & + SSDSC4, SSDSC5, SSDSC6, DDELTA1, & + DDELTA2, ZZWND +#endif +! +#ifdef W3_ST4 + INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF + INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& + SSINTHP, TTAUWSHELTER, SSWELLF(1:7), & + SSDSC(1:21), SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM, FFXFA, & + SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK,& + SSDSHCK, SSDSABK, SSDSPBK, SSINBR + REAL :: ZZWND + REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) +#endif +! +#ifdef W3_ST6 + REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & + SIN6WS, SIN6FC + INTEGER :: SDS6P1, SDS6P2 + LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif END TYPE SRCP ! TYPE SNLP -!/NL0 REAL :: DUMMY -!/NL1 REAL :: SNLC1, LAM, KDCON, KDMN, & -!/NL1 SNLS1, SNLS2, SNLS3 -!/NL2 INTEGER :: IQTPE, NDPTHS -!/NL2 REAL :: NLTAIL -!/NL2 REAL, POINTER :: DPTHNL(:) -!/NL3 INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & -!/NL3 NTHEXP, NSPMIN, NSPMAX, NSPMX2, & -!/NL3 NQA, SNLNQ -!/NL3 INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) -!/NL3 REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS -!/NL3 REAL, POINTER :: FRQ(:), XSI(:), & -!/NL3 QST2(:,:,:), QST3(:,:,:), & -!/NL3 QST5(:,:,:), QST6(:,:,:), & -!/NL3 SNLL(:), SNLM(:), SNLT(:), & -!/NL3 SNLCD(:), SNLCS(:) -!/NL4 INTEGER :: ITSA, IALT -!/NL5 REAL :: QR5DPT, QR5OML -!/NL5 INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX -!/NL5 INTEGER(KIND=8) :: QI5NNZ -!/NLS INTEGER :: NTHX, NFRX, NSPL, NSPH -!/NLS REAL :: CNLSA, CNLSC, CNLSFM, & -!/NLS CNLSC1, CNLSC2, CNLSC3 -!/NLS REAL, POINTER :: SNSST(:,:) +#ifdef W3_NL0 + REAL :: DUMMY +#endif +#ifdef W3_NL1 + REAL :: SNLC1, LAM, KDCON, KDMN, & + SNLS1, SNLS2, SNLS3 +#endif +#ifdef W3_NL2 + INTEGER :: IQTPE, NDPTHS + REAL :: NLTAIL + REAL, POINTER :: DPTHNL(:) +#endif +#ifdef W3_NL3 + INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & + NTHEXP, NSPMIN, NSPMAX, NSPMX2, & + NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), & + QST2(:,:,:), QST3(:,:,:), & + QST5(:,:,:), QST6(:,:,:), & + SNLL(:), SNLM(:), SNLT(:), & + SNLCD(:), SNLCS(:) +#endif +#ifdef W3_NL4 + INTEGER :: ITSA, IALT +#endif +#ifdef W3_NL5 + REAL :: QR5DPT, QR5OML + INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8) :: QI5NNZ +#endif +#ifdef W3_NLS + INTEGER :: NTHX, NFRX, NSPL, NSPH + REAL :: CNLSA, CNLSC, CNLSFM, & + CNLSC1, CNLSC2, CNLSC3 + REAL, POINTER :: SNSST(:,:) +#endif END TYPE SNLP ! TYPE SBTP -!/BT0 REAL :: DUMMY -!/BT1 REAL :: SBTC1 -!/BT4 REAL :: SBTCX(10) -!/BT8 REAL :: DUMMY -!/BT9 REAL :: DUMMY +#ifdef W3_BT0 + REAL :: DUMMY +#endif +#ifdef W3_BT1 + REAL :: SBTC1 +#endif +#ifdef W3_BT4 + REAL :: SBTCX(10) +#endif +#ifdef W3_BT8 + REAL :: DUMMY +#endif +#ifdef W3_BT9 + REAL :: DUMMY +#endif END TYPE SBTP ! TYPE SDBP -!/DB0 REAL :: DUMMY -!/DB1 REAL :: SDBC1, SDBC2 -!/DB1 LOGICAL :: FDONLY +#ifdef W3_DB0 + REAL :: DUMMY +#endif +#ifdef W3_DB1 + REAL :: SDBC1, SDBC2 + LOGICAL :: FDONLY +#endif END TYPE SDBP -!/UOST TYPE UOSTP -!/UOST CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW -!/UOST REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW -!/UOST END TYPE UOSTP +#ifdef W3_UOST + TYPE UOSTP + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW + END TYPE UOSTP +#endif ! TYPE STRP -!/TR0 REAL :: DUMMY -!/TR1 REAL :: DUMMY +#ifdef W3_TR0 + REAL :: DUMMY +#endif +#ifdef W3_TR1 + REAL :: DUMMY +#endif END TYPE STRP ! TYPE SBSP -!/BS0 REAL :: DUMMY -!/BS1 REAL :: DUMMY +#ifdef W3_BS0 + REAL :: DUMMY +#endif +#ifdef W3_BS1 + REAL :: DUMMY +#endif END TYPE SBSP ! TYPE SICP -!/IS0 REAL :: DUMMY -!/IS1 REAL :: IS1C1, IS1C2 -!/IS2 REAL :: IS2C1, IS2C2 +#ifdef W3_IS0 + REAL :: DUMMY +#endif +#ifdef W3_IS1 + REAL :: IS1C1, IS1C2 +#endif +#ifdef W3_IS2 + REAL :: IS2C1, IS2C2 +#endif END TYPE SICP ! specific type for unstructured scheme @@ -920,7 +1044,9 @@ MODULE W3GDATMD TYPE(SNLP) :: SNLPS TYPE(SBTP) :: SBTPS TYPE(SDBP) :: SDBPS -!/UOST TYPE(UOSTP) :: UOSTPS +#ifdef W3_UOST + TYPE(UOSTP) :: UOSTPS +#endif TYPE(STRP) :: STRPS TYPE(SBSP) :: SBSPS TYPE(SICP) :: SICPS @@ -941,8 +1067,10 @@ MODULE W3GDATMD INTEGER, POINTER :: NX, NY, NSEA, NSEAL, TRFLAG INTEGER, POINTER :: E3DF(:,:), P2MSF(:), US3DF(:), USSPF(:) REAL, POINTER :: USSP_WN(:) -!/REF1 REAL, POINTER :: REFLC(:,:) -!/REF1 INTEGER, POINTER :: REFLD(:,:) +#ifdef W3_REF1 + REAL, POINTER :: REFLC(:,:) + INTEGER, POINTER :: REFLD(:,:) +#endif INTEGER, POINTER :: NBEDGE INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) ! @@ -954,14 +1082,18 @@ MODULE W3GDATMD ! but these XGRD and YGRD should probably be double precision DOUBLE PRECISION, POINTER :: XYB(:,:) INTEGER, POINTER :: TRIGP(:,:) -!/PDLIB INTEGER, POINTER :: NBND_MAP -!/PDLIB INTEGER, POINTER :: INDEX_MAP(:) -!/PDLIB INTEGER, POINTER :: MAPSTA_LOC(:) +#ifdef W3_PDLIB + INTEGER, POINTER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) +#endif REAL(8), POINTER :: IEN(:,:), LEN(:,:), SI(:) REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & POS_CELL(:), IOBP(:), IOBPD(:,:), IOBDP(:), IOBPA(:), & -!/PDLIB IOBPD_loc(:,:), IOBP_loc(:), & +#ifdef W3_PDLIB + IOBPD_loc(:,:), IOBP_loc(:), & +#endif IAA(:), JAA(:), POSI(:,:), & I_DIAG(:), JA_IE(:,:,:), & INDEX_CELL(:) @@ -971,26 +1103,44 @@ MODULE W3GDATMD LOGICAL, POINTER :: GUGINIT ! REAL, POINTER :: FFACBERG -!/REF1 LOGICAL, POINTER :: RREF(:) -!/REF1 REAL, POINTER :: REFPARS(:) -!/IG1 REAL, POINTER :: IGPARS(:) -!/IC2 REAL, POINTER :: IC2PARS(:) -!/IC3 REAL, POINTER :: IC3PARS(:) -!/IC4 INTEGER, POINTER :: IC4PARS(:) -!/IC4 REAL, POINTER :: IC4_KI(:) -!/IC4 REAL, POINTER :: IC4_FC(:) -!/IC5 REAL, POINTER :: IC5PARS(:) -!/IS2 REAL, POINTER :: IS2PARS(:) +#ifdef W3_REF1 + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) +#endif +#ifdef W3_IG1 + REAL, POINTER :: IGPARS(:) +#endif +#ifdef W3_IC2 + REAL, POINTER :: IC2PARS(:) +#endif +#ifdef W3_IC3 + REAL, POINTER :: IC3PARS(:) +#endif +#ifdef W3_IC4 + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) +#endif +#ifdef W3_IC5 + REAL, POINTER :: IC5PARS(:) +#endif +#ifdef W3_IS2 + REAL, POINTER :: IS2PARS(:) +#endif INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & MAPFS(:,:), MAPSF(:,:) ! -!/SMC INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct -!/SMC INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC -!/SMC INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) -!/SMC INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) -!/SMC INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) +#ifdef W3_SMC + INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) +#endif ! -!/SEC1 INTEGER, POINTER :: NITERSEC1 +#ifdef W3_SEC1 + INTEGER, POINTER :: NITERSEC1 +#endif REAL, POINTER :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & DTMIN, DMIN, CTMAX, FICE0, FICEN, & FICEL, PFMOVE, STEXU, STEYU, STEDU, & @@ -998,15 +1148,19 @@ MODULE W3GDATMD IICEHFAC, IICEHDISP, IICEDDISP, IICEFDISP, & BTBETA, AAIRCMIN, AAIRGB REAL(8),POINTER :: GRIDSHIFT ! see notes in WMGHGH -!/RTD REAL, POINTER :: PoLat, PoLon -!/RTD REAL, POINTER :: AnglD(:) -!/RTD LOGICAL, POINTER :: FLAGUNR +#ifdef W3_RTD + REAL, POINTER :: PoLat, PoLon + REAL, POINTER :: AnglD(:) + LOGICAL, POINTER :: FLAGUNR +#endif REAL , POINTER :: ZB(:), CLATS(:) REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY -!/SMC REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#ifdef W3_SMC + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif REAL , POINTER :: SPCBAC(:,:), ANGARC(:) REAL , POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY @@ -1016,7 +1170,9 @@ MODULE W3GDATMD REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY -!/BT4 REAL, POINTER :: SED_D50(:), SED_PSIC(:) +#ifdef W3_BT4 + REAL, POINTER :: SED_D50(:), SED_PSIC(:) +#endif LOGICAL, POINTER :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& IICESMOOTH @@ -1048,106 +1204,158 @@ MODULE W3GDATMD !/ REAL, POINTER :: FACP, XREL, XFLT, FXFM, FXPM, & XFT, XFC, FACSD, FHMAX -!/RWND REAL, POINTER :: RWINDC -!/WCOR REAL, POINTER :: WWCOR(:) +#ifdef W3_RWND + REAL, POINTER :: RWINDC +#endif +#ifdef W3_WCOR + REAL, POINTER :: WWCOR(:) +#endif !/ !/ Data aliasses for structure PROP(S) !/ -!/PR2 REAL, POINTER :: DTME, CLATMN -!/PR3 REAL, POINTER :: WDCG, WDTH -!/SMC REAL, POINTER :: DTMS, Refran -!/SMC LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC +#ifdef W3_PR2 + REAL, POINTER :: DTME, CLATMN +#endif +#ifdef W3_PR3 + REAL, POINTER :: WDCG, WDTH +#endif +#ifdef W3_SMC + REAL, POINTER :: DTMS, Refran + LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC +#endif !/ !/ Data aliasses for structure FLDP(S) !/ -!/FLD1 INTEGER, POINTER :: TAIL_ID -!/FLD1 REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 -!/FLD2 INTEGER, POINTER :: TAIL_ID -!/FLD2 REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 +#ifdef W3_FLD1 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 +#endif +#ifdef W3_FLD2 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 +#endif !/ !/ Data aliasses for structure SFLP(S) !/ -!/FLX2 INTEGER, POINTER :: NITTIN -!/FLX2 REAL, POINTER :: CINXSI -!/FLX3 INTEGER, POINTER :: NITTIN, CAP_ID -!/FLX3 REAL, POINTER :: CINXSI, CD_MAX -!/FLX4 REAL, POINTER :: FLX4A0 +#ifdef W3_FLX2 + INTEGER, POINTER :: NITTIN + REAL, POINTER :: CINXSI +#endif +#ifdef W3_FLX3 + INTEGER, POINTER :: NITTIN, CAP_ID + REAL, POINTER :: CINXSI, CD_MAX +#endif +#ifdef W3_FLX4 + REAL, POINTER :: FLX4A0 +#endif !/ !/ Data aliasses for structure SLNP(S) !/ -!/LN1 REAL, POINTER :: SLNC1, FSPM, FSHF +#ifdef W3_LN1 + REAL, POINTER :: SLNC1, FSPM, FSHF +#endif !/ !/ Data aliasses for structure SRCP(S) !/ -!/ST1 REAL, POINTER :: SINC1, SDSC1 -!/ST2 REAL, POINTER :: ZWIND, FSWELL, SHSTAB, & -!/ST2 OFSTAB, CCNG, CCPS, FFNG, FFPS, & -!/ST2 CDSA0, CDSA1, CDSA2, SDSALN, & -!/ST2 CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & -!/ST2 XFH, XF1, XF2 -!/ST3 REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& -!/ST3 ZZALP, FFXFM, FFXPM, & -!/ST3 SSINTHP, TTAUWSHELTER, SSWELLF(:), & -!/ST3 SSDSC1, SSDSC2, SSDSC3, SSDSBR, & -!/ST3 SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & -!/ST3 SSDSC4, SSDSC5, SSDSC6, SSDSBT, & -!/ST3 DDELTA1, DDELTA2, & -!/ST3 SSDSCOS, SSDSDTH, SSDSBM(:) -!/ST4 INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, & -!/ST4 IKTAB(:,:), SATINDICES(:,:),SSDSDIK -!/ST4 REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) -!/ST4 REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& -!/ST4 ZZALP, FFXFA, & -!/ST4 FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, & -!/ST4 SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK, & -!/ST4 SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER,& -!/ST4 SSWELLF(:), SSDSC(:), SSDSBR, & -!/ST4 SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & -!/ST4 SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) -!/ST6 REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & -!/ST6 SIN6WS, SIN6FC -!/ST6 INTEGER, POINTER :: SDS6P1, SDS6P2 -!/ST6 LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 +#ifdef W3_ST1 + REAL, POINTER :: SINC1, SDSC1 +#endif +#ifdef W3_ST2 + REAL, POINTER :: ZWIND, FSWELL, SHSTAB, & + OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & + XFH, XF1, XF2 +#endif +#ifdef W3_ST3 + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& + ZZALP, FFXFM, FFXPM, & + SSINTHP, TTAUWSHELTER, SSWELLF(:), & + SSDSC1, SSDSC2, SSDSC3, SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + SSDSC4, SSDSC5, SSDSC6, SSDSBT, & + DDELTA1, DDELTA2, & + SSDSCOS, SSDSDTH, SSDSBM(:) +#endif +#ifdef W3_ST4 + INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, & + IKTAB(:,:), SATINDICES(:,:),SSDSDIK + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& + ZZALP, FFXFA, & + FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, & + SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK, & + SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER,& + SSWELLF(:), SSDSC(:), SSDSBR, & + SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & + SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) +#endif +#ifdef W3_ST6 + REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & + SIN6WS, SIN6FC + INTEGER, POINTER :: SDS6P1, SDS6P2 + LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif REAL, POINTER :: WWNMEANPTAIL, SSTXFTFTAIL !/ !/ Data aliasses for structure SNLP(S) !/ -!/NL1 REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, & -!/NL1 SNLS1, SNLS2, SNLS3 -!/NL2 INTEGER, POINTER :: IQTPE, NDPTHS -!/NL2 REAL, POINTER :: NLTAIL -!/NL2 REAL, POINTER :: DPTHNL(:) -!/NL3 INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & -!/NL3 NTHEXP, NSPMIN, NSPMAX, NSPMX2, & -!/NL3 NQA, SNLNQ -!/NL3 INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) -!/NL3 REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS -!/NL3 REAL, POINTER :: FRQ(:), XSI(:), & -!/NL3 QST2(:,:,:), QST3(:,:,:), & -!/NL3 QST5(:,:,:), QST6(:,:,:), & -!/NL3 SNLL(:), SNLM(:), SNLT(:), & -!/NL3 SNLCD(:), SNLCS(:) -!/NL4 INTEGER, POINTER :: ITSA, IALT -!/NL5 REAL, POINTER :: QR5DPT, QR5OML -!/NL5 INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX -!/NL5 INTEGER(KIND=8), POINTER:: QI5NNZ -!/NLS INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH -!/NLS REAL, POINTER :: CNLSA, CNLSC, CNLSFM, & -!/NLS CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) +#ifdef W3_NL1 + REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, & + SNLS1, SNLS2, SNLS3 +#endif +#ifdef W3_NL2 + INTEGER, POINTER :: IQTPE, NDPTHS + REAL, POINTER :: NLTAIL + REAL, POINTER :: DPTHNL(:) +#endif +#ifdef W3_NL3 + INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & + NTHEXP, NSPMIN, NSPMAX, NSPMX2, & + NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), & + QST2(:,:,:), QST3(:,:,:), & + QST5(:,:,:), QST6(:,:,:), & + SNLL(:), SNLM(:), SNLT(:), & + SNLCD(:), SNLCS(:) +#endif +#ifdef W3_NL4 + INTEGER, POINTER :: ITSA, IALT +#endif +#ifdef W3_NL5 + REAL, POINTER :: QR5DPT, QR5OML + INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8), POINTER:: QI5NNZ +#endif +#ifdef W3_NLS + INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH + REAL, POINTER :: CNLSA, CNLSC, CNLSFM, & + CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) +#endif !/ !/ Data aliasses for structure SBTP(S) !/ -!/BT1 REAL, POINTER :: SBTC1 -!/BT4 REAL, POINTER :: SBTCX(:) +#ifdef W3_BT1 + REAL, POINTER :: SBTC1 +#endif +#ifdef W3_BT4 + REAL, POINTER :: SBTCX(:) +#endif !/ !/ Data aliasses for structure SDBP(S) !/ -!/DB1 REAL, POINTER :: SDBC1, SDBC2 -!/DB1 LOGICAL, POINTER :: FDONLY +#ifdef W3_DB1 + REAL, POINTER :: SDBC1, SDBC2 + LOGICAL, POINTER :: FDONLY +#endif !/ -!/UOST!/ Data aliases for structure UOSTP(S) -!/UOST CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW -!/UOST REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW +#ifdef W3_UOST +!/ Data aliases for structure UOSTP(S) + CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW + REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif !/ !/ Data aliasing for structure SCHM(S) LOGICAL, POINTER :: FSN,FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP @@ -1169,7 +1377,9 @@ MODULE W3GDATMD LOGICAL, POINTER :: B_JGS_SOURCE_NONLINEAR !/ !/ Data aliasing for structure SICP(S) -!/IS1 REAL, POINTER :: IS1C1, IS1C2 +#ifdef W3_IS1 + REAL, POINTER :: IS1C1, IS1C2 +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -1230,7 +1440,9 @@ SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1244,9 +1456,13 @@ SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) !/ Local parameters !/ INTEGER :: I, NLOW -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3NMOD') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMOD') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1291,7 +1507,9 @@ SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) GRIDS(I)%GUGINIT = .FALSE. SGRDS(I)%SINIT = .FALSE. MPARS(I)%PINIT = .FALSE. -!/NL2 MPARS(I)%SNLPS%NDPTHS = 0 +#ifdef W3_NL2 + MPARS(I)%SNLPS%NDPTHS = 0 +#endif END DO #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3NMOD) WRITE (NDST,9000) NLOW, NGRIDS @@ -1317,10 +1535,14 @@ SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) END SUBROUTINE W3NMOD !/ ------------------------------------------------------------------- / SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & -!/SMC , MCel, MUFc, MVFc, MRLv, MBSMC & -!/SMC , MARC, MBAC, MSPEC & +#ifdef W3_SMC + , MCel, MUFc, MVFc, MRLv, MBSMC & + , MARC, MBAC, MSPEC & +#endif ) -!/SMC !!Li A few dimensional numbers for SMC grid. +#ifdef W3_SMC + !!Li A few dimensional numbers for SMC grid. +#endif !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | @@ -1397,7 +1619,9 @@ SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -1406,16 +1630,24 @@ SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & !/ Parameter list !/ INTEGER, INTENT(IN) :: IMOD, MX, MY, MSEA, NDSE, NDST -!/SMC INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC -!/SMC INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC +#ifdef W3_SMC + INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC + INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/SMC INTEGER :: IARC, IBAC, IBSMC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_SMC + INTEGER :: IARC, IBAC, IBSMC +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DIMX') +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMX') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1453,7 +1685,9 @@ SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & GRIDS(IMOD)%MAPFS(MY,MX), & GRIDS(IMOD)%MAPSF(MSEA,3), & GRIDS(IMOD)%FLAGST(MSEA), & -!/RTD GRIDS(IMOD)%AnglD(MSEA), & +#ifdef W3_RTD + GRIDS(IMOD)%AnglD(MSEA), & +#endif GRIDS(IMOD)%ZB(MSEA), & GRIDS(IMOD)%CLATS(0:MSEA), & GRIDS(IMOD)%CLATIS(0:MSEA), & @@ -1477,51 +1711,59 @@ SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & CHECK_ALLOC_STATUS ( ISTAT ) !!/DEBUGINIT WRITE(740+IAPROC,*) 'After alocation of MAPST2, MY=', MY, ' MX=', MX !!/DEBUGINIT FLUSH(740+IAPROC) -!/BT4 ALLOCATE ( GRIDS(IMOD)%SED_D50(0:MSEA), & -!/BT4 GRIDS(IMOD)%SED_PSIC(0:MSEA),& -!/BT4 STAT=ISTAT ) -!/BT4 CHECK_ALLOC_STATUS ( ISTAT ) -! -!/SMC ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & -!/SMC GRIDS(IMOD)%NLvUFc(0:MRLv), & -!/SMC GRIDS(IMOD)%NLvVFc(0:MRLv), & -!/SMC GRIDS(IMOD)%IJKCel(5, -9:MCel), & -!/SMC GRIDS(IMOD)%IJKUFc(7,MUFc), & -!/SMC GRIDS(IMOD)%IJKVFc(8,MVFc), & -!/SMC GRIDS(IMOD)%CTRNX(-9:MCel), & -!/SMC GRIDS(IMOD)%CTRNY(-9:MCel), & -!/SMC GRIDS(IMOD)%CLATF(MVFc), & -!/SMC STAT=ISTAT ) -!/SMC CHECK_ALLOC_STATUS ( ISTAT ) -! -!/SMC !! Arctic part related variables, declare minimum 1 element. -!/SMC IARC = MARC -!/SMC IF( MARC .LE. 1 ) IARC = 1 -!/SMC IBAC = MBAC -!/SMC IF( MBAC .LE. 1 ) IBAC = 1 -!/SMC IBSMC = MBSMC -!/SMC IF( MBSMC .LE. 1 ) IBSMC = 1 -!/SMC ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & -!/SMC GRIDS(IMOD)%ANGARC(IARC), & -!/SMC GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & -!/SMC GRIDS(IMOD)%ISMCBP(IBSMC), & -!/SMC STAT=ISTAT ) -!/SMC CHECK_ALLOC_STATUS ( ISTAT ) -! -!/SMC !! All SMC grid related varialbes are initialised in case SMC -!/SMC !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 -!/SMC GRIDS(IMOD)%NLvCel(:) = 0 -!/SMC GRIDS(IMOD)%NLvUFc(:) = 0 -!/SMC GRIDS(IMOD)%NLvVFc(:) = 0 -!/SMC GRIDS(IMOD)%ISMCBP(:) = 0 -!/SMC GRIDS(IMOD)%ICLBAC(:) = 0 -!/SMC GRIDS(IMOD)%IJKCel(:,:) = 0 -!/SMC GRIDS(IMOD)%IJKUFc(:,:) = 0 -!/SMC GRIDS(IMOD)%IJKVFc(:,:) = 0 -!/SMC GRIDS(IMOD)%CTRNX(:) = 0.0 -!/SMC GRIDS(IMOD)%CTRNY(:) = 0.0 -!/SMC GRIDS(IMOD)%CLATF(:) = 0.0 -!/SMC GRIDS(IMOD)%ANGARC(:) = 0.0 +#ifdef W3_BT4 + ALLOCATE ( GRIDS(IMOD)%SED_D50(0:MSEA), & + GRIDS(IMOD)%SED_PSIC(0:MSEA),& + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_SMC + ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & + GRIDS(IMOD)%NLvUFc(0:MRLv), & + GRIDS(IMOD)%NLvVFc(0:MRLv), & + GRIDS(IMOD)%IJKCel(5, -9:MCel), & + GRIDS(IMOD)%IJKUFc(7,MUFc), & + GRIDS(IMOD)%IJKVFc(8,MVFc), & + GRIDS(IMOD)%CTRNX(-9:MCel), & + GRIDS(IMOD)%CTRNY(-9:MCel), & + GRIDS(IMOD)%CLATF(MVFc), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_SMC + !! Arctic part related variables, declare minimum 1 element. + IARC = MARC + IF( MARC .LE. 1 ) IARC = 1 + IBAC = MBAC + IF( MBAC .LE. 1 ) IBAC = 1 + IBSMC = MBSMC + IF( MBSMC .LE. 1 ) IBSMC = 1 + ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & + GRIDS(IMOD)%ANGARC(IARC), & + GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & + GRIDS(IMOD)%ISMCBP(IBSMC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_SMC + !! All SMC grid related varialbes are initialised in case SMC + !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 + GRIDS(IMOD)%NLvCel(:) = 0 + GRIDS(IMOD)%NLvUFc(:) = 0 + GRIDS(IMOD)%NLvVFc(:) = 0 + GRIDS(IMOD)%ISMCBP(:) = 0 + GRIDS(IMOD)%ICLBAC(:) = 0 + GRIDS(IMOD)%IJKCel(:,:) = 0 + GRIDS(IMOD)%IJKUFc(:,:) = 0 + GRIDS(IMOD)%IJKVFc(:,:) = 0 + GRIDS(IMOD)%CTRNX(:) = 0.0 + GRIDS(IMOD)%CTRNY(:) = 0.0 + GRIDS(IMOD)%CLATF(:) = 0.0 + GRIDS(IMOD)%ANGARC(:) = 0.0 +#endif ! GRIDS(IMOD)%FLAGST = .TRUE. GRIDS(IMOD)%GINIT = .TRUE. @@ -1530,46 +1772,72 @@ SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & GRIDS(IMOD)%CLATIS(0)=1. GRIDS(IMOD)%CTHG0S(0)=1. ! -!/REF1 ALLOCATE ( GRIDS(IMOD)%RREF(4), & -!/REF1 GRIDS(IMOD)%REFPARS(10), & -!/REF1 STAT=ISTAT ) -!/REF1 CHECK_ALLOC_STATUS ( ISTAT ) -! -!/REF1 GRIDS(IMOD)%RREF(:)=.FALSE. -!/REF1 GRIDS(IMOD)%REFPARS(:)=0. -! -!/REF1! Memory footprint can be reduced by defining REFLC and REFLD only over nodes -!/REF1! where reflection can occur. -!/REF1 ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & -!/REF1 GRIDS(IMOD)%REFLD(6,0:NSEA), & -!/REF1 STAT=ISTAT ) -!/REF1 CHECK_ALLOC_STATUS ( ISTAT ) -!/IG1 ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) -!/IG1 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC2 ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) -!/IC2 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC3 ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) -!/IC3 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_REF1 + ALLOCATE ( GRIDS(IMOD)%RREF(4), & + GRIDS(IMOD)%REFPARS(10), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_REF1 + GRIDS(IMOD)%RREF(:)=.FALSE. + GRIDS(IMOD)%REFPARS(:)=0. +#endif +! +#ifdef W3_REF1 +! Memory footprint can be reduced by defining REFLC and REFLD only over nodes +! where reflection can occur. + ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & + GRIDS(IMOD)%REFLD(6,0:NSEA), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +#ifdef W3_IG1 + ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +#ifdef W3_IC2 + ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +#ifdef W3_IC3 + ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif -!/IC4 ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) -!/IC4 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC4 ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) -!/IC4 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC4 ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) -!/IC4 CHECK_ALLOC_STATUS ( ISTAT ) -!/IC5 ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) -!/IC5 CHECK_ALLOC_STATUS ( ISTAT ) -!/IS2 ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) -!/IS2 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_IC4 + ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +#ifdef W3_IC5 + ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +#ifdef W3_IS2 + ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) WRITE (NDST,9001) #endif ! -!/REF1 GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. -!/REF1 GRIDS(IMOD)%REFLD(:,:)=0 -!/IG1 GRIDS(IMOD)%IGPARS(:)=0. -!/IC2 GRIDS(IMOD)%IC2PARS(:)=0. -!/IS2 GRIDS(IMOD)%IS2PARS(:)=0. +#ifdef W3_REF1 + GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. + GRIDS(IMOD)%REFLD(:,:)=0 +#endif +#ifdef W3_IG1 + GRIDS(IMOD)%IGPARS(:)=0. +#endif +#ifdef W3_IC2 + GRIDS(IMOD)%IC2PARS(:)=0. +#endif +#ifdef W3_IS2 + GRIDS(IMOD)%IS2PARS(:)=0. +#endif ! ! -------------------------------------------------------------------- / ! 2. Update counters in grid @@ -1683,8 +1951,12 @@ SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/ST4 USE CONSTANTS, ONLY: RADE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_ST4 + USE CONSTANTS, ONLY: RADE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -1698,10 +1970,16 @@ SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) !/ Local parameters !/ INTEGER, SAVE :: MK2, MSPEC -!/ST4 INTEGER :: SDSNTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_ST4 + INTEGER :: SDSNTH +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DIMS') +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMS') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1765,17 +2043,19 @@ SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) SGRDS(IMOD)%DSII(:)=0. SGRDS(IMOD)%DDEN(:)=0. SGRDS(IMOD)%DDEN2(:)=0. -!/ST4 ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & -!/ST4 MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & -!/ST4 MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & -!/ST4 STAT=ISTAT ) -!/ST4 CHECK_ALLOC_STATUS ( ISTAT ) -!/ST4 SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) -!/ST4 ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & -!/ST4 MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & -!/ST4 MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & -!/ST4 STAT=ISTAT ) -!/ST4 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_ST4 + ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & + MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & + MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) + ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! SGRDS(IMOD)%SINIT = .TRUE. #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) @@ -1908,7 +2188,9 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -1921,9 +2203,13 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3SETG') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETG') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1962,36 +2248,56 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) TRFLAG => GRIDS(IMOD)%TRFLAG FLAGLL => GRIDS(IMOD)%FLAGLL ! -!/SMC NCel => GRIDS(IMOD)%NCel -!/SMC NUFc => GRIDS(IMOD)%NUFc -!/SMC NVFc => GRIDS(IMOD)%NVFc -!/SMC NRLv => GRIDS(IMOD)%NRLv -!/SMC MRFct => GRIDS(IMOD)%MRFct +#ifdef W3_SMC + NCel => GRIDS(IMOD)%NCel + NUFc => GRIDS(IMOD)%NUFc + NVFc => GRIDS(IMOD)%NVFc + NRLv => GRIDS(IMOD)%NRLv + MRFct => GRIDS(IMOD)%MRFct +#endif ! -!/SMC NGLO => GRIDS(IMOD)%NGLO -!/SMC NARC => GRIDS(IMOD)%NARC -!/SMC NBGL => GRIDS(IMOD)%NBGL -!/SMC NBAC => GRIDS(IMOD)%NBAC -!/SMC NBSMC => GRIDS(IMOD)%NBSMC +#ifdef W3_SMC + NGLO => GRIDS(IMOD)%NGLO + NARC => GRIDS(IMOD)%NARC + NBGL => GRIDS(IMOD)%NBGL + NBAC => GRIDS(IMOD)%NBAC + NBSMC => GRIDS(IMOD)%NBSMC +#endif ! E3DF => GRIDS(IMOD)%E3DF P2MSF => GRIDS(IMOD)%P2MSF US3DF => GRIDS(IMOD)%US3DF USSPF => GRIDS(IMOD)%USSPF USSP_WN => GRIDS(IMOD)%USSP_WN -!/REF1 REFLC => GRIDS(IMOD)%REFLC -!/REF1 REFLD => GRIDS(IMOD)%REFLD +#ifdef W3_REF1 + REFLC => GRIDS(IMOD)%REFLC + REFLD => GRIDS(IMOD)%REFLD +#endif FFACBERG => GRIDS(IMOD)%FFACBERG -!/REF1 RREF => GRIDS(IMOD)%RREF -!/REF1 REFPARS=> GRIDS(IMOD)%REFPARS -!/IG1 IGPARS => GRIDS(IMOD)%IGPARS -!/IC2 IC2PARS => GRIDS(IMOD)%IC2PARS -!/IC3 IC3PARS => GRIDS(IMOD)%IC3PARS -!/IC4 IC4PARS => GRIDS(IMOD)%IC4PARS -!/IC4 IC4_KI => GRIDS(IMOD)%IC4_KI -!/IC4 IC4_FC => GRIDS(IMOD)%IC4_FC -!/IC5 IC5PARS => GRIDS(IMOD)%IC5PARS -!/IS2 IS2PARS => GRIDS(IMOD)%IS2PARS +#ifdef W3_REF1 + RREF => GRIDS(IMOD)%RREF + REFPARS=> GRIDS(IMOD)%REFPARS +#endif +#ifdef W3_IG1 + IGPARS => GRIDS(IMOD)%IGPARS +#endif +#ifdef W3_IC2 + IC2PARS => GRIDS(IMOD)%IC2PARS +#endif +#ifdef W3_IC3 + IC3PARS => GRIDS(IMOD)%IC3PARS +#endif +#ifdef W3_IC4 + IC4PARS => GRIDS(IMOD)%IC4PARS + IC4_KI => GRIDS(IMOD)%IC4_KI + IC4_FC => GRIDS(IMOD)%IC4_FC +#endif +#ifdef W3_IC5 + IC5PARS => GRIDS(IMOD)%IC5PARS +#endif +#ifdef W3_IS2 + IS2PARS => GRIDS(IMOD)%IS2PARS +#endif SX => GRIDS(IMOD)%SX SY => GRIDS(IMOD)%SY X0 => GRIDS(IMOD)%X0 @@ -2002,14 +2308,18 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) DTMAX => GRIDS(IMOD)%DTMAX DTMIN => GRIDS(IMOD)%DTMIN DMIN => GRIDS(IMOD)%DMIN -!/SEC1 NITERSEC1 => GRIDS(IMOD)%NITERSEC1 +#ifdef W3_SEC1 + NITERSEC1 => GRIDS(IMOD)%NITERSEC1 +#endif CTMAX => GRIDS(IMOD)%CTMAX FICE0 => GRIDS(IMOD)%FICE0 GRIDSHIFT => GRIDS(IMOD)%GRIDSHIFT CMPRTRCK => GRIDS(IMOD)%CMPRTRCK -!/RTD PoLat => GRIDS(IMOD)%PoLat -!/RTD PoLon => GRIDS(IMOD)%PoLon -!/RTD FLAGUNR => GRIDS(IMOD)%FLAGUNR +#ifdef W3_RTD + PoLat => GRIDS(IMOD)%PoLat + PoLon => GRIDS(IMOD)%PoLon + FLAGUNR => GRIDS(IMOD)%FLAGUNR +#endif FICEN => GRIDS(IMOD)%FICEN FICEL => GRIDS(IMOD)%FICEL IICEHMIN => GRIDS(IMOD)%IICEHMIN @@ -2042,9 +2352,11 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) FILEXT => GRIDS(IMOD)%FILEXT XYB => GRIDS(IMOD)%XYB TRIGP => GRIDS(IMOD)%TRIGP -!/PDLIB NBND_MAP => GRIDS(IMOD)%NBND_MAP -!/PDLIB INDEX_MAP => GRIDS(IMOD)%INDEX_MAP -!/PDLIB MAPSTA_LOC => GRIDS(IMOD)%MAPSTA_LOC +#ifdef W3_PDLIB + NBND_MAP => GRIDS(IMOD)%NBND_MAP + INDEX_MAP => GRIDS(IMOD)%INDEX_MAP + MAPSTA_LOC => GRIDS(IMOD)%MAPSTA_LOC +#endif NTRI => GRIDS(IMOD)%NTRI COUNTRI => GRIDS(IMOD)%COUNTRI SI => GRIDS(IMOD)%SI @@ -2071,8 +2383,10 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) IOBPD => GRIDS(IMOD)%IOBPD IOBDP => GRIDS(IMOD)%IOBDP IOBPA => GRIDS(IMOD)%IOBPA -!/PDLIB IOBP_loc => GRIDS(IMOD)%IOBP_loc -!/PDLIB IOBPD_loc => GRIDS(IMOD)%IOBPD_loc +#ifdef W3_PDLIB + IOBP_loc => GRIDS(IMOD)%IOBP_loc + IOBPD_loc => GRIDS(IMOD)%IOBPD_loc +#endif TRIA => GRIDS(IMOD)%TRIA CROSSDIFF => GRIDS(IMOD)%CROSSDIFF MAXX => GRIDS(IMOD)%MAXX @@ -2088,7 +2402,9 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) MAPSF => GRIDS(IMOD)%MAPSF FLAGST => GRIDS(IMOD)%FLAGST ! -!/RTD AnglD => GRIDS(IMOD)%AnglD +#ifdef W3_RTD + AnglD => GRIDS(IMOD)%AnglD +#endif ZB => GRIDS(IMOD)%ZB CLATS => GRIDS(IMOD)%CLATS CLATIS => GRIDS(IMOD)%CLATIS @@ -2110,23 +2426,29 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) HPFAC => GRIDS(IMOD)%HPFAC HQFAC => GRIDS(IMOD)%HQFAC ! -!/BT4 SED_D50 => GRIDS(IMOD)%SED_D50 -!/BT4 SED_PSIC => GRIDS(IMOD)%SED_PSIC +#ifdef W3_BT4 + SED_D50 => GRIDS(IMOD)%SED_D50 + SED_PSIC => GRIDS(IMOD)%SED_PSIC +#endif ! -!/SMC NLvCel => GRIDS(IMOD)%NLvCel -!/SMC NLvUFc => GRIDS(IMOD)%NLvUFc -!/SMC NLvVFc => GRIDS(IMOD)%NLvVFc -!/SMC IJKCel => GRIDS(IMOD)%IJKCel -!/SMC IJKUFc => GRIDS(IMOD)%IJKUFc -!/SMC IJKVFc => GRIDS(IMOD)%IJKVFc -!/SMC ISMCBP => GRIDS(IMOD)%ISMCBP -!/SMC CTRNX => GRIDS(IMOD)%CTRNX -!/SMC CTRNY => GRIDS(IMOD)%CTRNY -!/SMC CLATF => GRIDS(IMOD)%CLATF +#ifdef W3_SMC + NLvCel => GRIDS(IMOD)%NLvCel + NLvUFc => GRIDS(IMOD)%NLvUFc + NLvVFc => GRIDS(IMOD)%NLvVFc + IJKCel => GRIDS(IMOD)%IJKCel + IJKUFc => GRIDS(IMOD)%IJKUFc + IJKVFc => GRIDS(IMOD)%IJKVFc + ISMCBP => GRIDS(IMOD)%ISMCBP + CTRNX => GRIDS(IMOD)%CTRNX + CTRNY => GRIDS(IMOD)%CTRNY + CLATF => GRIDS(IMOD)%CLATF +#endif ! -!/SMC ICLBAC => GRIDS(IMOD)%ICLBAC -!/SMC ANGARC => GRIDS(IMOD)%ANGARC -!/SMC SPCBAC => GRIDS(IMOD)%SPCBAC +#ifdef W3_SMC + ICLBAC => GRIDS(IMOD)%ICLBAC + ANGARC => GRIDS(IMOD)%ANGARC + SPCBAC => GRIDS(IMOD)%SPCBAC +#endif ! GSU => GRIDS(IMOD)%GSU ! @@ -2191,228 +2513,282 @@ SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) XFC => MPARS(IMOD)%NPARS%XFC FACSD => MPARS(IMOD)%NPARS%FACSD FHMAX => MPARS(IMOD)%NPARS%FHMAX -!/RWND RWINDC => MPARS(IMOD)%NPARS%RWINDC -!/WCOR WWCOR => MPARS(IMOD)%NPARS%WWCOR +#ifdef W3_RWND + RWINDC => MPARS(IMOD)%NPARS%RWINDC +#endif +#ifdef W3_WCOR + WWCOR => MPARS(IMOD)%NPARS%WWCOR +#endif ! ! Structure PROPS ! -!/PR2 DTME => MPARS(IMOD)%PROPS%DTME -!/PR2 CLATMN => MPARS(IMOD)%PROPS%CLATMN -!/PR3 WDCG => MPARS(IMOD)%PROPS%WDCG -!/PR3 WDTH => MPARS(IMOD)%PROPS%WDTH -!/SMC DTMS => MPARS(IMOD)%PROPS%DTMS -!/SMC Refran => MPARS(IMOD)%PROPS%Refran -!/SMC FUNO3 => MPARS(IMOD)%PROPS%FUNO3 -!/SMC FVERG => MPARS(IMOD)%PROPS%FVERG -!/SMC FSWND => MPARS(IMOD)%PROPS%FSWND -!/SMC ARCTC => MPARS(IMOD)%PROPS%ARCTC +#ifdef W3_PR2 + DTME => MPARS(IMOD)%PROPS%DTME + CLATMN => MPARS(IMOD)%PROPS%CLATMN +#endif +#ifdef W3_PR3 + WDCG => MPARS(IMOD)%PROPS%WDCG + WDTH => MPARS(IMOD)%PROPS%WDTH +#endif +#ifdef W3_SMC + DTMS => MPARS(IMOD)%PROPS%DTMS + Refran => MPARS(IMOD)%PROPS%Refran + FUNO3 => MPARS(IMOD)%PROPS%FUNO3 + FVERG => MPARS(IMOD)%PROPS%FVERG + FSWND => MPARS(IMOD)%PROPS%FSWND + ARCTC => MPARS(IMOD)%PROPS%ARCTC +#endif ! ! Structure FLDP ! -!/FLD1 TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID -!/FLD1 TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV -!/FLD1 TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 -!/FLD1 TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 -!/FLD2 TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID -!/FLD2 TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV -!/FLD2 TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 -!/FLD2 TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 +#ifdef W3_FLD1 + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 +#endif +#ifdef W3_FLD2 + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 +#endif ! ! Structure SFLPS ! -!/FLX2 NITTIN => MPARS(IMOD)%SFLPS%NITTIN -!/FLX2 CINXSI => MPARS(IMOD)%SFLPS%CINXSI -!/FLX3 NITTIN => MPARS(IMOD)%SFLPS%NITTIN -!/FLX3 CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID -!/FLX3 CINXSI => MPARS(IMOD)%SFLPS%CINXSI -!/FLX3 CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX -!/FLX4 FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 +#ifdef W3_FLX2 + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CINXSI => MPARS(IMOD)%SFLPS%CINXSI +#endif +#ifdef W3_FLX3 + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID + CINXSI => MPARS(IMOD)%SFLPS%CINXSI + CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX +#endif +#ifdef W3_FLX4 + FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 +#endif ! ! Structure SLNPS ! -!/LN1 SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 -!/LN1 FSPM => MPARS(IMOD)%SLNPS%FSPM -!/LN1 FSHF => MPARS(IMOD)%SLNPS%FSHF +#ifdef W3_LN1 + SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 + FSPM => MPARS(IMOD)%SLNPS%FSPM + FSHF => MPARS(IMOD)%SLNPS%FSHF +#endif ! ! Structure SRCPS ! WWNMEANPTAIL=> MPARS(IMOD)%SRCPS%WWNMEANPTAIL SSTXFTFTAIL => MPARS(IMOD)%SRCPS%SSTXFTFTAIL -!/ST1 SINC1 => MPARS(IMOD)%SRCPS%SINC1 -!/ST1 SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 -!/ST2 ZWIND => MPARS(IMOD)%SRCPS%ZWIND -!/ST2 FSWELL => MPARS(IMOD)%SRCPS%FSWELL -!/ST2 SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB -!/ST2 OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB -!/ST2 CCNG => MPARS(IMOD)%SRCPS%CCNG -!/ST2 CCPS => MPARS(IMOD)%SRCPS%CCPS -!/ST2 FFNG => MPARS(IMOD)%SRCPS%FFNG -!/ST2 FFPS => MPARS(IMOD)%SRCPS%FFPS -!/ST2 CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 -!/ST2 CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 -!/ST2 CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 -!/ST2 SDSALN => MPARS(IMOD)%SRCPS%SDSALN -!/ST2 CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 -!/ST2 CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 -!/ST2 CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 -!/ST2 CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 -!/ST2 FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN -!/ST2 XFH => MPARS(IMOD)%SRCPS%XFH -!/ST2 XF1 => MPARS(IMOD)%SRCPS%XF1 -!/ST2 XF2 => MPARS(IMOD)%SRCPS%XF2 -! -!/ST3 ZZWND => MPARS(IMOD)%SRCPS%ZZWND -!/ST3 AALPHA => MPARS(IMOD)%SRCPS%AALPHA -!/ST3 BBETA => MPARS(IMOD)%SRCPS%BBETA -!/ST3 SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP -!/ST3 ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX -!/ST3 ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT -!/ST3 ZZALP => MPARS(IMOD)%SRCPS%ZZALP -!/ST3 TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER -!/ST3 SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF -!/ST3 SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 -!/ST3 WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP -!/ST3 FFXFM => MPARS(IMOD)%SRCPS%FFXFM -!/ST3 FFXPM => MPARS(IMOD)%SRCPS%FFXPM -!/ST3 DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 -!/ST3 DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 -!/ST3 SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF -!/ST3 SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN -! -!/ST4 ZZWND => MPARS(IMOD)%SRCPS%ZZWND -!/ST4 AALPHA => MPARS(IMOD)%SRCPS%AALPHA -!/ST4 BBETA => MPARS(IMOD)%SRCPS%BBETA -!/ST4 SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP -!/ST4 ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX -!/ST4 ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT -!/ST4 ZZALP => MPARS(IMOD)%SRCPS%ZZALP -!/ST4 TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER -!/ST4 SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR -!/ST4 SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF -!/ST4 SSDSC => MPARS(IMOD)%SRCPS%SSDSC -!/ST4 SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR -!/ST4 SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT -!/ST4 SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 -!/ST4 SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 -!/ST4 SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF -!/ST4 SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM -!/ST4 SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK -!/ST4 SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK -!/ST4 SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK -!/ST4 SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK -!/ST4 SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT -!/ST4 SSDSP => MPARS(IMOD)%SRCPS%SSDSP -!/ST4 WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP -!/ST4 FFXFM => MPARS(IMOD)%SRCPS%FFXFM -!/ST4 FFXFA => MPARS(IMOD)%SRCPS%FFXFA -!/ST4 FFXPM => MPARS(IMOD)%SRCPS%FFXPM -!/ST4 SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH -!/ST4 SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF -!/ST4 SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN -!/ST4 SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS -!/ST4 SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO -!/ST4 IKTAB => MPARS(IMOD)%SRCPS%IKTAB -!/ST4 DCKI => MPARS(IMOD)%SRCPS%DCKI -!/ST4 QBI => MPARS(IMOD)%SRCPS%QBI -!/ST4 CUMULW => MPARS(IMOD)%SRCPS%CUMULW -!/ST4 SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES -!/ST4 SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS -!/ST4 SSINBR => MPARS(IMOD)%SRCPS%SSINBR -! -!/ST6 SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 -!/ST6 SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS -!/ST6 SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC -!/ST6 SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET -!/ST6 SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 -!/ST6 SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 -!/ST6 SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 -!/ST6 SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 -!/ST6 SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 -!/ST6 SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 -!/ST6 SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 +#ifdef W3_ST1 + SINC1 => MPARS(IMOD)%SRCPS%SINC1 + SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 +#endif +#ifdef W3_ST2 + ZWIND => MPARS(IMOD)%SRCPS%ZWIND + FSWELL => MPARS(IMOD)%SRCPS%FSWELL + SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB + OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB + CCNG => MPARS(IMOD)%SRCPS%CCNG + CCPS => MPARS(IMOD)%SRCPS%CCPS + FFNG => MPARS(IMOD)%SRCPS%FFNG + FFPS => MPARS(IMOD)%SRCPS%FFPS + CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 + CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 + CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 + SDSALN => MPARS(IMOD)%SRCPS%SDSALN + CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 + CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 + CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 + CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 + FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN + XFH => MPARS(IMOD)%SRCPS%XFH + XF1 => MPARS(IMOD)%SRCPS%XF1 + XF2 => MPARS(IMOD)%SRCPS%XF2 +#endif +! +#ifdef W3_ST3 + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 + DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN +#endif +! +#ifdef W3_ST4 + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC => MPARS(IMOD)%SRCPS%SSDSC + SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR + SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT + SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 + SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 + SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF + SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM + SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK + SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK + SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK + SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK + SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT + SSDSP => MPARS(IMOD)%SRCPS%SSDSP + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXFA => MPARS(IMOD)%SRCPS%FFXFA + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN + SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS + SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO + IKTAB => MPARS(IMOD)%SRCPS%IKTAB + DCKI => MPARS(IMOD)%SRCPS%DCKI + QBI => MPARS(IMOD)%SRCPS%QBI + CUMULW => MPARS(IMOD)%SRCPS%CUMULW + SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES + SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS + SSINBR => MPARS(IMOD)%SRCPS%SSINBR +#endif +! +#ifdef W3_ST6 + SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 + SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS + SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC + SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET + SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 + SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 + SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 + SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 + SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 + SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 + SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 +#endif ! ! Structure SRNLS ! -!/NL1 SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 -!/NL1 LAM => MPARS(IMOD)%SNLPS%LAM -!/NL1 KDCON => MPARS(IMOD)%SNLPS%KDCON -!/NL1 KDMN => MPARS(IMOD)%SNLPS%KDMN -!/NL1 SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 -!/NL1 SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 -!/NL1 SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 -!/NL2 IQTPE => MPARS(IMOD)%SNLPS%IQTPE -!/NL2 NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS -!/NL2 NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL -!/NL2 IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL -!/NL3 NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN -!/NL3 NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX -!/NL3 NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT -!/NL3 NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX -!/NL3 NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP -!/NL3 NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN -!/NL3 NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX -!/NL3 NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 -!/NL3 FRQ => MPARS(IMOD)%SNLPS%FRQ -!/NL3 XSI => MPARS(IMOD)%SNLPS%XSI -!/NL3 NQA => MPARS(IMOD)%SNLPS%NQA -!/NL3 QST1 => MPARS(IMOD)%SNLPS%QST1 -!/NL3 QST2 => MPARS(IMOD)%SNLPS%QST2 -!/NL3 QST3 => MPARS(IMOD)%SNLPS%QST3 -!/NL3 QST4 => MPARS(IMOD)%SNLPS%QST4 -!/NL3 QST5 => MPARS(IMOD)%SNLPS%QST5 -!/NL3 QST6 => MPARS(IMOD)%SNLPS%QST6 -!/NL3 SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ -!/NL3 SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC -!/NL3 SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC -!/NL3 SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD -!/NL3 SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS -!/NL3 SNLL => MPARS(IMOD)%SNLPS%SNLL -!/NL3 SNLM => MPARS(IMOD)%SNLPS%SNLM -!/NL3 SNLT => MPARS(IMOD)%SNLPS%SNLT -!/NL3 SNLCD => MPARS(IMOD)%SNLPS%SNLCD -!/NL3 SNLCS => MPARS(IMOD)%SNLPS%SNLCS -!/NL4 ITSA => MPARS(IMOD)%SNLPS%ITSA -!/NL4 IALT => MPARS(IMOD)%SNLPS%IALT -!/NL5 QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT -!/NL5 QR5OML => MPARS(IMOD)%SNLPS%QR5OML -!/NL5 QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS -!/NL5 QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV -!/NL5 QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ -!/NL5 QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL -!/NL5 QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX -!/NLS NTHX => MPARS(IMOD)%SNLPS%NTHX -!/NLS NFRX => MPARS(IMOD)%SNLPS%NFRX -!/NLS NSPL => MPARS(IMOD)%SNLPS%NSPL -!/NLS NSPH => MPARS(IMOD)%SNLPS%NSPH -!/NLS SNSST => MPARS(IMOD)%SNLPS%SNSST -!/NLS CNLSA => MPARS(IMOD)%SNLPS%CNLSA -!/NLS CNLSC => MPARS(IMOD)%SNLPS%CNLSC -!/NLS CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM -!/NLS CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 -!/NLS CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 -!/NLS CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 +#ifdef W3_NL1 + SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 + LAM => MPARS(IMOD)%SNLPS%LAM + KDCON => MPARS(IMOD)%SNLPS%KDCON + KDMN => MPARS(IMOD)%SNLPS%KDMN + SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 + SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 + SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 +#endif +#ifdef W3_NL2 + IQTPE => MPARS(IMOD)%SNLPS%IQTPE + NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS + NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL + IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL +#endif +#ifdef W3_NL3 + NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN + NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX + NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT + NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX + NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP + NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN + NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX + NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 + FRQ => MPARS(IMOD)%SNLPS%FRQ + XSI => MPARS(IMOD)%SNLPS%XSI + NQA => MPARS(IMOD)%SNLPS%NQA + QST1 => MPARS(IMOD)%SNLPS%QST1 + QST2 => MPARS(IMOD)%SNLPS%QST2 + QST3 => MPARS(IMOD)%SNLPS%QST3 + QST4 => MPARS(IMOD)%SNLPS%QST4 + QST5 => MPARS(IMOD)%SNLPS%QST5 + QST6 => MPARS(IMOD)%SNLPS%QST6 + SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ + SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC + SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC + SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD + SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS + SNLL => MPARS(IMOD)%SNLPS%SNLL + SNLM => MPARS(IMOD)%SNLPS%SNLM + SNLT => MPARS(IMOD)%SNLPS%SNLT + SNLCD => MPARS(IMOD)%SNLPS%SNLCD + SNLCS => MPARS(IMOD)%SNLPS%SNLCS +#endif +#ifdef W3_NL4 + ITSA => MPARS(IMOD)%SNLPS%ITSA + IALT => MPARS(IMOD)%SNLPS%IALT +#endif +#ifdef W3_NL5 + QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT + QR5OML => MPARS(IMOD)%SNLPS%QR5OML + QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS + QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV + QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ + QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL + QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX +#endif +#ifdef W3_NLS + NTHX => MPARS(IMOD)%SNLPS%NTHX + NFRX => MPARS(IMOD)%SNLPS%NFRX + NSPL => MPARS(IMOD)%SNLPS%NSPL + NSPH => MPARS(IMOD)%SNLPS%NSPH + SNSST => MPARS(IMOD)%SNLPS%SNSST + CNLSA => MPARS(IMOD)%SNLPS%CNLSA + CNLSC => MPARS(IMOD)%SNLPS%CNLSC + CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM + CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 + CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 + CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 +#endif ! ! Structure SBTPS ! -!/BT1 SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 -!/BT4 SBTCX => MPARS(IMOD)%SBTPS%SBTCX +#ifdef W3_BT1 + SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 +#endif +#ifdef W3_BT4 + SBTCX => MPARS(IMOD)%SBTPS%SBTCX +#endif ! ! Structure SDBPS ! -!/DB1 SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 -!/DB1 SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 -!/DB1 FDONLY => MPARS(IMOD)%SDBPS%FDONLY +#ifdef W3_DB1 + SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 + SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 + FDONLY => MPARS(IMOD)%SDBPS%FDONLY +#endif ! ! -!/UOST UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL -!/UOST UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW -!/UOST UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL -!/UOST UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW +#ifdef W3_UOST + UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL + UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW + UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL + UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW +#endif ! ! Structure SICPS ! -!/IS1 IS1C1 => MPARS(IMOD)%SICPS%IS1C1 -!/IS1 IS1C2 => MPARS(IMOD)%SICPS%IS1C2 +#ifdef W3_IS1 + IS1C1 => MPARS(IMOD)%SICPS%IS1C1 + IS1C2 => MPARS(IMOD)%SICPS%IS1C2 +#endif ! ! Structure SCHM FSBCCFL => MPARS(IMOD)%SCHMS%FSBCCFL @@ -2522,7 +2898,9 @@ SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -2542,9 +2920,13 @@ SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) INTEGER :: PRANGE(2), QRANGE(2) INTEGER :: LBI(2), UBI(2), LBO(2), UBO(2), ISTAT REAL , ALLOCATABLE :: COSA(:,:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3GNTX') +#ifdef W3_S + CALL STRACE (IENT, 'W3GNTX') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -2748,8 +3130,12 @@ SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/MEMCHECK USE MallocInfo_m -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -2758,15 +3144,21 @@ SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) !/ Parameter list !/ INTEGER, INTENT(IN) :: IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST -!/MEMCHECK type(MallInfo_t) :: mallinfos +#ifdef W3_MEMCHECK + type(MallInfo_t) :: mallinfos +#endif INTEGER :: IAPROC = 1 !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DIMUG') +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMUG') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -2789,9 +3181,11 @@ SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) WRITE (NDST,9000) IMOD, MX, MTRI #endif -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_UG_ALLOCATE SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_UG_ALLOCATE SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays @@ -2848,9 +3242,11 @@ SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) WRITE (NDST,9003) #endif -!/MEMCHECK WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_UG_ALLOCATE SECTION 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_UG_ALLOCATE SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif RETURN ! @@ -2928,7 +3324,9 @@ SUBROUTINE W3SETREF ! !/ ------------------------------------------------------------------- / USE CONSTANTS -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif ! IMPLICIT NONE !/ @@ -2937,168 +3335,188 @@ SUBROUTINE W3SETREF INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP INTEGER :: J, K, NEIGH1(0:7) INTEGER :: ILEV, NLEV -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & COSAVG, SINAVG, THAVG, ANGLES(0:7), CLAT !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SETREF') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETREF') +#endif ! ! 1. Preparations --------------------------------------------------- * ! -!/REF1 IF (REFPARS(2).GT.0) RREF(2)=.TRUE. -!/REF1 IF (REFPARS(3).GT.0) RREF(3)=.TRUE. -!/REF1 IF (REFPARS(4).GT.0) RREF(4)=.TRUE. -! -!/REF1 DO IY=2, NY-1 -!/REF1 DO IX=2, NX-1 -!/REF1 IF (REFPARS(1).GT.0) RREF(1)=.TRUE. -!/REF1!No reflection from artificial island on pole. -!/REF1 IF (FLAGLL.AND.(YGRD(IY,IX).GT.85)) RREF(1)=.FALSE. -!/REF1 IF (MAPSTA(IY,IX).GT.0) THEN -!/REF1! -!/REF1! Prepares for reflection from subgrid islands -!/REF1! -!/REF1 IF (RREF(2)) & -!/REF1 REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) -!/REF1! -!/REF1! Prepares for iceberg reflections -!/REF1! -!/REF1 IF (RREF(4)) & -!/REF1 REFLC(4,MAPFS(IY,IX))= 1. -!/REF1! -!/REF1! resolved shoreline reflection -!/REF1! -!/REF1 IF (RREF(1)) THEN -!/REF1 REFLC(1, MAPFS(IY,IX)) = 0. -!/REF1 REFLD(1:6,MAPFS(IY,IX)) = 0 -!/REF1! -!/REF1! Search for neighboring coastline. 3 2 1 -!/REF1! around X. These are the neighbors of X: 4 X 0 -!/REF1! 5 6 7 -!/REF1! -!/REF1! -!/REF1 NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) -!/REF1 NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) -!/REF1 NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) -!/REF1 NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) -!/REF1! -!/REF1! if one of the surrounding points is land: determines directions ... -!/REF1! -!/REF1 IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN -!/REF1 IF ( FLAGLL ) THEN -!/REF1 CLAT = COS(YGRD(IY,IX)*DERA) -!/REF1 ELSE -!/REF1 CLAT = 1. -!/REF1 END IF -!/REF1 ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) -!/REF1 ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) -!/REF1 ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) -!/REF1 ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) -!/REF1 ANGLES(4:7)= ANGLES(0:3)+PI -!/REF1 IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN -!/REF1 REFLD(3,MAPFS(IY,IX))=0 -!/REF1 ELSE -!/REF1 IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 -!/REF1 END IF -!/REF1 IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN -!/REF1 REFLD(4,MAPFS(IY,IX))=0 -!/REF1 ELSE -!/REF1 IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 -!/REF1 END IF -!/REF1! -!/REF1! Looks for a locally straight coast in all 8 orientations -!/REF1! -!/REF1 J=0 -!/REF1 REFLD(1,MAPFS(IY,IX))=0 -!/REF1 COSAVG=0 -!/REF1 SINAVG=0 -!/REF1! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) -!/REF1 REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) -!/REF1 REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) -!/REFT IF (IY.EQ.4) THEN -!/REFT WRITE(6,*) 'POINT (IX,IY):',IX,IY -!/REFT WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) -!/REFT WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) -!/REFT WRITE(6,*) 'REFT:',NEIGH1(5:7) -!/REFT WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE -!/REFT WRITE(6,*) 'ANG:',ANGLES(4)*RADE,1, ANGLES(0) *RADE -!/REFT WRITE(6,*) 'ANG:',ANGLES(5:7)*RADE -!/REFT WRITE(6,*) 'REFT:',XGRD(IY+1,IX-1:IX+1), YGRD(IY+1,IX-1:IX+1) -!/REFT WRITE(6,*) 'REFT:',XGRD(IY,IX-1:IX+1) , YGRD(IY,IX-1:IX+1) -!/REFT WRITE(6,*) 'REFT:',XGRD(IY-1,IX-1:IX+1), YGRD(IY-1,IX-1:IX+1) -!/REFT WRITE(6,*) 'REFLD:',REFLD(3:6,MAPFS(IY,IX)) -!/REFT ENDIF -!/REF1 DO K=0,7 -!/REF1 IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & -!/REF1 .AND.NEIGH1(MOD(K+1,8)).EQ.0 & -!/REF1 .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN -!/REF1 REFLC(1,MAPFS(IY,IX))= REFPARS(1) -!/REF1! -!/REF1! Defines direction index for specular reflection (normal to coast) -!/REF1! -!/REF1! for example, if we have this layout 1 1 0 -!/REF1! (NB: 1 is sea, 0 is land) 1 X 0 -!/REF1! 1 1 0 -!/REF1! -!/REF1! then there is only a coastline detection for K=0, giving J=1 -!/REF1! and the final result will be REFLD(1,MAPFS(IY,IX))=1 -!/REF1! Namely, the direction TH(REFLD) is the direction pointing INTO the coast -!/REF1! -!/REF1 REFLD(2,MAPFS(IY,IX))= 2 -!/REF1 COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) -!/REF1 SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) -!/REF1 J=J+1 -!/REF1 ENDIF -!/REF1 END DO -!/REF1 IF (J.GT.0) THEN -!/REF1 IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 -!/REF1 THAVG=ATAN2(SINAVG,COSAVG) +#ifdef W3_REF1 + IF (REFPARS(2).GT.0) RREF(2)=.TRUE. + IF (REFPARS(3).GT.0) RREF(3)=.TRUE. + IF (REFPARS(4).GT.0) RREF(4)=.TRUE. +#endif +! +#ifdef W3_REF1 + DO IY=2, NY-1 + DO IX=2, NX-1 + IF (REFPARS(1).GT.0) RREF(1)=.TRUE. +!No reflection from artificial island on pole. + IF (FLAGLL.AND.(YGRD(IY,IX).GT.85)) RREF(1)=.FALSE. + IF (MAPSTA(IY,IX).GT.0) THEN +! +! Prepares for reflection from subgrid islands +! + IF (RREF(2)) & + REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) +! +! Prepares for iceberg reflections +! + IF (RREF(4)) & + REFLC(4,MAPFS(IY,IX))= 1. +! +! resolved shoreline reflection +! + IF (RREF(1)) THEN + REFLC(1, MAPFS(IY,IX)) = 0. + REFLD(1:6,MAPFS(IY,IX)) = 0 +! +! Search for neighboring coastline. 3 2 1 +! around X. These are the neighbors of X: 4 X 0 +! 5 6 7 +! +! + NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) + NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) + NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) + NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) +! +! if one of the surrounding points is land: determines directions ... +! + IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN + IF ( FLAGLL ) THEN + CLAT = COS(YGRD(IY,IX)*DERA) + ELSE + CLAT = 1. + END IF + ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) + ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) + ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) + ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) + ANGLES(4:7)= ANGLES(0:3)+PI + IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN + REFLD(3,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 + END IF + IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN + REFLD(4,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 + END IF +! +! Looks for a locally straight coast in all 8 orientations +! + J=0 + REFLD(1,MAPFS(IY,IX))=0 + COSAVG=0 + SINAVG=0 +! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) + REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) + REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) +#endif +#ifdef W3_REFT + IF (IY.EQ.4) THEN + WRITE(6,*) 'POINT (IX,IY):',IX,IY + WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) + WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) + WRITE(6,*) 'REFT:',NEIGH1(5:7) + WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE + WRITE(6,*) 'ANG:',ANGLES(4)*RADE,1, ANGLES(0) *RADE + WRITE(6,*) 'ANG:',ANGLES(5:7)*RADE + WRITE(6,*) 'REFT:',XGRD(IY+1,IX-1:IX+1), YGRD(IY+1,IX-1:IX+1) + WRITE(6,*) 'REFT:',XGRD(IY,IX-1:IX+1) , YGRD(IY,IX-1:IX+1) + WRITE(6,*) 'REFT:',XGRD(IY-1,IX-1:IX+1), YGRD(IY-1,IX-1:IX+1) + WRITE(6,*) 'REFLD:',REFLD(3:6,MAPFS(IY,IX)) + ENDIF +#endif +#ifdef W3_REF1 + DO K=0,7 + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & + .AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) +! +! Defines direction index for specular reflection (normal to coast) +! +! for example, if we have this layout 1 1 0 +! (NB: 1 is sea, 0 is land) 1 X 0 +! 1 1 0 +! +! then there is only a coastline detection for K=0, giving J=1 +! and the final result will be REFLD(1,MAPFS(IY,IX))=1 +! Namely, the direction TH(REFLD) is the direction pointing INTO the coast +! + REFLD(2,MAPFS(IY,IX))= 2 + COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) + SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) + J=J+1 + ENDIF + END DO + IF (J.GT.0) THEN + IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 + THAVG=ATAN2(SINAVG,COSAVG) +#endif #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETREF) -!/REF1 !WRITE (6,*) 'COASTAL REFLECTION:',IX,IY, & -!/REF1 !SINAVG,COSAVG,THAVG/TPI,NINT(THAVG/TPI*NTH),MOD(NTH+NINT(THAVG/TPI*NTH),NTH) -#endif -!/REF1 REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) -!/REF1 ELSE -!/REF1 -!/REF1! 1 1 1 -!/REF1! Looks for mild corners like 1 1 1 -!/REF1! 1 0 0 -!/REF1 DO K=0,7 -!/REF1 IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & -!/REF1 .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN -!/REF1 REFLC(1,MAPFS(IY,IX))= REFPARS(1) -!/REF1 REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) -!/REF1 REFLD(2,MAPFS(IY,IX))= 1 -!/REF1 ENDIF -!/REF1 END DO -!/REF1! 1 1 1 1 1 1 -!/REF1! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 -!/REF1! 1 0 1 1 1 0 -!/REF1 IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN -!/REF1 DO K=0,7,2 -!/REF1 IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN -!/REF1 REFLC(1,MAPFS(IY,IX))= REFPARS(1) -!/REF1 REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 -!/REF1 REFLD(2,MAPFS(IY,IX))= 0 -!/REF1 !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) -!/REF1 END IF -!/REF1 END DO -!/REF1 END IF -!/REF1 END IF -!/REF1! End of test if surrounding point is land -!/REF1 END IF -!/REFT IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN -!/REFT WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & -!/REFT REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI -!/REFT ENDIF -!/REF1! End of test if local point is sea -!/REF1 END IF -!/REF1 END IF -!/REF1 END DO -!/REF1 END DO +#ifdef W3_REF1 + !WRITE (6,*) 'COASTAL REFLECTION:',IX,IY, & + !SINAVG,COSAVG,THAVG/TPI,NINT(THAVG/TPI*NTH),MOD(NTH+NINT(THAVG/TPI*NTH),NTH) +#endif +#endif +#ifdef W3_REF1 + REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) + ELSE + +! 1 1 1 +! Looks for mild corners like 1 1 1 +! 1 0 0 + DO K=0,7 + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) + REFLD(2,MAPFS(IY,IX))= 1 + ENDIF + END DO +! 1 1 1 1 1 1 +! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 +! 1 0 1 1 1 0 + IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN + DO K=0,7,2 + IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 + REFLD(2,MAPFS(IY,IX))= 0 + !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) + END IF + END DO + END IF + END IF +! End of test if surrounding point is land + END IF +#endif +#ifdef W3_REFT + IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN + WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & + REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI + ENDIF +#endif +#ifdef W3_REF1 +! End of test if local point is sea + END IF + END IF + END DO + END DO +#endif ! RETURN ! diff --git a/model/ftn/w3getmem.c b/model/src/w3getmem.c similarity index 100% rename from model/ftn/w3getmem.c rename to model/src/w3getmem.c diff --git a/model/ftn/w3gig1md.ftn b/model/src/w3gig1md.F90 similarity index 99% rename from model/ftn/w3gig1md.ftn rename to model/src/w3gig1md.F90 index 3327621e0..f85738d9e 100644 --- a/model/ftn/w3gig1md.ftn +++ b/model/src/w3gig1md.F90 @@ -211,7 +211,9 @@ SUBROUTINE W3ADDIG(E,DEPTH,WN,CG,IACTION) ECOS, ESIN, EC2, MAPTH, MAPWN, & DSIP, IOBPD, GTYPE, UNGTYPE, IGPARS -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ ! IMPLICIT NONE diff --git a/model/ftn/w3gkemd.ftn b/model/src/w3gkemd.F90 old mode 100755 new mode 100644 similarity index 96% rename from model/ftn/w3gkemd.ftn rename to model/src/w3gkemd.F90 index 02928765b..cf65a09fd --- a/model/ftn/w3gkemd.ftn +++ b/model/src/w3gkemd.F90 @@ -720,7 +720,9 @@ subroutine FindQuartetNumber(ns, kx, ky, om, oml, nnz) end if end do end do -!/TS write(*, *) '→ nnz = ', nnz +#ifdef W3_TS + write(*, *) '→ nnz = ', nnz +#endif end do !/ end subroutine FindQuartetNumber @@ -1162,7 +1164,9 @@ subroutine PrepKGrid(nk, nth, dpt, sig, th) call WAVNU1(sig(ik), dpt, k, cg) end if qr_wn1(ik) = k ! Store k in qr_wn1 ('ll used for interp.) -!/TS write(*, *) 'σ, k, cg: ', sig(ik), k, cg +#ifdef W3_TS + write(*, *) 'σ, k, cg: ', sig(ik), k, cg +#endif ! Calc Δσ if (ik .eq. 1) then dsii = 0.5 * (sig(2) - sig(1)) ! first bin @@ -1181,10 +1185,12 @@ subroutine PrepKGrid(nk, nth, dpt, sig, th) qr_om(jkth) = sig(ik) end do end do -!/TS write(*, *) 'qr_kx: ', qr_kx -!/TS write(*, *) 'qr_ky: ', qr_ky -!/TS write(*, *) 'qr_dk: ', qr_dk -!/TS write(*, *) 'qr_om: ', qr_om +#ifdef W3_TS + write(*, *) 'qr_kx: ', qr_kx + write(*, *) 'qr_ky: ', qr_ky + write(*, *) 'qr_dk: ', qr_dk + write(*, *) 'qr_om: ', qr_om +#endif ! return !/ @@ -1379,24 +1385,26 @@ subroutine PrepKernelIO(nk, nth, sig, th, act) write(51) qr_bdry close(51) ! Screen Test -!/TS write(*, *) "[W] qr_depth: ", qr_depth -!/TS write(*, *) "[W] qr_oml : ", qr_oml -!/TS write(*, *) "[W] qi_disc : ", qi_disc -!/TS write(*, *) "[W] qi_kev : ", qi_kev -!/TS write(*, *) "[W] qr_om : ", qr_om -!/TS write(*, *) "[W] qr_dk : ", qr_dk -!/TS write(*, *) "[W] The total number of quartets is ", qi_nnz -!/TS write(*, *) '[W] qi_NN : ', qi_NN -!/TS write(*, *) '[W] qi_PP : ', qi_PP -!/TS write(*, *) '[W] qi_QQ : ', qi_QQ -!/TS write(*, *) '[W] qi_RR : ', qi_RR -!/TS write(*, *) '[W] qr_TKern: ', qr_TKern -!/TS write(*, *) '[W] qr_TKurt: ', qr_TKurt -!/TS write(*, *) '[W] qr_dom : ', qr_dom -!/TS write(*, *) '[W] qi_icCos: ', qi_icCos -!/TS write(*, *) '[W] qi_irCsr: ', qi_irCsr -!/TS write(*, *) '[W] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) -!/TS write(*, *) '[W] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) +#ifdef W3_TS + write(*, *) "[W] qr_depth: ", qr_depth + write(*, *) "[W] qr_oml : ", qr_oml + write(*, *) "[W] qi_disc : ", qi_disc + write(*, *) "[W] qi_kev : ", qi_kev + write(*, *) "[W] qr_om : ", qr_om + write(*, *) "[W] qr_dk : ", qr_dk + write(*, *) "[W] The total number of quartets is ", qi_nnz + write(*, *) '[W] qi_NN : ', qi_NN + write(*, *) '[W] qi_PP : ', qi_PP + write(*, *) '[W] qi_QQ : ', qi_QQ + write(*, *) '[W] qi_RR : ', qi_RR + write(*, *) '[W] qr_TKern: ', qr_TKern + write(*, *) '[W] qr_TKurt: ', qr_TKurt + write(*, *) '[W] qr_dom : ', qr_dom + write(*, *) '[W] qi_icCos: ', qi_icCos + write(*, *) '[W] qi_irCsr: ', qi_irCsr + write(*, *) '[W] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) + write(*, *) '[W] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) +#endif ! else if (trim(act) == 'READ') then write(*, *) '⊚ → [R] Reading |', trim(qs_cfg), '| ...' @@ -1444,24 +1452,26 @@ subroutine PrepKernelIO(nk, nth, sig, th, act) ! close(51) ! Screen Test -!/TS write(*, *) "[R] qr_depth: ", qr_depth -!/TS write(*, *) "[R] qr_oml : ", qr_oml -!/TS write(*, *) "[R] qi_disc : ", qi_disc -!/TS write(*, *) "[R] qi_kev : ", qi_kev -!/TS write(*, *) "[R] qr_om : ", qr_om -!/TS write(*, *) "[R] qr_dk : ", qr_dk -!/TS write(*, *) "[R] The total number of quartets is ", qi_nnz -!/TS write(*, *) '[R] qi_NN : ', qi_NN -!/TS write(*, *) '[R] qi_PP : ', qi_PP -!/TS write(*, *) '[R] qi_QQ : ', qi_QQ -!/TS write(*, *) '[R] qi_RR : ', qi_RR -!/TS write(*, *) '[R] qr_TKern: ', qr_TKern -!/TS write(*, *) '[R] qr_TKurt: ', qr_TKurt -!/TS write(*, *) '[R] qr_dom : ', qr_dom -!/TS write(*, *) '[R] qi_icCos: ', qi_icCos -!/TS write(*, *) '[R] qi_irCsr: ', qi_irCsr -!/TS write(*, *) '[R] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) -!/TS write(*, *) '[R] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) +#ifdef W3_TS + write(*, *) "[R] qr_depth: ", qr_depth + write(*, *) "[R] qr_oml : ", qr_oml + write(*, *) "[R] qi_disc : ", qi_disc + write(*, *) "[R] qi_kev : ", qi_kev + write(*, *) "[R] qr_om : ", qr_om + write(*, *) "[R] qr_dk : ", qr_dk + write(*, *) "[R] The total number of quartets is ", qi_nnz + write(*, *) '[R] qi_NN : ', qi_NN + write(*, *) '[R] qi_PP : ', qi_PP + write(*, *) '[R] qi_QQ : ', qi_QQ + write(*, *) '[R] qi_RR : ', qi_RR + write(*, *) '[R] qr_TKern: ', qr_TKern + write(*, *) '[R] qr_TKurt: ', qr_TKurt + write(*, *) '[R] qr_dom : ', qr_dom + write(*, *) '[R] qi_icCos: ', qi_icCos + write(*, *) '[R] qi_irCsr: ', qi_irCsr + write(*, *) '[R] Σ_QR : ', qr_sumQR(1: qi_nrsm: ns+1) + write(*, *) '[R] Σ_P : ', (qr_sumNP(iq, iq), iq = 1, ns) +#endif end if !/ end subroutine PrepKernelIO @@ -1721,15 +1731,17 @@ subroutine CalcQRSNL(nk, nth, sig, th, & end if ! ! Screen output (check whether the kernel data are stored in memory) -!/TS write(*, *) "◆ qr_depth :", qr_depth -!/TS write(*, *) "◆ qr_oml :", qr_oml -!/TS write(*, *) "◆ qi_disc :", qi_disc -!/TS write(*, *) "◆ qi_kev :", qi_kev -!/TS write(*, *) "◆ qi_nnz :", qi_nnz -!/TS write(*, *) "◆ qi_NN(:10) :", qi_NN(:10) -!/TS write(*, *) "◆ qr_TKern(:10) :", qr_TKern(:10) -!/TS write(*, *) "◆ qr_TKurt(:10) :", qr_TKurt(:10) -!/TS write(*, *) "◆ qr_sumQR(:10) :", qr_sumQR(:10) +#ifdef W3_TS + write(*, *) "◆ qr_depth :", qr_depth + write(*, *) "◆ qr_oml :", qr_oml + write(*, *) "◆ qi_disc :", qi_disc + write(*, *) "◆ qi_kev :", qi_kev + write(*, *) "◆ qi_nnz :", qi_nnz + write(*, *) "◆ qi_NN(:10) :", qi_NN(:10) + write(*, *) "◆ qr_TKern(:10) :", qr_TKern(:10) + write(*, *) "◆ qr_TKurt(:10) :", qr_TKurt(:10) + write(*, *) "◆ qr_sumQR(:10) :", qr_sumQR(:10) +#endif ! num_I = size(Inpqr0) if (num_I .ne. qi_nnz) then @@ -1862,7 +1874,9 @@ subroutine CalcQRSNL(nk, nth, sig, th, & Mnp2D = reshape(Mnp1D, (/ns, ns/)) Snl = sum((Mnp2D + transpose(Mnp2D)) * qr_sumNP, 2) / qr_dk ! ◆ Conservation Check -!/TS write(*, '(A, E15.3)') ' ← {WW3 GKE } ΣSnl(k) * dk: ', sum(Snl * qr_dk) +#ifdef W3_TS + write(*, '(A, E15.3)') ' ← {WW3 GKE } ΣSnl(k) * dk: ', sum(Snl * qr_dk) +#endif ! ! ◆ Dnl [Diagonal term] ! i) it is easy to calculate Dnl for Janssen's KE (but we may diff --git a/model/src/w3gridmd.F90 b/model/src/w3gridmd.F90 new file mode 100644 index 000000000..5ac13f1a2 --- /dev/null +++ b/model/src/w3gridmd.F90 @@ -0,0 +1,7584 @@ +#include "w3macros.h" +!/ ------------------------------------------------------------------- / + MODULE W3GRIDMD +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | J. H. Alves | +!/ | F. Ardhuin | +!/ | FORTRAN 90 | +!/ | Last update : 27-May-2021 | +!/ +-----------------------------------+ +!/ +!/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) +!/ 27-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Add UNFORMATTED bath file option. +!/ Read options with namelists. +!/ 14-Feb-2000 : Adding exact Snl ( version 2.01 ) +!/ 04-May-2000 : Non central source term int. ( version 2.03 ) +!/ 24-Jan-2001 : Flat grid option. ( version 2.06 ) +!/ 02-Feb-2001 : Xnl version 3.0 ( version 2.07 ) +!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) +!/ 27-Feb-2001 : O0 output switch added. ( version 2.08 ) +!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) +!/ 29-Mar-2001 : Sub-grid island treatment. ( version 2.10 ) +!/ 20-Jul-2001 : Clean up. ( version 2.11 ) +!/ 12-Sep-2001 : Clean up. ( version 2.13 ) +!/ 09-Nov-2001 : Clean up. ( version 2.14 ) +!/ 11-Jan-2002 : Sub-grid ice treatment. ( version 2.15 ) +!/ 17-Jan-2002 : DSII bug fix. ( version 2.16 ) +!/ 09-May-2002 : Switch clean up. ( version 2.21 ) +!/ 26-Nov-2002 : Adding first version of NL-3/4. ( version 3.01 ) +!/ Removed before distribution in 3.12. +!/ 26-Dec-2002 : Relaxing CFL time step. ( version 3.02 ) +!/ 01-Aug-2003 : Modify GSE correction for moving gr.( version 3.03 ) +!/ Add offset option for first direction. +!/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ 04-May-2005 : Allow active points at edge. ( version 3.07 ) +!/ 07-Jul-2005 : Add MAPST2 and map processing. ( version 3.07 ) +!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) +!/ 23-Jun-2006 : Adding alternative source terms. ( version 3.09 ) +!/ Module W3SLN1MD, dummy for others. +!/ 28-Jun-2006 : Adding file name preamble. ( version 3.09 ) +!/ 28-Oct-2006 : Spectral partitioning. ( version 3.09 ) +!/ 09-Jan-2007 : Correct edges of read mask. ( version 3.10 ) +!/ 26-Mar-2007 : Add to spectral partitioning. ( version 3.11 ) +!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) +!/ ( J. H. Alves ) +!/ 25-Apr-2007 : Battjes-Janssen Sdb added. ( version 3.11 ) +!/ ( J. H. Alves ) +!/ 18-Sep-2007 : Adding WAM4 physics option. ( version 3.13 ) +!/ ( F. Ardhuin ) +!/ 09-Oct-2007 : Adding bottom scattering SBS1. ( version 3.13 ) +!/ ( F. Ardhuin ) +!/ 22-Feb-2008 : Initialize TRNX-Y properly. ( version 3.13 ) +!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) +!/ 23-Jul-2009 : Modification of ST3 namelist . ( version 3.14-SHOM ) +!/ 31-Mar-2010 : Addition of shoreline reflection ( version 3.14-IFREMER ) +!/ 29-Jun-2010 : Adding Stokes drift profile output ( version 3.14-IFREMER ) +!/ 30-Aug-2010 : Adding ST4 option ( version 3.14-IFREMER ) + +!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 29-Oct-2010 : Clean up of unstructured grids ( version 3.14.4 ) +!/ (A. Roland and F. Ardhuin) +!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to +!/ specify index closure for a grid. Change GLOBAL +!/ input in ww3_grid.inp to CSTRG. ( version 3.14 ) +!/ (T. J. Campbell, NRL) +!/ 25-Jun-2011 : Adding movable bed friction ( version 4.01 ) +!/ 16-Sep-2011 : Clean up. ( version 4.05 ) +!/ 01-Dec-2011 : New namelist for reflection ( version 4.05 ) +!/ 01-Mar-2012 : Bug correction for NLPROP in ST2 ( version 4.05 ) +!/ 12-Jun-2012 : Add /RTD rotated grid option. JGLi ( version 4.06 ) +!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear +!/ filter (SNLS) from 3.15 (HLT). ( version 4.07 ) +!/ 02-Sep-2012 : Clean up of reflection and UG grids ( version 4.08 ) +!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) +!/ 19-Dec-2012 : Add NOSWLL as namelist variable. ( version 4.OF ) +!/ 05-Mar-2013 : Adjusted default roughness for rocks( version 4.09 ) +!/ 01-Jun-2013 : Adding namelist for spectral output ( version 4.10 ) +!/ 12-Sep-2013 : Adding Arctic part for SMC grid. ( version 4.11 ) +!/ 01-Nov-2013 : Changed UG list name to UNST ( version 4.12 ) +!/ 11-Nov-2013 : Make SMC and RTD option compatible. ( version 4.13 ) +!/ 13-Nov-2013 : Moved out reflection to W3UPDTMD ( version 4.12 ) +!/ 27-Jul-2013 : Adding free infragravity waves ( version 4.15 ) +!/ 02-Dec-2013 : Update of ST4 ( version 4.16 ) +!/ 16-Feb-2014 : Adds wind bias correction: WCOR ( version 5.00 ) +!/ 10-Mar-2014 : Adding namelist for IC2 ( version 5.01 ) +!/ 29-May-2014 : Adding namelist for IC3 ( version 5.01 ) +!/ 15 Oct-2015 : Change SMC grid input files. JGLi ( version 5.09 ) +!/ 10-Jan-2017 : Changes for US3D and USSP ( version 6.01 ) +!/ 20-Jan-2017 : Bug fix for mask input from file. ( version 6.02 ) +!/ 01-Mar-2018 : RTD poles info read from namelist ( version 6.02 ) +!/ 14-Mar-2018 : Option to read UNST boundary file ( version 6.02 ) +!/ 26-Mar-2018 : Sea-point only Wnd/Cur input. JGLi ( version 6.02 ) +!/ 15-May-2018 : Dry sea points over zlim ( version 6.04 ) +!/ 06-Jun-2018 : add Implicit grid parameters for unstructured grids +!/ add DEBUGGRID/DEBUGSTP ( version 6.04 ) +!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) +!/ 20-Jun-2018 : Update of ST6 (Q. Liu) ( version 6.06 ) +!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) +!/ 27-Aug-2018 : Add WBT parameter ( version 6.06 ) +!/ 22-Jan-2020 : Update default values for IS2 ( version 7.05 ) +!/ 20-Feb-2020 : Include Romero's dissipation in ST4 ( version 7.06 ) +!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) +!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) +!/ 24-Jun-2020 : RTD output b. c. to rotated grid. ( version 7.11 ) +!/ 05-Jan-2021 : Update SMC grid for multi-grid. JGLi( version 7.13 ) +!/ 27-May-2021 : Updates for IC5 (Q. Liu) ( version 7.12 ) +!/ 27-May-2021 : Moved to a subroutine ( version 7.13 ) +!/ 07-Jun-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.13 ) +!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) +!/ +!/ Copyright 2009-2013 National Weather Service (NWS), +!/ National Oceanic and Atmospheric Administration. All rights +!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ No unauthorized use without permission. +!/ +! 1. Purpose : +! +! "Grid" preprocessing subroutine, which writes a model definition +! file containing the model parameter settigs and grid data. +! +! 2. Method : +! +! Information is read from the file ww3_grid.inp (NDSI), or +! preset in this subroutine. A model definition file mod_def.ww3 is +! then produced by W3IOGR. Note that the name of the model +! definition file is set in W3IOGR. +! +! 3. Parameters : +! +! Local parameters. +! ---------------------------------------------------------------- +! NDSI Int. Input unit number ("ww3_grid.inp"). +! NDSS Int. Scratch file. +! NDSG Int. Grid unit ( may be NDSI ) +! NDSTR Int. Sub-grid unit ( may be NDSI or NDSG ) +! VSC Real Scale factor. +! VOF Real Add offset. +! ZLIM Real Limiting bottom depth, used to define land. +! IDLA Int. Layout indicator used by INA2R. +! IDFM Int. Id. FORMAT indicator. +! RFORM C*16 Id. FORMAT. +! FNAME C*60 File name with bottom level data. +! FROM C*4 Test string for open, 'UNIT' or 'FILE' +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3NMOD Subr. W3GDATMD Set number of model. +! W3SETG Subr. Id. Point to selected model. +! W3DIMS Subr. Id. Set array dims for a spectral grid. +! W3DIMX Subr. Id. Set array dims for a spatial grid. +! W3GRMP Subr. W3GSRUMD Compute bilinear interpolation for point +! W3NOUT Subr. W3ODATMD Set number of model for output. +! W3SETO Subr. Id. Point to selected model for output. +! W3DMO5 Subr. Id. Set array dims for output type 5. +! ITRACE Subr. W3SERVMD Subroutine tracing initialization. +! STRACE Subr. Id. Subroutine tracing. +! NEXTLN Subr. Id. Get next line from input file +! EXTCDE Subr. Id. Abort program as graceful as possible. +! DISTAB Subr. W3DISPMD Make tables for solution of the +! dispersion relation. +! READNL Subr. Internal Read namelist. +! INAR2R Subr. W3ARRYMD Read in an REAL array. +! PRTBLK Subr. Id. Print plot of array. +! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! ww3_grid program +! +! 6. Error messages : +! +! 7. Remarks : +! +! Physical grid : +! ----------------- +! +! The physical grid is defined by a grid counter IX defining the +! discrete longitude and IY defining the discrete latitude as shown +! below. For mathemathical convenience, these grid axes will +! generally be denoted as the X and Y axes. Two-dimensional arrays +! describing parameters on this grid are given as A(IY,IX). +! +! IY=NY +! ^ | | | | | | ^ N +! | |------|------|------|------|------|---- | +! | | :: | 25 | 26 | 27 | 28 | --|-- +! |------|------|------|------|------|---- | +! IY=3 | :: | :: | 9 | 10 | 11 | | +! |------|------|------|------|------|---- +! IY=2 | :: | 1 | 2 | :: | 3 | +! |------|------|------|------|------|---- +! IY=1 | :: | :: | :: | :: | :: | +! +------+------+------+------+------+---- +! IX=1 IX=2 IX=3 IX=4 IX=5 ---> IX=NX +! +! :: is a land point. +! +! To reduce memory usage of the model, spectra are stored for sea +! points only, in a one-dimensional grid with the length NSEA. This +! grid is called the storage grid. The definition of the counter +! in the storage grid is graphically depicted above. To transfer +! data between the two grids, the maps MAPFS and MAPSF are +! determined. MAPFS gives the counter of the storage grid ISEA +! for every physical grid point (IY,IX), such that +! +! MAPFS(IY,IX) = ISEA +! +! ISEA = 0 corresponds to land points. The map MAPSF gives the grid +! counters (IY,IX) for a given storage point ISEA. +! +! MAPSF(ISEA,1) = IX +! MAPSF(ISEA,2) = IY +! MAPSF(ISEA,3) = IY+(IX-1)*NY ( filled during reading ) +! +! Finally, a status maps MAPSTA and MAPST2 are determined, where +! the status indicator ISTAT = MAPSTA(IY,IX) determines the type +! of the grid point. +! +! ISTAT Means +! --------------------------------------------------- +! 0 Point excluded from grid. +! (-)1 Sea point +! (-)2 "Active" boundary point (data prescribed) +! +! For ISTAT=0, the secondary status counter ISTA2 is defined as +! +! ISTA2 Means +! --------------------------------------------------- +! 0 Land point. +! 1 Point excluded from grid. +! +! Negative values of ISTAT identify points that are temporarily +! taken out of the computation. For these points ISTA2 are +! defined per bit +! +! BIT Means +! --------------------------------------------------- +! 1 Ice flag (1 = ice coverage) +! 2 Dry flag (1 = dry point with depth 0) +! 3 Inferred land in multi-grid model. +! 4 Masking in multi-grid model. +! 5 land point flag for relocatable grid. +! +! Thus ISTA2=0 for ISTAT<0 is in error, ISTA2=1 means ice cover, +! ISTA2=3 means ice on dry point, etc. +! +! Spectral grid : +! ----------------- +! +! In the spectral grid (and in physical space in general), +! the cartesian convention for directions is used, i.e., the +! direction 0 corresponds to waves propagating in the positive +! X-direction and 90 degr. corresponds to waves propagating in +! the positive Y-direction. Similar definitions are used for the +! internal description of winds and currents. Output can obviously +! be transformed according to any preferred convention. +! +! ITH=NTH +! ^ | | | | | +! | |------|------|------|------|---- +! | | | | | | TH(3) = DTH*2. +! |------|------|------|------|---- +! ITH=2 | | | | | TH(2) = DTH +! |------|------|------|------|---- +! ITH=1 | | | | | TH(1) = 0. +! +------+------+------+------+---- +! IK=1 IK=2 IK=3 IK=4 ---> IK=NK +! +! The spectral grid consists of NK wavenumbers. The first +! wavenumber IK=1 corresponds to the longest wave. The wavenumber +! grid varies in space, as given by an invariant relative freq. +! grid and the local depth. The spectral grid furthermore contains +! NTH directions, equally spaced over a full circle. the first +! direction corresponds to the direction 0, etc. +! +! (Begin SMC description) +! +! Spherical Multiple-Cell (SMC) grid +! ----------------------------------- +! +! SMC grid is a multi-resolution grid using cells of multiple times +! of each other. It is similar to the lat-lon grid using rectangular +! cells but only cells at sea points are retained. All land points +! have been removed from the model. At high latitudes, cells are +! merged longitudinally to relax the CFL resctiction on time steps. +! Near coastlines, cells are divided into quarters in a few steps so +! that high resolution is achieved to refine coastlines and resolve +! small islands. At present, three tiers of quarter cells are used. +! For locating purpose, a usual x-y counter is setup by the smallest +! cell size and starting from the south-west corner of the usual +! rectuangular domain. Each sea cell is then given a pair of x-y +! index, plus a pair of increments. These four index are stored in +! the cell array IJKCel(NCel, 5), each row holds i, j, di, dj, ndps +! where ndps is an integer depth in metre. If precision higher than +! a metre is required, it may use other unit (cm for instance) with a +! conversion factor. +! +! For transport calculation, two face arrays, IJKUFc(NUFc, 7) and +! IJKVFc(NVFc,8), are also created to store the neighbouring cell +! sequential numbers and the face location and size. The 3 arrays +! are calculated outside the wave model and input from text files. +! +! Boundary condition is added for SMC grid so that it can be used for +! regional model as well. Most of the original boundary settings +! are reclaimed as long as the boundary condition file is provided +! by a lat-lon grid WW3 model, which will set the interpolation +! parameters in the boundary condition file. The NBI number is +! reset with an input value because the NX-Y double loop overcount +! the boundary cells for merged cells in the SMC grid. ISBPI +! boundary cell mapping array is fine as MAPFS uses duplicated cell +! number in any merged cell. From there, all original NBI loops are +! reusable. +! +! The whole Arctic can be included in the SMC grid if ARCTC variable +! is set to be .TRUE. within the SMC option. The ARCTC option appends +! the polar Arctic part above 86N to the existing SMC grid and uses +! a map-east reference direction for this extra polar region. +! Because the map-east direction changes with latitude and longitude +! the wave spectra defined to the map-east direction could not be +! mixed up with the conventional spectra defined to the local east +! direction. A rotation sub is provided for convertion from one to +! another. Propagation part will be calculated together, including +! the boundary cells. The boundary cells are then updated by +! assigning the corresponding inner cells to them after conversion. +! Boundary cells are duplicated northmost 4 rows of the global part +! and they can be excluded for source term and output if required. +! For convenience, Arctic cellls are all base level cells and are +! appended to the end of the global cells. If refined cells were +! used in the Arctic part, it would not be kept all together, making +! the sub-loops much more complicated. If refined resolution cells +! are required for a Arctic regional model, users may consider use +! the rotated SMC grid options (RTD and SMC). +! +! For more information about the SMC grid, please refer to +! Li, J.G. (2012) Propagation of Ocean Surface Waves on a Spherical +! Multiple-Cell Grid. J. Comput. Phys., 231, 8262-8277. online at +! http://dx.doi.org/10.1016/j.jcp.2012.08.007 +! +! (End SMC description) +! +! ICEWIND is the scale factor for reduction of wind input by ice +! concentration. Value specified corresponds to the fractional +! input for 100% ice concentration. Default is 1.0, meaning that +! 100% ice concentration result in zero wind input. +! Sin_in_ice=Sin_in_open_water * (1-ICE*ICEWIND) + +! -----------------------------------------------------------------* +! 8. Structure : +! +! ---------------------------------------------------------------- +! 1. Set up grid storage structure. +! ( W3NMOD , W3NOUT , W3SETG , W3SETO ) +! 2.a I-O setup. +! b Print heading(s). +! 3. Prepare int. table for dispersion relation ( DISTAB ) +! 4. Read and process input file up to spectrum. +! a Get comment character +! b Name of grid +! c Define spectrum ( W3DIMS ) +! 5. Set-up discrete spectrum. +! a Directions. +! b Frequency for spectrum. +! 6. Read and process input file up to numerical parameters +! a Set model flags and time steps +! b Set / select source term package +! c Pre-process namelists. +! d Wind input source term. +! e Nonlinear interactions. +! f Whitecapping term. +! g Bottom friction source term. +! h Depth indiced breaking source term. +! i Triad interaction source term. +! j Bottom scattering source term. +! k Undefined source term. +! l Set / select propagaton scheme +! m Parameters for propagation scheme. +! n Set misc. parameters (ice, seeding, ...) +! o End of namelist processing +! p Set various other variables +! 7. Read and prepare grid. +! a Layout of grid +! b Storage of grid of grid +! c Read bottom depths +! d Set up temp map +! e Subgrid information +! 1 Info from input file +! 2 Open file and check if necessary +! 3 Read the data +! 4 Limit +! 8 Finalize status maps +! a Determine where to get the data +! Get data in parts from input file +! ---------------------------------------------------- +! b Read and update TMPSTA with bound. and excl. points. +! c Finalize excluded points +! ---------------------------------------------------- +! Read data from file +! ---------------------------------------------------- +! d Read data from file +! ---------------------------------------------------- +! e Get NSEA and other counters +! f Set up all maps ( W3DIMX ) +! 9. Prepare output boundary points. +! a Read +! b Update +! 10. Write model definition file. ( W3IOGR ) +! ---------------------------------------------------------------- +! +! 9. Switches : +! +! !/FLX1 Stresses according to Wu (1980). +! !/FLX2 Stresses according to T&C (1996). +! !/FLX3 Stresses according to T&C (1996) with cap on Cd. +! !/FLX4 Stresses according to Hwang (2011). +! !/FLX5 Direct use of stress from atmospheric model/input file. +! +! !/LN0 No linear input source term. +! !/SEED 'Seeding' of lowest frequency for sufficiently strong +! winds. Proxi for linear input. +! !/LN1 Cavaleri and Melanotte-Rizzoli with Tolman filter. +! +! !/ST0 No source terms included (input/dissipation) +! !/ST1 WAM-3 physics package. +! !/ST2 Tolman and Chalikov (1996) physics package. +! !/ST3 WAM 4+ source terms from P.A.E.M. Janssen and J-R. Bidlot +! !/ST4 Input and dissipation using saturation following Ardhuin et al. (2009,2010) +! Filipot & Ardhuin (2010) or Romero (2019) +! !/ST6 BYDRZ source term package featuring Donelan et al. +! (2006) input and Babanin et al. (2001,2010) dissipation. +! +! !/NL0 No nonlinear interactions. +! !/NL1 Discrete interaction approximation (DIA). +! !/NL2 Exact interactions (WRT). +! !/NL3 Generalized Multiple DIA (GMD). +! !/NL4 Two Scale Approximation +! !/NL5 Generalized Kinetic Equation (GKE) +! !/NLS Snl based HF filter. +! +! !/BT0 No bottom friction included. +! !/BT1 JONSWAP bottom friction package. +! !/BT4 SHOWEX bottom friction using movable bed roughness +! (Tolman 1994, Ardhuin & al. 2003) +! +! !/IC1 Sink term for interaction with ice (uniform k_i) +! !/IC2 Sink term for under-ice boundary layer friction +! (Liu et al. 1991: JGR 96 (C3), 4605-4621) +! (Liu and Mollo 1988: JPO 18 1720-1712) +! !/IC3 Sink term for interaction with ice (Wang and Shen method) +! (Wang and Shen JGR 2010) +! !/IC4 Sink term for empirical, frequency-dependent attenuation +! in ice (Wadhams et al. 1988: JGR 93 (C6) 6799-6818) +! !/IC5 Sink term for interaction with ice (effective medium mod.) +! (Mosig et al. 2015, Meylan et al. 2018, Liu et al. +! 2020) +! +! !/UOST Unresolved Obstacles Source Term (UOST), Mentaschi et al. 2015 +! +! !/DB0 No depth-induced breaking included. +! !/DB1 Battjes-Janssen depth-limited breaking. +! !/MLIM Mich-style limiter. +! +! !/TR0 No triad interactions included. +! +! !/BS0 No bottom scattering included. +! !/BS1 Routines from F. Ardhuin. +! +! !/PR1 First order propagation scheme. +! !/PR2 QUICKEST scheme with ULTIMATE limite and diffusion +! correction for swell dispersion. +! !/PR3 Averaging ULTIMATE QUICKEST scheme. +! +! !/RTD Rotated regular lat-lon grid. Special case is standard Polat=90. +! !/SMC Spherical Multiple-Cell grid, may includes the whole Arctic. +! +! !/MGG GSE correction for moving grid. +! +! !/S Enable subroutine tracing. +! !/T Enable test output. +! !/T0 Enable test output tables for boundary output. +! +! !/O0 Print equivalent namelist setting to std out. +! !/O1 Print tables with boundary points as part of output. +! !/O2 Print MAPSTA as part of output. +! !/O2a Print land-sea mask in mask.ww3. +! !/O2b Print obstruction data. +! !/O2c Print extended status map. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / + USE CONSTANTS +!/ + USE W3TRIAMD + USE W3GSRUMD, ONLY: W3GRMP + USE W3ODATMD, ONLY: W3NOUT, W3SETO, W3DMO5 + USE W3IOGRMD, ONLY: W3IOGR + USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE +#ifdef W3_RTD + USE W3SERVMD, ONLY: W3EQTOLL, W3LLTOEQ +#endif +#ifdef W3_SMC + USE W3SERVMD, ONLY: W3LLTOEQ +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + USE W3ARRYMD, ONLY: INA2R, INA2I +#ifdef W3_T + USE W3ARRYMD, ONLY: PRTBLK +#endif + USE W3DISPMD, ONLY: DISTAB +!/ + USE W3GDATMD + USE W3ODATMD, ONLY: NDSE, NDST, NDSO + USE W3ODATMD, ONLY: NBI, NBI2, NFBPO, NBO, NBO2, FLBPI, FLBPO, & + IPBPO, ISBPO, XBPO, YBPO, RDBPO, FNMPRE, & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, & + NOSWLL, PTMETH, PTFCUT + USE W3TIMEMD, ONLY: CALTYPE + USE W3NMLGRIDMD +#ifdef W3_SCRIP + USE SCRIP_GRIDS, ONLY: GRID1_UNITS, GRID1_NAME, & + GRID1_CENTER_LON, GRID1_CENTER_LAT, & + GRID1_CORNER_LON, GRID1_CORNER_LAT, & + GRID1_MASK, GRID1_SIZE, GRID1_RANK, & + GRID1_IMASK, & + GRID1_CORNERS, GRID1_DIMS + USE SCRIP_KINDSMOD + USE WMSCRPMD +#endif +#ifdef W3_SCRIPNC + USE NETCDF +#endif +! +#ifdef W3_NL3 + USE W3SNL3MD, ONLY: LAMMAX, DELTHM +#endif +#ifdef W3_NLS + USE W3SNLSMD, ONLY: ABMAX +#endif +! + IMPLICIT NONE +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + TYPE(NML_SPECTRUM_T) :: NML_SPECTRUM + TYPE(NML_RUN_T) :: NML_RUN + TYPE(NML_TIMESTEPS_T) :: NML_TIMESTEPS + TYPE(NML_GRID_T) :: NML_GRID + TYPE(NML_RECT_T) :: NML_RECT + TYPE(NML_CURV_T) :: NML_CURV + TYPE(NML_UNST_T) :: NML_UNST + TYPE(NML_SMC_T) :: NML_SMC + TYPE(NML_DEPTH_T) :: NML_DEPTH + TYPE(NML_MASK_T) :: NML_MASK + TYPE(NML_OBST_T) :: NML_OBST + TYPE(NML_SLOPE_T) :: NML_SLOPE + TYPE(NML_SED_T) :: NML_SED + TYPE(NML_INBND_COUNT_T) :: NML_INBND_COUNT + TYPE(NML_INBND_POINT_T), ALLOCATABLE :: NML_INBND_POINT(:) + TYPE(NML_EXCL_COUNT_T) :: NML_EXCL_COUNT + TYPE(NML_EXCL_POINT_T), ALLOCATABLE :: NML_EXCL_POINT(:) + TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: NML_EXCL_BODY(:) + TYPE(NML_OUTBND_COUNT_T) :: NML_OUTBND_COUNT + TYPE(NML_OUTBND_LINE_T), ALLOCATABLE :: NML_OUTBND_LINE(:) +! + INTEGER, PARAMETER :: NFL = 6 + INTEGER :: NDSI, NDSI2, NDSS, NDSM, NDSG, NDSTR,& + IERR, NDSTRC, NTRACE, ITH, IK, ITH0, & + ISP, IYN(NFL), NRLIN, NRSRCE, NRNL, & + NRBT, NRDB, NRTR, NRBS, NRPROP, & + IDLA, IDFM, IX0, IXN, IX, IY, ISEA, & + IDX, IXO, IDY, IYO, IBA, NBA, ILOOP, & + IFL, NBOTOT, NPO, IP, IX1, IX2, IY1, & + IY2, J, JJ, IXR(4), IYR(4), ISEAI(4),& + IST, NKI, NTHI, NRIC, NRIS, I, IDFT, & + NSTAT, NBT, NLAND, NOSW, NMAPB, IMAPB +#ifdef W3_NL2 + INTEGER :: IDEPTH +#endif +#ifdef W3_O1 + INTEGER :: IBI, IP0, IPN, IPH, IPI +#endif + INTEGER :: NCOL = 78 +#ifdef W3_SMC + !!Li Offset to change Equator index = 0 to regular index JEQT + !!Li LvSMC levels of refinded resolutions for SMC grid. + !!Li NBISMC number of boundary point for regional SMC grid. + !!Li ISHFT for SMC i-index from smc origin to regular grid west edge. + !!Li SMC cell only subgrid obstruction array dimensions NCObst, JObs. + INTEGER :: JEQT, LvSMC, NBISMC, JS, NCObst, JObs, ISHFT + INTEGER :: NGUI, NGVJ, NAUI, NAVJ +#endif +! +#ifdef W3_O2 + INTEGER :: NMAP, IMAP +#endif +#ifdef W3_T + INTEGER :: IX3, IY3 +#endif +#ifdef W3_T0 + INTEGER :: IFILE +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +! + INTEGER, ALLOCATABLE :: TMPSTA(:,:), TMPMAP(:,:), READMP(:,:) +#ifdef W3_T + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif +! + REAL :: RXFR, RFR1, SIGMA, SXFR, FACHF, & + VSC, VSC0, VOF, & + ZLIM, X, Y, XP, XO0, YO0, DXO, DYO, & + XO, YO, RD(4), RDTOT, & + FACTOR, RTH0, FMICHE, RWNDC, & + WCOR1, WCOR2 +! + CHARACTER(LEN=4) :: GSTRG, CSTRG +! +! Variables used to allow spectral output on full grid +! + INTEGER :: P2SF,I1P2SF,I2P2SF + INTEGER :: E3D,I1E3D,I2E3D + INTEGER :: US3D,I1US3D,I2US3D, & + USSP, IUSSP, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M + ! STK_WN are the decays for Stokes drift partitions + REAL :: STK_WN(25) + +#ifdef W3_DEBUGGRID + INTEGER :: nbCase1, nbCase2, nbCase3, & + nbCase4, nbCase5, nbCase6, & + nbCase7, nbCase8 + INTEGER :: nbTMPSTA0, nbTMPSTA1, nbTMPSTA2 + INTEGER :: IAPROC +#endif +! +#ifdef W3_LN1 + REAL :: CLIN, RFPM, RFHF +#endif +#ifdef W3_ST1 + REAL :: CINP, CDIS, APM +#endif +#ifdef W3_ST2 + REAL :: PHIMIN, FPIA, FPIB, DPHID +#endif +#ifdef W3_NL1 + REAL :: NLPROP +#endif +#ifdef W3_NL2 + REAL :: DPTFAC, DEPTHS(100) +#endif +#ifdef W3_NL3 + REAL :: QPARMS(500) +#endif +#ifdef W3_NLS + REAL :: A34, FHFC, DNM, FC1, FC2, FC3 +#endif +#ifdef W3_BT1 + REAL :: GAMMA +#endif +#ifdef W3_PR2 + REAL :: LATMIN +#endif +! +#ifdef W3_SMC + REAL :: TRNMX, TRNMY + INTEGER, ALLOCATABLE :: NLvCelsk(:), NLvUFcsk(:), NLvVFcsk(:) + INTEGER, ALLOCATABLE :: IJKCelin(:,:),IJKUFcin(:,:),IJKVFcin(:,:) + INTEGER, ALLOCATABLE :: NBICelin(:), IJKObstr(:,:) + REAL :: PoLonAC, PoLatAC + INTEGER, ALLOCATABLE :: IJKCelAC(:,:),IJKUFcAC(:,:),IJKVFcAC(:,:) + REAL, ALLOCATABLE :: XLONAC(:),YLATAC(:),ELONAC(:),ELATAC(:) +#endif +! +#ifdef W3_RTD + REAL, ALLOCATABLE :: AnglDin(:,:),StdLon(:,:),StdLat(:,:) + ! 1-dim boundary sectors + REAL, ALLOCATABLE :: BDYLON(:), BDYLAT(:), & + ELatbdy(:), ELonbdy(:), Anglbdy(:) + ! If the destination grid for an output b.c. is rotated, its pole is: + REAL :: bPolat, bPolon +! +#endif + REAL, ALLOCATABLE :: XGRDIN(:,:), YGRDIN(:,:) + REAL, ALLOCATABLE :: ZBIN(:,:), OBSX(:,:), OBSY(:,:) + REAL, ALLOCATABLE :: REFD(:,:), REFD2(:,:), REFS(:,:) +#ifdef W3_BT4 + REAL, ALLOCATABLE :: SED_D50FILE(:,:), SED_POROFILE(:,:) + LOGICAL :: SEDMAPD50 + REAL :: SED_D50_UNIFORM, SED_DSTAR, RIPFAC1, & + RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC +#endif +! + LOGICAL :: FLLIN, FLINDS, FLNL, FLBT, FLDB, & + FLTR, FLBS, FLPROP, FLREF, & + FIRST, CONNCT, FLNEW, INGRID,FLIC, & + FLIS, FLGNML + LOGICAL :: FLTC96 = .FALSE. + LOGICAL :: FLNMLO = .FALSE. + LOGICAL :: FLSTB2 = .FALSE. + LOGICAL :: FLST4 = .FALSE. + LOGICAL :: FLST6 = .FALSE. + + REAL :: FACBERG, REFSLOPE +#ifdef W3_IS1 + REAL :: ISC1, ISC2 +#endif +#ifdef W3_IS2 + REAL :: ISC1, IS2BACKSCAT, IS2C2, IS2C3,& + IS2FRAGILITY, IS2DMIN, IS2DAMP, & + IS2CONC, IS2CREEPB, IS2CREEPC, & + IS2CREEPD, IS2CREEPN, IS2BREAKE,& + IS2WIM1, IS2BREAKF, IS2FLEXSTR, & + IS2ANDISN, IS2ANDISE, IS2ANDISD + LOGICAL :: IS2BREAK, IS2DISP, IS2DUPDATE, & + IS2ISOSCAT, IS2ANDISB +#endif +! +#ifdef W3_REF1 + REAL :: REFCOAST, REFFREQ, REFMAP, & + REFSUBGRID, REFRMAX, REFMAPD, & + REFICEBERG, REFCOSP_STRAIGHT, & + REFFREQPOW, REFUNSTSOURCE +#endif +! +#ifdef W3_IG1 + LOGICAL :: IGSWELLMAX, IGBCOVERWRITE + INTEGER :: IGMETHOD, IGADDOUTP, IGSOURCE, & + IGSOURCEATBP, IGSTERMS + REAL :: IGMAXFREQ, IGMINDEP, IGMAXDEP, & + IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL +#endif +! +#ifdef W3_IC2 + LOGICAL :: IC2DISPER + REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX +#endif + +#ifdef W3_IC3 + REAL :: IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, & + IC3MAXTHK, IC3MAXCNC, & + IC3HILIM, IC3KILIM, & + IC3VISC, IC3ELAS, IC3DENS, IC3HICE + LOGICAL :: IC3CHENG,USECGICE +#endif + +#ifdef W3_IC4 + INTEGER :: IC4METHOD + REAL :: IC4KI(NIC4), IC4FC(NIC4) +#endif +! +#ifdef W3_IC5 + REAL :: IC5MINIG, IC5MINWT, & + IC5MAXKRATIO, IC5MAXKI, IC5MINHW, & + IC5MAXITER, IC5RKICK, IC5KFILTER, & + IC5VEMOD + CHARACTER(LEN=4) :: IC5MSTR(3) = (/' EFS', ' RP ', ' M2 '/) +#endif + + CHARACTER :: COMSTR*1, PNAME*30, RFORM*16, & + FROM*4, FNAME*60, TNAME*60, LINE*80, & + STATUS*20,FNAME2*60, PNAME2*40 + CHARACTER(LEN=6) :: YESXNO(2) +#ifdef W3_FLX3 + CHARACTER(LEN=18) :: TYPEID +#endif + +#ifdef W3_SCRIP + INTEGER :: NCID + INTEGER :: grid_size_dimid, grid_rank_dimid, grid_corners_dimid + INTEGER :: grid_center_lat_varid, grid_center_lon_varid + INTEGER :: grid_corner_lat_varid, grid_corner_lon_varid + INTEGER :: grid_area_varid, grid_imask_varid + INTEGER :: grid_dims_varid + REAL (SCRIP_R8) :: CONV_DX,CONV_DY,OFFSET +#endif + +!/ ------------------------------------------------------------------- / +!/ Namelists +!/ + INTEGER :: FLAGTR, IHM + REAL :: CFLTM, CICE0, CICEN, PMOVE, XFILT, & + LICE, XSEED, XR, HSPM, WSM, WSC, STDX,& + STDY, STDT, ICEHMIN, ICEHFAC, ICEHINIT, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEHDISP, ICEFDISP, ICEDDISP, BTBET +! + REAL(8) :: GSHIFT ! see notes in WMGHGH + LOGICAL :: FLC, ICEDISP, TRCKCMPR + INTEGER :: PTM ! Partitioning method + REAL :: PTFC ! Part. cut off freq (for method 5) + REAL :: AIRCMIN, AIRGB + CHARACTER :: PMNAME*45, PMNAM2*45 ! Part. method desc. +#ifdef W3_FLD1 + INTEGER :: TAILTYPE + REAL :: TAILLEV, TAILT1, TAILT2 +#endif +#ifdef W3_FLD2 + INTEGER :: TAILTYPE + REAL :: TAILLEV, TAILT1, TAILT2 +#endif +#ifdef W3_FLX3 + INTEGER :: CTYPE + REAL :: CDMAX +#endif +#ifdef W3_FLX4 + REAL :: CDFAC +#endif +#ifdef W3_ST2 + REAL :: ZWND, SWELLF, STABSH, STABOF, & + CNEG, CPOS, FNEG, FPOS + REAL :: SDSA0, SDSA1, SDSA2, & + SDSB0, SDSB1, SDSB2, SDSB3 +#endif +#ifdef W3_ST3 + REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& + ZALP, SWELLF, FXPM3, FXFM3, & + WNMEANPTAIL, WNMEANP, STXFTF, STXFTWN + REAL :: STXFTFTAIL, SDSC1, & + SDSDELTA1, SDSDELTA2 +#endif +! +#ifdef W3_ST4 + INTEGER :: SWELLFPAR, SDSISO, SDSBRFDF + REAL :: SDSBCHOICE + REAL :: ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP,& + ZALP, Z0RAT, TAUWSHELTER, SWELLF, & + SWELLF2,SWELLF3,SWELLF4, SWELLF5, & + SWELLF6, SWELLF7, FXPM3, FXFM3, & + WNMEANPTAIL, WNMEANP, STXFTF, STXFTFTAIL, & + STXFTWN, SINBR, FXFMAGE, & + SDSC2, SDSCUM, SDSC4, SDSC5, SDSC6, WHITECAPWIDTH, WHITECAPDUR, & + SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & + SDSBR, SDSP, SDSBT, SDS4A, SDKOF, & + SDSCOS, SDSDTH, SDSBCK, SDSABK, & + SDSPBK, SDSBINT, SDSHCK, & + SDSBRF1, & + SDSBM0, SDSBM1, SDSBM2, SDSBM3, & + SDSBM4, SDSFACMTF, SDSCUMP, SDSNUW, & + SDSL, SDSMWD, SDSMWPOW, SPMSS, SDSNMTF +#endif +! +#ifdef W3_ST6 + REAL :: SINA0, SINWS, SINFC, & + SDSA1, SDSA2, SWLB1 + INTEGER :: SDSP1, SDSP2 + LOGICAL :: SDSET, CSTB1 +#endif +! +#ifdef W3_NL1 + REAL :: LAMBDA, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 +#endif +#ifdef W3_NL2 + INTEGER :: IQTYPE, NDEPTH + REAL :: TAILNL +#endif +#ifdef W3_NL3 + INTEGER :: NQDEF + REAL :: MSC, NSC, KDFD, KDFS +#endif +#ifdef W3_NL4 + INTEGER :: INDTSA, ALTLP +#endif +#ifdef W3_NL5 + REAL :: NL5DPT, NL5OML + INTEGER :: NL5DIS, NL5KEV, NL5IPL, NL5PMX +#endif +#ifdef W3_DB1 + REAL :: BJALFA, BJGAM + LOGICAL :: BJFLAG +#endif +#ifdef W3_PR2 + REAL :: DTIME +#endif +! +#ifdef W3_SMC + REAL :: DTIMS, CFLSM, RFMAXD, SYMR, YJ0R + LOGICAL :: UNO3, AVERG, SEAWND, Arctic + CHARACTER :: PNSMC*30 +#endif +! +#ifdef W3_PR3 + REAL :: WDTHCG, WDTHTH +#endif + LOGICAL :: JGS_TERMINATE_MAXITER = .TRUE. + LOGICAL :: JGS_TERMINATE_DIFFERENCE = .TRUE. + LOGICAL :: JGS_TERMINATE_NORM = .TRUE. + LOGICAL :: JGS_LIMITER = .FALSE. + LOGICAL :: JGS_BLOCK_GAUSS_SEIDEL = .TRUE. + LOGICAL :: JGS_USE_JACOBI = .TRUE. + LOGICAL :: JGS_SOURCE_NONLINEAR = .FALSE. + LOGICAL :: UGOBCAUTO = .FALSE. + LOGICAL :: UGBCCFL = .FALSE. + LOGICAL :: EXPFSN = .TRUE. + LOGICAL :: EXPFSPSI = .FALSE. + LOGICAL :: EXPFSFCT = .FALSE. + LOGICAL :: IMPFSN = .FALSE. + LOGICAL :: EXPTOTAL = .FALSE. + LOGICAL :: IMPTOTAL = .FALSE. + LOGICAL :: IMPREFRACTION = .FALSE. + LOGICAL :: IMPFREQSHIFT = .FALSE. + LOGICAL :: IMPSOURCE = .FALSE. + LOGICAL :: SETUP_APPLY_WLV = .FALSE. + INTEGER :: JGS_MAXITER=100 + INTEGER :: nbSel + INTEGER :: UNSTSCHEMES(4) + INTEGER :: UNSTSCHEME + INTEGER :: JGS_NLEVEL = 0 + REAL*8 :: JGS_PMIN = 0. + REAL*8 :: JGS_DIFF_THR = 1.E-10 + REAL*8 :: JGS_NORM_THR = 1.E-20 + REAL*8 :: SOLVERTHR_SETUP = 1.E-20 + REAL*8 :: CRIT_DEP_SETUP = 0. +! + CHARACTER :: UGOBCFILE*60 + REAL :: UGOBCDEPTH + LOGICAL :: UGOBCOK + +#ifdef W3_RTD + REAL :: PLAT, PLON + LOGICAL :: UNROT + ! Poles of the output nested grids. May be a mix of rotated and standard + REAL, DIMENSION(9) :: BPLAT, BPLON +#endif +! +#ifdef W3_FLD1 + NAMELIST /FLD1/ TAILTYPE, TAILLEV, TAILT1, TAILT2 +#endif +#ifdef W3_FLD2 + NAMELIST /FLD2/ TAILTYPE, TAILLEV, TAILT1, TAILT2 +#endif +#ifdef W3_FLX3 + NAMELIST /FLX3/ CDMAX, CTYPE +#endif +#ifdef W3_FLX4 + NAMELIST /FLX4/ CDFAC +#endif +#ifdef W3_IC2 + NAMELIST /SIC2/ IC2DISPER, IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, IC2DMAX +#endif +#ifdef W3_IC3 + NAMELIST /SIC3/ IC3MAXTHK, IC2TURB, IC2ROUGH, IC2REYNOLDS, & + IC2SMOOTH, IC2VISC, IC2TURBS, IC3MAXCNC, & + IC3CHENG, USECGICE, IC3HILIM, IC3KILIM, & + IC3VISC, IC3ELAS, IC3DENS, IC3HICE +#endif +#ifdef W3_IC4 + NAMELIST /SIC4/ IC4METHOD, IC4KI, IC4FC +#endif +#ifdef W3_IC5 + NAMELIST /SIC5/ IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK,& + IC5KFILTER, IC5VEMOD +#endif +#ifdef W3_IG1 + NAMELIST /SIG1/ IGMETHOD, IGADDOUTP, IGSOURCE, IGBCOVERWRITE, & + IGMAXFREQ, IGSTERMS, IGSWELLMAX, & + IGSOURCEATBP, IGKDMIN, IGFIXEDDEPTH, IGEMPIRICAL +#endif +#ifdef W3_LN1 + NAMELIST /SLN1/ CLIN, RFPM, RFHF +#endif +#ifdef W3_ST1 + NAMELIST /SIN1/ CINP +#endif +#ifdef W3_ST2 + NAMELIST /SIN2/ ZWND, SWELLF, STABSH, STABOF, CNEG, CPOS, FNEG +#endif +#ifdef W3_ST3 + NAMELIST /SIN3/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + SWELLF +#endif +#ifdef W3_ST4 + NAMELIST /SIN4/ ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + TAUWSHELTER, SWELLFPAR, SWELLF, & + SWELLF2, SWELLF3, SWELLF4, SWELLF5, SWELLF6, & + SWELLF7, Z0RAT, SINBR +#endif +#ifdef W3_NL1 + NAMELIST /SNL1/ LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 +#endif +#ifdef W3_NL2 + NAMELIST /SNL2/ IQTYPE, TAILNL, NDEPTH + NAMELIST /ANL2/ DEPTHS +#endif +#ifdef W3_NL3 + NAMELIST /SNL3/ NQDEF, MSC, NSC, KDFD, KDFS + NAMELIST /ANL3/ QPARMS +#endif +#ifdef W3_NL4 + NAMELIST /SNL4/ INDTSA, ALTLP +#endif +#ifdef W3_NL5 + NAMELIST /SNL5/ NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX +#endif +#ifdef W3_NLS + NAMELIST /SNLS/ A34, FHFC, DNM, FC1, FC2, FC3 +#endif +#ifdef W3_ST1 + NAMELIST /SDS1/ CDIS, APM +#endif +#ifdef W3_ST2 + NAMELIST /SDS2/ SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN +#endif +#ifdef W3_ST3 + NAMELIST /SDS3/ SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & + SDSDELTA2 +#endif +#ifdef W3_ST4 + NAMELIST /SDS4/ SDSBCHOICE, WNMEANP, WNMEANPTAIL, FXPM3, FXFM3, & + FXFMAGE, SDSC2, SDSCUM, SDSSTRAIN, SDSSTRAINA, & + SDSSTRAIN2, SDSC4, SDSFACMTF, SDSNMTF,SDSCUMP, & + SDSC5, SDSC6, SDSBR, SDSBT, SDSP, SDSISO, & + SDSBCK, SDSABK, SDSPBK, SDSBINT, SDSHCK, & + SDSDTH, SDSCOS, SDSBRF1, SDSBRFDF, SDSNUW, & + SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & + WHITECAPWIDTH, WHITECAPDUR, SDSMWD, SDSMWPOW, SDKOF +#endif + +#ifdef W3_ST6 + NAMELIST /SIN6/ SINA0, SINWS, SINFC + NAMELIST /SDS6/ SDSET, SDSA1, SDSA2, SDSP1, SDSP2 + NAMELIST /SWL6/ SWLB1, CSTB1 +#endif +#ifdef W3_BT1 + NAMELIST /SBT1/ GAMMA +#endif +#ifdef W3_BT4 + NAMELIST /SBT4/ SEDMAPD50, SED_D50_UNIFORM, RIPFAC1, & + RIPFAC2, RIPFAC3, RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC +#endif +#ifdef W3_DB1 + NAMELIST /SDB1/ BJALFA, BJGAM, BJFLAG +#endif +#ifdef W3_UOST + NAMELIST /UOST/ UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif +! +#ifdef W3_PR1 + NAMELIST /PRO1/ CFLTM +#endif +#ifdef W3_PR2 + NAMELIST /PRO2/ CFLTM, DTIME, LATMIN +#endif +#ifdef W3_SMC + NAMELIST /PSMC/ CFLSM, DTIMS, RFMAXD, Arctic, AVERG, UNO3, & + LvSMC, ISHFT, JEQT, NBISMC, SEAWND +#endif +! +#ifdef W3_PR3 + NAMELIST /PRO3/ CFLTM, WDTHCG, WDTHTH +#endif + NAMELIST /UNST/ UGOBCAUTO, UGOBCDEPTH, UGOBCFILE, & + UGBCCFL, EXPFSN, EXPFSPSI, EXPFSFCT, & + IMPFSN, IMPTOTAL, EXPTOTAL, & + IMPREFRACTION, IMPFREQSHIFT, & + IMPSOURCE, & + JGS_TERMINATE_MAXITER, & + JGS_TERMINATE_DIFFERENCE, & + JGS_TERMINATE_NORM, & + JGS_LIMITER, & + JGS_USE_JACOBI, & + JGS_BLOCK_GAUSS_SEIDEL, & + JGS_MAXITER, & + JGS_PMIN, & + JGS_DIFF_THR, & + JGS_NORM_THR, & + JGS_NLEVEL, & + JGS_SOURCE_NONLINEAR, & + SETUP_APPLY_WLV, SOLVERTHR_SETUP, & + CRIT_DEP_SETUP + NAMELIST /MISC/ CICE0, CICEN, LICE, XSEED, FLAGTR, XP, XR, & + XFILT, PMOVE, IHM, HSPM, WSM, WSC, FLC, FMICHE, & + RWNDC, FACBERG, NOSW, GSHIFT, WCOR1, WCOR2, & + STDX, STDY, STDT, ICEHMIN, ICEHINIT, ICEDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, ICEHFAC, & + ICEHDISP, ICEDDISP, ICEFDISP, CALTYPE, & + TRCKCMPR, PTM, PTFC, BTBET + NAMELIST /OUTS/ P2SF, I1P2SF, I2P2SF, & + US3D, I1US3D, I2US3D, & + USSP, IUSSP, STK_WN, & + E3D, I1E3D, I2E3D, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M +#ifdef W3_IS1 + NAMELIST /SIS1/ ISC1, ISC2 +#endif +#ifdef W3_IS2 + NAMELIST /SIS2/ ISC1, IS2C2, IS2C3, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & + IS2DISP, IS2FRAGILITY, IS2CONC, IS2DMIN, & + IS2DAMP, IS2DUPDATE, IS2CREEPB, IS2CREEPC, & + IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, & + IS2WIM1, IS2FLEXSTR, IS2ANDISB, IS2ANDISE, IS2ANDISD, & + IS2ANDISN +#endif +#ifdef W3_REF1 + NAMELIST /REF1/ REFCOAST, REFFREQ, REFMAP, REFMAPD, & + REFSUBGRID, REFICEBERG, & + REFCOSP_STRAIGHT, REFSLOPE, REFRMAX, & + REFFREQPOW, REFUNSTSOURCE +#endif +!/ +#ifdef W3_RTD + NAMELIST /ROTD/ PLAT, PLON, UNROT +! Poles of destination grids for boundary conditions output + NAMELIST /ROTB/ BPLAT, BPLON +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ + DATA YESXNO / 'YES/--' , '---/NO' / + + CONTAINS + + SUBROUTINE W3GRID() + +#ifdef W3_O0 + FLNMLO = .TRUE. +#endif +#ifdef W3_STAB2 + FLSTB2 = .TRUE. +#endif +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 1. Set up grid storage structure +! + CALL W3NMOD ( 1, 6, 6 ) + CALL W3SETG ( 1, 6, 6 ) + CALL W3NOUT ( 6, 6 ) + CALL W3SETO ( 1, 6, 6 ) +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 2. IO set-up. +! +#ifdef W3_DEBUGGRID + IAPROC = 1 +#endif + NDSI = 10 + NDSS = 99 + NDSM = 20 +! + INQUIRE(FILE=TRIM(FNMPRE)//"ww3_grid.nml", EXIST=FLGNML) + IF (FLGNML) THEN + ! Read namelist + CALL W3NMLGRID (NDSI, TRIM(FNMPRE)//'ww3_grid.nml', NML_SPECTRUM, NML_RUN, & + NML_TIMESTEPS, NML_GRID, NML_RECT, NML_CURV, & + NML_UNST, NML_SMC, NML_DEPTH, NML_MASK, & + NML_OBST, NML_SLOPE, NML_SED, NML_INBND_COUNT, & + NML_INBND_POINT, NML_EXCL_COUNT, & + NML_EXCL_POINT, NML_EXCL_BODY, & + NML_OUTBND_COUNT, NML_OUTBND_LINE, IERR) + ELSE + OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_grid.inp',STATUS='OLD', & + ERR=2000,IOSTAT=IERR) + END IF +! + NDSTRC = 6 + NTRACE = 10 + CALL ITRACE ( NDSTRC, NTRACE ) +! +#ifdef W3_S + CALL STRACE (IENT, 'W3GRID') +#endif + WRITE (NDSO,900) +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 3.a Interpolation table for dispersion relation. +! + CALL DISTAB +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 3.b Table for friction factors +! + CALL TABU_FW +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 4 Read and process input file up to spectrum +! + + IF (FLGNML) THEN + ! grid name + GNAME=TRIM(NML_GRID%NAME) + WRITE (NDSO,902) GNAME + + ! spectrum parameters + RXFR=NML_SPECTRUM%XFR + RFR1=NML_SPECTRUM%FREQ1 + NKI=NML_SPECTRUM%NK + NTHI=NML_SPECTRUM%NTH + RTH0=NML_SPECTRUM%THOFF + + ELSE + + READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) COMSTR + IF (COMSTR.EQ.' ') COMSTR = '$' + WRITE (NDSO,901) COMSTR + CALL NEXTLN ( COMSTR , NDSI , NDSE ) +! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) GNAME + WRITE (NDSO,902) GNAME +! + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) RXFR, RFR1, NKI, NTHI, RTH0 + END IF + + + NK = NKI + NK2 = NKI + 2 + NTH = NTHI + NSPEC = NK * NTH + XFR = MAX ( RXFR , 1.00001 ) + FR1 = MAX ( RFR1 , 1.E-6 ) + DTH = TPI / REAL(NTH) + RTH0 = MAX ( -0.5 , MIN ( 0.5 , RTH0 ) ) + WRITE (NDSO,903) NTH, DTH*RADE + WRITE (NDSO,904) 360./REAL(NTH)*RTH0 + WRITE (NDSO,905) NK, FR1, FR1*XFR**(NK-1), XFR +! + CALL W3DIMS ( 1, NK, NTH, NDSE, NDST ) +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 5. Initialize spectral parameters. +! 5.a Directions : +! + DO ITH=1, NTH + TH (ITH) = DTH * ( RTH0 + REAL(ITH-1) ) + ESIN(ITH) = SIN ( TH(ITH) ) + ECOS(ITH) = COS ( TH(ITH) ) + IF ( ABS(ESIN(ITH)) .LT. 1.E-5 ) THEN + ESIN(ITH) = 0. + IF ( ECOS(ITH) .GT. 0.5 ) THEN + ECOS(ITH) = 1. + ELSE + ECOS(ITH) = -1. + END IF + END IF + IF ( ABS(ECOS(ITH)) .LT. 1.E-5 ) THEN + ECOS(ITH) = 0. + IF ( ESIN(ITH) .GT. 0.5 ) THEN + ESIN(ITH) = 1. + ELSE + ESIN(ITH) = -1. + END IF + END IF + ES2 (ITH) = ESIN(ITH)**2 + EC2 (ITH) = ECOS(ITH)**2 + ESC (ITH) = ESIN(ITH)*ECOS(ITH) + END DO +! + DO IK=2, NK+1 + ITH0 = (IK-1)*NTH + DO ITH=1, NTH + ESIN(ITH0+ITH) = ESIN(ITH) + ECOS(ITH0+ITH) = ECOS(ITH) + ES2 (ITH0+ITH) = ES2 (ITH) + EC2 (ITH0+ITH) = EC2 (ITH) + ESC (ITH0+ITH) = ESC (ITH) + END DO + END DO +! +! b Frequencies : +! + SIGMA = FR1 * TPI / XFR**2 + SXFR = 0.5 * (XFR-1./XFR) +! + DO IK=0, NK+1 + SIGMA = SIGMA * XFR + SIG (IK) = SIGMA + DSIP(IK) = SIGMA * SXFR + END DO +! + DSII( 1) = 0.5 * SIG( 1) * (XFR-1.) + DO IK=2, NK-1 + DSII(IK) = DSIP(IK) + END DO + DSII(NK) = 0.5 * SIG(NK) * (XFR-1.) / XFR +! + DO IK=1, NK + DDEN(IK) = DTH * DSII(IK) * SIG(IK) + END DO +! + DO ISP=1, NSPEC + IK = 1 + (ISP-1)/NTH + SIG2 (ISP) = SIG (IK) + DDEN2(ISP) = DDEN(IK) + END DO +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 6 Read and process input file up to numerical parameters +! 6.a Set model flags and time steps +! + WRITE (NDSO,910) + IF (FLGNML) THEN + FLDRY=NML_RUN%FLDRY + FLCX=NML_RUN%FLCX + FLCY=NML_RUN%FLCY + FLCTH=NML_RUN%FLCTH + FLCK=NML_RUN%FLCK + FLSOU=NML_RUN%FLSOU + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) & + FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU + END IF +! + IYN = 2 + IF ( FLDRY ) IYN(1) = 1 + IF ( FLCX ) IYN(2) = 1 + IF ( FLCY ) IYN(3) = 1 + IF ( FLCTH ) IYN(4) = 1 + IF ( FLCK ) IYN(5) = 1 + IF ( FLSOU ) IYN(6) = 1 +! + WRITE (NDSO,911) (YESXNO(IYN(IFL)),IFL=1,NFL) +! + IF ( .NOT. (FLDRY.OR.FLCX.OR.FLCY.OR.FLCK.OR.FLCTH.OR.FLSOU) ) THEN + WRITE (NDSE,1010) + CALL EXTCDE ( 2 ) + END IF +! + IF (FLGNML) THEN + DTMAX=NML_TIMESTEPS%DTMAX + DTCFL=NML_TIMESTEPS%DTXY + DTCFLI=NML_TIMESTEPS%DTKTH + DTMIN=NML_TIMESTEPS%DTMIN + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) DTMAX, DTCFL, DTCFLI, DTMIN + END IF +#ifdef W3_SEC1 + IF (DTMAX.LT.1.) THEN + NITERSEC1=CEILING(1./DTMAX) + WRITE (NDSO,913) NITERSEC1 + ELSE + NITERSEC1=1 + END IF +#endif + + DTMAX = MAX ( 1. , DTMAX ) +! +! Commented to allow very high resolution zooms +! +! DTCFL = MAX ( 1. , DTCFL ) +! DTCFLI = MIN ( DTMAX , MAX ( 1. , DTCFLI ) ) + DTMIN = MIN ( DTMAX , MAX ( 0. , DTMIN ) ) + WRITE (NDSO,912) DTMAX, DTCFL, DTCFLI, DTMIN +! +! 6.b Set / select source term package +! + NRLIN = 0 + NRSRCE = 0 + NRNL = 0 + NRBT = 0 + NRIC = 0 + NRIS = 0 + NRDB = 0 + NRTR = 0 + NRBS = 0 +! + FLLIN = .TRUE. + FLINDS = .TRUE. + FLNL = .TRUE. + FLBT = .TRUE. + FLIC = .FALSE. + FLIS = .FALSE. + FLDB = .TRUE. + FLTR = .TRUE. + FLBS = .TRUE. + FLREF = .FALSE. +! +#ifdef W3_LN0 + NRLIN = NRLIN + 1 + FLLIN = .FALSE. +#endif +#ifdef W3_SEED + NRLIN = NRLIN + 1 +#endif +#ifdef W3_LN1 + NRLIN = NRLIN + 1 +#endif +! +#ifdef W3_ST0 + NRSRCE = NRSRCE + 1 + FLINDS = .FALSE. +#endif +#ifdef W3_ST1 + NRSRCE = NRSRCE + 1 +#endif +#ifdef W3_ST2 + NRSRCE = NRSRCE + 1 + FLTC96 = .TRUE. +#endif +#ifdef W3_ST3 + NRSRCE = NRSRCE + 1 +#endif +#ifdef W3_ST4 + NRSRCE = NRSRCE + 1 + FLST4 = .TRUE. +#endif +#ifdef W3_ST6 + NRSRCE = NRSRCE + 1 + FLST6 = .TRUE. +#endif +! +#ifdef W3_NL0 + NRNL = NRNL + 1 + FLNL = .FALSE. +#endif +#ifdef W3_NL1 + NRNL = NRNL + 1 +#endif +#ifdef W3_NL2 + NRNL = NRNL + 1 +#endif +#ifdef W3_NL3 + NRNL = NRNL + 1 +#endif +#ifdef W3_NL4 + NRNL = NRNL + 1 +#endif +#ifdef W3_NL5 + NRNL = NRNL + 1 +#endif +! +#ifdef W3_BT0 + NRBT = NRBT + 1 + FLBT = .FALSE. +#endif +#ifdef W3_BT1 + NRBT = NRBT + 1 +#endif +#ifdef W3_BT4 + NRBT = NRBT + 1 +#endif +#ifdef W3_BT8 + NRBT = NRBT + 1 +#endif +#ifdef W3_BT9 + NRBT = NRBT + 1 +#endif +! +#ifdef W3_IC1 + NRIC = NRIC + 1 + FLIC = .TRUE. +#endif +#ifdef W3_IC2 + NRIC = NRIC + 1 + FLIC = .TRUE. +#endif +#ifdef W3_IC3 + NRIC = NRIC + 1 + FLIC = .TRUE. +#endif +#ifdef W3_IC4 + NRIC = NRIC + 1 + FLIC = .TRUE. +#endif +#ifdef W3_IC5 + NRIC = NRIC + 1 + FLIC = .TRUE. +#endif +! +#ifdef W3_IS1 + NRIS = NRIS + 1 + FLIS = .TRUE. +#endif +#ifdef W3_IS2 + NRIS = NRIS + 1 + FLIS = .TRUE. +#endif +! +#ifdef W3_DB0 + NRDB = NRDB + 1 + FLDB = .FALSE. +#endif +#ifdef W3_DB1 + NRDB = NRDB + 1 +#endif +! +#ifdef W3_TR0 + NRTR = NRTR + 1 + FLTR = .FALSE. +#endif +#ifdef W3_TR1 + NRTR = NRTR + 1 +#endif +! +#ifdef W3_BS0 + NRBS = NRBS + 1 + FLBS = .FALSE. +#endif +#ifdef W3_BS1 + NRBS = NRBS + 1 +#endif +! +#ifdef W3_REF1 + FLREF = .TRUE. +#endif +! + IF ( .NOT.FLLIN .AND. .NOT.FLINDS .AND. .NOT.FLNL .AND. & + .NOT.FLBT .AND. .NOT.FLIC .AND. .NOT.FLIS .AND. & + .NOT.FLDB .AND. .NOT.FLTR .AND. .NOT.FLBS .AND. & + .NOT.FLREF .AND. FLSOU ) THEN + WRITE (NDSE,1020) + CALL EXTCDE ( 10 ) + END IF +! + IF ( ( FLLIN .OR. FLINDS .OR. FLNL .OR. FLBT .OR. FLDB .OR. & + FLTR .OR. FLBS .OR. FLREF .OR. FLIC ) & + .AND. .NOT.FLSOU ) THEN + WRITE (NDSE,1021) + END IF +! + IF ( NRLIN .NE. 1 ) THEN + WRITE (NDSE,1022) NRLIN + CALL EXTCDE ( 11 ) + END IF +! + IF ( NRSRCE .NE. 1 ) THEN + WRITE (NDSE,1023) NRSRCE + CALL EXTCDE ( 12 ) + END IF +! + IF ( NRNL .NE. 1 ) THEN + WRITE (NDSE,1024) NRNL + CALL EXTCDE ( 13 ) + END IF +! + IF ( NRBT .NE. 1 ) THEN + WRITE (NDSE,1025) NRBT + CALL EXTCDE ( 14 ) + END IF +! + IF ( NRDB .NE. 1 ) THEN + WRITE (NDSE,1026) NRDB + CALL EXTCDE ( 15 ) + END IF +! + IF ( NRTR .NE. 1 ) THEN + WRITE (NDSE,1027) NRTR + CALL EXTCDE ( 16 ) + END IF +! + IF ( NRBS .NE. 1 ) THEN + WRITE (NDSE,1028) NRBS + CALL EXTCDE ( 17 ) + END IF +! + IF ( NRIC .GT. 1 ) THEN + WRITE (NDSE,1034) NRIC + CALL EXTCDE ( 19 ) + END IF +! + IF ( NRIS .GT. 1 ) THEN + WRITE (NDSE,1036) NRIS + CALL EXTCDE ( 26 ) + END IF + + +! +! 6.c Read namelist file or Pre-process namelists into scratch file +! + WRITE (NDSO,915) + IF (FLGNML) THEN + OPEN (NDSS,FILE=TRIM(FNMPRE)//TRIM(NML_GRID%NML),STATUS='OLD',FORM='FORMATTED') + ELSE + OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') + DO + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,'(A)',END=2001,ERR=2002) LINE + IF ( LINE(1:16) .EQ. 'END OF NAMELISTS' ) THEN + EXIT + ELSE + WRITE (NDSS,'(A)') LINE + ENDIF + END DO + END IF + WRITE (NDSO,916) +! +! 6.d Define Sin. +! 6.d.1 Stresses +! +#ifdef W3_FLX1 + WRITE (NDSO,810) +#endif +#ifdef W3_FLX2 + WRITE (NDSO,810) +#endif +! +#ifdef W3_FLX2 + CINXSI = 0.20 + NITTIN = 3 +#endif +#ifdef W3_FLX3 + CINXSI = 0.20 + NITTIN = 3 + CDMAX = 2.5E-3 + CTYPE = 0 +#endif +! +#ifdef W3_FLX3 + CALL READNL ( NDSS, 'FLX3', STATUS ) + WRITE (NDSO,810) STATUS + CDMAX = MAX ( 0. , CDMAX ) + IF ( CTYPE .EQ. 1 ) THEN + TYPEID = 'hyperbolic tangent' + ELSE + CTYPE = 0 + TYPEID = 'discontinuous ' + END IF + WRITE (NDSO,811) CDMAX*1.E3, TYPEID + CD_MAX = CDMAX + CAP_ID = CTYPE +#endif +! +#ifdef W3_FLX4 + CDFAC = 1.0 + CALL READNL ( NDSS, 'FLX4', STATUS ) + WRITE (NDSO,810) STATUS + WRITE (NDSO,811) CDFAC + FLX4A0 = CDFAC +#endif +#ifdef W3_FLX5 + WRITE (NDSO,810) +#endif +! +! 6.d.2 Linear input +! +#ifdef W3_LN0 + WRITE (NDSO,820) +#endif +#ifdef W3_SEED + WRITE (NDSO,820) +#endif +! +#ifdef W3_LN1 + CLIN = 80. + RFPM = 1. + RFHF = 0.5 +#endif +! +#ifdef W3_LN1 + CALL READNL ( NDSS, 'SLN1', STATUS ) + WRITE (NDSO,820) STATUS + CLIN = MAX (0.,CLIN) + RFPM = MAX (0.,RFPM) + RFHF = MAX(0.,MIN (1.,RFHF)) + WRITE (NDSO,821) CLIN, RFPM, RFHF + SLNC1 = CLIN * (DAIR/DWAT)**2 / GRAV**2 + FSPM = RFPM + FSHF = RFHF +#endif +! +! 6.d.3 Exponential input +! +#ifdef W3_ST0 + WRITE (NDSO,920) +#endif +! +#ifdef W3_ST1 + CINP = 0.25 +#endif +#ifdef W3_ST2 + ZWND = 10. + SWELLF = 0.100 + STABSH = 1.38 + STABOF = -0.01 + CNEG = -0.1 + CPOS = 0.1 + FNEG = 150. +#endif +! +#ifdef W3_ST3 + ZWND = 10. + ALPHA0 = 0.0095 + Z0MAX = 0.0 + BETAMAX = 1.2 ! default WAM4 / WAM4 + is 1.2 with rhow=1000 + SINTHP = 2. + SWELLF = 0. + ZALP = 0.0110 +#endif +! +#ifdef W3_ST4 + ZWND = 10. + ALPHA0 = 0.0095 + Z0MAX = 0.0 + Z0RAT = 0.04 + BETAMAX = 1.43 + SINTHP = 2. + SWELLF = 0.66 + SWELLFPAR = 1 + SWELLF2 = -0.018 + SWELLF3 = 0.022 + SWELLF4 = 1.5E5 + SWELLF5 = 1.2 + SWELLF6 = 0. + SWELLF7 = 360000. + TAUWSHELTER = 0.3 + ZALP = 0.006 + SINBR = 0. +#endif +! +#ifdef W3_ST6 + SINA0 = 0.09 + SINWS = 32.0 + SINFC = 6.0 +#endif +! +#ifdef W3_ST1 + CALL READNL ( NDSS, 'SIN1', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) CINP + SINC1 = 28. * CINP * DAIR / DWAT +#endif +! +#ifdef W3_ST2 + CALL READNL ( NDSS, 'SIN2', STATUS ) + WRITE (NDSO,920) STATUS + IF ( SWELLF.LT.0. .OR. SWELLF.GT.1. ) SWELLF = 1. + WRITE (NDSO,921) ZWND, SWELLF + IF ( STABSH .LT. 0.1 ) STABSH = 1. + IF ( CNEG*CPOS .EQ. 0. ) THEN + CNEG = 0. + CPOS = 0. + FNEG = 0. + FPOS = 0. + ELSE + CPOS = - ABS(CPOS) * ABS(CNEG)/CNEG + FNEG = - MAX(1.,ABS(FNEG)) + FPOS = FNEG * CNEG/CPOS + END IF +#endif +#ifdef W3_STAB2 + WRITE (NDSO,1921) STABSH, STABOF, CNEG, CPOS, FNEG, FPOS +#endif +#ifdef W3_ST2 + ZWIND = ZWND + FSWELL = SWELLF + SHSTAB = STABSH + OFSTAB = STABOF + CCNG = CNEG + CCPS = CPOS + FFNG = FNEG + FFPS = FPOS +#endif +! +#ifdef W3_ST3 + CALL READNL ( NDSS, 'SIN3', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, & + SWELLF + ZZWND = ZWND + AALPHA = ALPHA0 + BBETA = BETAMAX + SSINTHP = SINTHP + ZZ0MAX = Z0MAX + ZZALP = ZALP + SSWELLF(1) = SWELLF +#endif +! +#ifdef W3_ST4 + CALL READNL ( NDSS, 'SIN4', STATUS ) + WRITE (NDSO,920) STATUS + WRITE (NDSO,921) ALPHA0, BETAMAX, SINTHP, Z0MAX, ZALP, ZWND, TAUWSHELTER, & + SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, SWELLF5, & + SWELLF6, SWELLF7, Z0RAT + ZZWND = ZWND + AALPHA = ALPHA0 + BBETA = BETAMAX + SSINBR = SINBR + SSINTHP = SINTHP + ZZ0MAX = Z0MAX + ZZ0RAT = Z0RAT + ZZALP = ZALP + TTAUWSHELTER = TAUWSHELTER + SSWELLF(1) = SWELLF + SSWELLF(2) = SWELLF2 + SSWELLF(3) = SWELLF3 + SSWELLF(4) = SWELLF4 + SSWELLF(5) = SWELLF5 + SSWELLF(6) = SWELLF6 + SSWELLF(7) = SWELLF7 + SSWELLFPAR = SWELLFPAR +#endif +! +#ifdef W3_ST6 + CALL READNL ( NDSS, 'SIN6', STATUS ) + WRITE (NDSO,920) STATUS + SIN6A0 = SINA0 + SIN6WS = SINWS + SIN6FC = SINFC + J = 1 + IF ( SIN6A0.LE.0. ) J = 2 + WRITE (NDSO,921) YESXNO(J), SIN6A0, SIN6WS, SIN6FC +#endif +! +! 6.e Define Snl. +! +#ifdef W3_NL0 + WRITE (NDSO,922) +#endif +! +#ifdef W3_NL1 + LAMBDA = 0.25 + IF ( FLTC96 ) THEN + NLPROP = 1.00E7 + ELSE IF ( FLST4 ) THEN + NLPROP = 2.50E7 + ELSE IF ( FLST6 ) THEN + NLPROP = 3.00E7 + ELSE + NLPROP = 2.78E7 + END IF +#endif +! +#ifdef W3_NL1 + KDCONV = 0.75 + KDMIN = 0.50 + SNLCS1 = 5.5 + SNLCS2 = 0.833 + SNLCS3 = -1.25 +#endif +! +#ifdef W3_NL1 + CALL READNL ( NDSS, 'SNL1', STATUS ) + WRITE (NDSO,922) STATUS + WRITE (NDSO,923) LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 + SNLC1 = NLPROP / GRAV**4 + LAM = LAMBDA + KDCON = KDCONV + KDMN = KDMIN + SNLS1 = SNLCS1 + SNLS2 = SNLCS2 + SNLS3 = SNLCS3 +#endif +! +#ifdef W3_ST0 + FACHF = 5. +#endif +#ifdef W3_ST1 + FACHF = 4.5 +#endif +#ifdef W3_ST2 + FACHF = 5. +#endif +#ifdef W3_ST3 + FACHF = 5. +#endif +#ifdef W3_ST4 + FACHF = 5. +#endif +#ifdef W3_ST6 + FACHF = 5. +#endif +#ifdef W3_NL2 + IQTYPE = 2 + TAILNL = -FACHF + NDEPTH = 0 +#endif +#ifdef W3_NL3 + NQDEF = 0 + MSC = 0. + NSC = -3.5 + KDFD = 0.20 + KDFS = 5.00 +#endif +#ifdef W3_NL4 + INDTSA = 1 + ALTLP = 2 +#endif +#ifdef W3_NL5 + NL5DPT = 3000. + NL5OML = 0.10 + NL5DIS = 0 + NL5KEV = 0 + NL5IPL = 1 + NL5PMX = 100 +#endif +#ifdef W3_NLS + A34 = 0.05 + FHFC = 1.E10 + DNM = 0.25 + FC1 = 1.25 + FC2 = 1.50 + FC3 = 6.00 +#endif +! +#ifdef W3_NL2 + CALL READNL ( NDSS, 'SNL2', STATUS ) + WRITE (NDSO,922) STATUS + TAILNL = MIN ( MAX ( TAILNL, -5. ) , -4. ) + IF ( IQTYPE .EQ. 3 ) THEN + WRITE (NDSO,923) 'Shallow water', TAILNL + ELSE IF ( IQTYPE .EQ. 2 ) THEN + WRITE (NDSO,923) 'Deep water with scaling', TAILNL + ELSE + WRITE (NDSO,923) 'Deep water', TAILNL + IQTYPE = 1 + END IF +#endif +! +#ifdef W3_NL2 + IF ( IQTYPE .NE. 3 ) THEN + NDEPTH = 1 + ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) + DPTHNL => MPARS(1)%SNLPS%DPTHNL + DPTHNL = 1000. + ELSE + IF ( NDEPTH .EQ. 0 ) NDEPTH = 7 + NDEPTH = MAX ( 1 , NDEPTH ) + ALLOCATE ( MPARS(1)%SNLPS%DPTHNL(NDEPTH) ) + DPTHNL => MPARS(1)%SNLPS%DPTHNL + DPTHNL(1) = 640. + DPTHNL(NDEPTH) = 10. + IF ( NDEPTH .GT. 1 ) THEN + DPTFAC = (DPTHNL(NDEPTH)/DPTHNL(1))**(1./(REAL(NDEPTH-1))) + DO IDEPTH=2, NDEPTH-1 + DPTHNL(IDEPTH) = DPTFAC*DPTHNL(IDEPTH-1) + END DO + END IF + CALL READNL ( NDSS, 'ANL2', STATUS ) + WRITE (NDSO,1923) NDEPTH, DPTHNL(1:MIN(5,NDEPTH)) + IF (NDEPTH .GT. 5 )WRITE (NDSO,2923) DPTHNL(6:NDEPTH) + END IF + WRITE (NDST,*) + IQTPE = IQTYPE + NDPTHS = NDEPTH + NLTAIL = TAILNL +#endif +! +#ifdef W3_NL3 + CALL READNL ( NDSS, 'SNL3', STATUS ) + WRITE (NDSO,922) STATUS +#endif +!!/NL3 MSC = MAX ( 0. , MIN ( 8. , MSC ) ) ! Disabled HLT ca. 2009 +#ifdef W3_NL3 + KDFD = MAX ( 0.001 , MIN ( 10. , KDFD ) ) + KDFS = MAX ( KDFD , MIN ( 10. , KDFS ) ) + WRITE (NDSO,923) MSC, NSC, KDFD, KDFS +#endif +! +#ifdef W3_NL3 + NQDEF = MAX ( 0 , NQDEF ) + IF ( NQDEF .EQ. 0 ) THEN + NQDEF = 1 + QPARMS(1:5) = [ 0.25 , 0.00, -1., 1.E7, 0.00 ] + ELSE + DO J=1, NQDEF + QPARMS((J-1)*5+1:J*5) = [ 0.25, 0.00, -1., 1.E7, 1.E6 ] + END DO + CALL READNL ( NDSS, 'ANL3', STATUS ) + END IF + DO J=1, NQDEF + QPARMS((J-1)*5+1) = MAX(0.,MIN (LAMMAX,QPARMS((J-1)*5+1))) + QPARMS((J-1)*5+2) = MAX(0.,MIN (QPARMS((J-1)*5+1), & + QPARMS((J-1)*5+2))) + QPARMS((J-1)*5+3) = MIN (DELTHM,QPARMS((J-1)*5+3)) + QPARMS((J-1)*5+4) = MAX (0.,QPARMS((J-1)*5+4)) + QPARMS((J-1)*5+5) = MAX (0.,QPARMS((J-1)*5+5)) + END DO + WRITE (NDSO,1923) NQDEF + WRITE (NDSO,2923) QPARMS(1:NQDEF*5) + WRITE (NDSO,*) + SNLNQ = NQDEF + SNLMSC = MSC + SNLNSC = NSC + SNLSFD = SQRT ( KDFD * TANH(KDFD) ) + SNLSFS = SQRT ( KDFS * TANH(KDFS) ) + ALLOCATE ( MPARS(1)%SNLPS%SNLL(NQDEF), & + MPARS(1)%SNLPS%SNLM(NQDEF), & + MPARS(1)%SNLPS%SNLT(NQDEF), & + MPARS(1)%SNLPS%SNLCD(NQDEF), & + MPARS(1)%SNLPS%SNLCS(NQDEF) ) + SNLL => MPARS(1)%SNLPS%SNLL + SNLL = QPARMS(1:NQDEF*5:5) + SNLM => MPARS(1)%SNLPS%SNLM + SNLM = QPARMS(2:NQDEF*5:5) + SNLT => MPARS(1)%SNLPS%SNLT + SNLT = QPARMS(3:NQDEF*5:5) + SNLCD => MPARS(1)%SNLPS%SNLCD + SNLCD = QPARMS(4:NQDEF*5:5) + SNLCS => MPARS(1)%SNLPS%SNLCS + SNLCS = QPARMS(5:NQDEF*5:5) +#endif +! +#ifdef W3_NL4 + CALL READNL ( NDSS, 'SNL4', STATUS ) + WRITE (NDSO,922) STATUS + WRITE (NDSO,923) INDTSA, ALTLP + ITSA = INDTSA + IALT = ALTLP +#endif +! +#ifdef W3_NL5 + CALL READNL ( NDSS, 'SNL5', STATUS ) + WRITE (NDSO,922) STATUS + NL5DPT = MAX(0., MIN(NL5DPT, 3000.)) + NL5DIS = MAX(0 , MIN(NL5DIS, 1)) + NL5KEV = MAX(0 , MIN(NL5KEV, 1)) + NL5IPL = MAX(0 , MIN(NL5IPL, 1)) + IF (NL5DIS .EQ. 1) NL5IPL = 0 + IF (NL5PMX .GT. 0) NL5PMX = MAX(10, NL5PMX) + WRITE (NDSO,923) NL5DPT, NL5OML, NL5DIS, NL5KEV, NL5IPL, NL5PMX + QR5DPT = NL5DPT + QR5OML = NL5OML + QI5DIS = NL5DIS + QI5KEV = NL5KEV + QI5IPL = NL5IPL + QI5PMX = NL5PMX +#endif +! +#ifdef W3_NLS + CALL READNL ( NDSS, 'SNLS', STATUS ) + WRITE (NDSO,9922) STATUS + A34 = MAX ( 0. , MIN ( A34 , ABMAX ) ) + FHFC = MAX ( 0. , FHFC ) + DNM = MAX ( 0., DNM ) + WRITE (NDSO,9923) A34, (XFR-1.)*A34, FHFC, DNM, FC1, FC2, FC3 + CNLSA = A34 + CNLSC = FHFC + CNLSFM = DNM + CNLSC1 = FC1 + CNLSC2 = FC2 + CNLSC3 = FC3 +#endif +! +! 6.f Define Sds. +! +#ifdef W3_ST0 + WRITE (NDSO,924) +#endif +! +#ifdef W3_ST1 + CDIS = -2.36E-5 + APM = 3.02E-3 +#endif +#ifdef W3_ST2 + SDSA0 = 4.8 + SDSA1 = 1.7e-4 + SDSA2 = 2.0 + SDSB0 = 0.3e-3 + SDSB1 = 0.47 + PHIMIN = 0.003 + SDSALN = 0.002 + FPIMIN = 0.009 +#endif +#ifdef W3_ST3 + SDSC1 = -2.1 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -4.5 + WNMEANP = 0.5 !! This is Bidlot et al. 2005, Otherwise WAM4 uses -0.5 + FXFM3 = 2.5 + FXPM3 = 4. + WNMEANPTAIL = 0.5 + SDSDELTA1 = 0.4 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 + SDSDELTA2 = 0.6 !! This is Bidlot et al. 2005, Otherwise WAM4 uses 0.5 +#endif +! +#ifdef W3_ST4 + WNMEANP = 0.5 ! taken from Bidlot et al. 2005 + FXFM3 = 2.5 + FXFMAGE = 0. + FXPM3 = 4. + WNMEANPTAIL = -0.5 + SDSBCHOICE =1 ! 1: Ardhuin et al., 2: Filipot & Ardhuin, 3: Romero + SDSC2 = -2.2E-5 ! -3.8 for Romero + SDSCUM = -0.40344 + SDSC4 = 1. + SDSC5 = 0. + SDSNUW = 0. + SDSC6 = 0.3 + SDSBR = 0.90E-3 ! 0.005 for Romero + SDSBRFDF = 0 + SDSBRF1 = 0.5 + SDSP = 2. ! this is now fixed in w3sds4, should be cleaned up + SDSDTH = 80. + SDSCOS = 2. + SDSISO = 2 + SDSBM0 = 1. + SDSBM1 = 0. + SDSBM2 = 0. + SDSBM3 = 0. + SDSBM4 = 0. + SDSBCK = 0. + SDSABK = 1.5 + SDSPBK = 4. + SDSBINT = 0.3 + SDSHCK = 1.5 + WHITECAPWIDTH = 0.3 + SDSSTRAIN = 0. + SDSFACMTF = 400 ! MTF factor for Lambda , Romero (2019) + SDSSTRAINA = 15. + SDSSTRAIN2 = 0. + WHITECAPDUR = 0.56 ! breaking duration factor +! b (strength of breaking) + SDSBT = 1.100E-3 ! B_T (sturation threshold for dissipation rate b) +! Lambda parameters + SDSL = 3.5000e-05 ! L scaling +! MTF + SPMSS = 0.5 ! cmss^SPMSS + SDSNMTF = 1.5 ! MTF power + SDSCUMP = 2. +! MW + SDSMWD = .9 ! new AFo + SDSMWPOW = 1. ! (k )^pow + SDKOF = 3. ! ko factor such that ko= g (SDKOF/(28 us))^2 +#endif +! +#ifdef W3_ST6 + SDSET = .TRUE. + SDSA1 = 4.75E-06 + SDSP1 = 4 + SDSA2 = 7.00E-05 + SDSP2 = 4 + CSTB1 = .FALSE. + SWLB1 = 0.41E-02 +#endif +! +#ifdef W3_ST1 + CALL READNL ( NDSS, 'SDS1', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) CDIS, APM + SDSC1 = TPI * CDIS / APM**2 +#endif +! +#ifdef W3_ST2 + CALL READNL ( NDSS, 'SDS2', STATUS ) + WRITE (NDSO,924) STATUS + IF ( PHIMIN .LE. 0. ) THEN + SDSB2 = 0. + SDSB3 = 0. + PHIMIN = SDSB0 + SDSB1*FPIMIN + ELSE + FPIA = ( PHIMIN - SDSB0 ) / SDSB1 + IF ( FPIA .LT. FPIMIN ) THEN + SDSB3 = 4. + SDSB2 = FPIMIN**SDSB3 * (PHIMIN-SDSB0-SDSB1*FPIMIN) + ELSE + FPIB = MAX ( FPIA-0.0025 , FPIMIN ) + DPHID = MAX ( PHIMIN - SDSB0 - SDSB1*FPIB , 1.E-15 ) + SDSB3 = MIN ( 10. , SDSB1*FPIB / DPHID ) + SDSB2 = FPIB**SDSB3 * DPHID + FPIMIN = FPIB + END IF + END IF + WRITE (NDSO,925) SDSA0, SDSA1, SDSA2, & + SDSB0, SDSB1, SDSB2, SDSB3, FPIMIN, PHIMIN + CDSA0 = SDSA0 + CDSA1 = SDSA1 + CDSA2 = SDSA2 + CDSB0 = SDSB0 + CDSB1 = SDSB1 + CDSB2 = SDSB2 + CDSB3 = SDSB3 +#endif +! +#ifdef W3_ST3 + CALL READNL ( NDSS, 'SDS3', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) SDSC1, WNMEANP, SDSDELTA1, & + SDSDELTA2 + SSDSC1 = SDSC1 + WWNMEANP = WNMEANP + FFXFM = FXFM3 * TPI + FFXPM = FXPM3 * GRAV / 28. + WWNMEANPTAIL = WNMEANPTAIL + DDELTA1 = SDSDELTA1 + DDELTA2 = SDSDELTA2 +#endif +! +#ifdef W3_ST4 + CALL READNL ( NDSS, 'SDS4', STATUS ) + WRITE (NDSO,924) STATUS + WRITE (NDSO,925) SDSC2, SDSBCK, SDSCUM, WNMEANP + SSDSC(1) = REAL(SDSBCHOICE) + SSDSC(2) = SDSC2 + SSDSC(3) = SDSCUM + SSDSC(4) = SDSC4 + SSDSC(5) = SDSC5 + SSDSC(6) = SDSC6 + SSDSC(7) = WHITECAPWIDTH + SSDSC(8) = SDSSTRAIN ! Straining constant ... + SSDSC(9) = SDSL + SSDSC(10) = SDSSTRAINA*NTH/360. ! angle Aor enhanced straining + SSDSC(11) = SDSSTRAIN2 ! straining constant for directional part + SSDSC(12) = SDSBT + SSDSC(13) = SDSMWD + SSDSC(14) = SPMSS + SSDSC(15) = SDSMWPOW + SSDSC(16) = SDKOF + SSDSC(17) = WHITECAPDUR + SSDSC(18) = SDSFACMTF + SSDSC(19) = SDSNMTF + SSDSC(20) = SDSCUMP + SSDSC(21) = SDSNUW +#endif +! +#ifdef W3_ST4 + SSDSBR = SDSBR + SSDSBRF1 = SDSBRF1 + SSDSBRFDF= SDSBRFDF + SSDSBM(0) = SDSBM0 + SSDSBM(1) = SDSBM1 + SSDSBM(2) = SDSBM2 + SSDSBM(3) = SDSBM3 + SSDSBM(4) = SDSBM4 + SSDSBT = SDSBT + SSDSISO = SDSISO + SSDSCOS = SDSCOS + SSDSP = SDSP + SSDSDTH = SDSDTH + WWNMEANP = WNMEANP + FFXFM = FXFM3 * TPI + FFXFA = FXFMAGE * TPI + FFXPM = FXPM3 * GRAV / 28. + WWNMEANPTAIL = WNMEANPTAIL + SSDSBCK = SDSBCK + SSDSABK = SDSABK + SSDSPBK = SDSPBK + SSDSBINT = SDSBINT + SSDSHCK = SDSHCK +#endif +! +#ifdef W3_ST6 + CALL READNL ( NDSS, 'SDS6', STATUS ) + WRITE (NDSO,924) STATUS + SDS6ET = SDSET + SDS6A1 = SDSA1 + SDS6P1 = SDSP1 + SDS6A2 = SDSA2 + SDS6P2 = SDSP2 + J = 2 + IF (SDSET) J = 1 + WRITE (NDSO,925) YESXNO(J), YESXNO(3-J), SDS6A1, SDS6P1, SDS6A2, SDS6P2 + + CALL READNL ( NDSS, 'SWL6', STATUS ) + WRITE (NDSO,937) STATUS + J = 1 + SWL6S6 = SWLB1.GT.0.0 + IF (.NOT.SWL6S6) J = 2 + SWL6B1 = SWLB1 + SWL6CSTB1 = CSTB1 + IF (CSTB1) THEN + WRITE (NDSO,940) YESXNO(J), '(constant) ' ,SWL6B1 + ELSE + WRITE (NDSO,940) YESXNO(J), '(steepness dependent)' ,SWL6B1 + END IF +#endif +! +! 6.g Define Sbt. +! +#ifdef W3_BT0 + WRITE (NDSO,926) +#endif +#ifdef W3_BT4 + WRITE (NDSO,926) +#endif +! +#ifdef W3_BT1 + GAMMA = -0.067 +#endif +! +#ifdef W3_BT1 + CALL READNL ( NDSS, 'SBT1', STATUS ) + WRITE (NDSO,926) STATUS + WRITE (NDSO,927) GAMMA + SBTC1 = 2. * GAMMA / GRAV +#endif +! +#ifdef W3_BT4 + SEDMAPD50=.FALSE. + SED_D50_UNIFORM=2.E-4 ! default grain size: medium sand 200 microns + RIPFAC1=0.4 ! A1 in Ardhuin et al. 2003 + RIPFAC2=-2.5 ! A2 in Ardhuin et al. 2003 + RIPFAC3=1.2 ! A3 in Ardhuin et al. 2003 + RIPFAC4=0.05 ! A4 in Ardhuin et al. 2003 + SIGDEPTH=0.05 + BOTROUGHMIN=0.01 + BOTROUGHFAC=1.00 + CALL READNL ( NDSS, 'SBT4', STATUS ) + WRITE (NDSO,926) STATUS + WRITE (NDSO,927) SEDMAPD50, SED_D50_UNIFORM, & + RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4,SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC + SBTCX(1)=RIPFAC1 + SBTCX(2)=RIPFAC2 + SBTCX(3)=RIPFAC3 + SBTCX(4)=RIPFAC4 + SBTCX(5)=SIGDEPTH + SBTCX(6)=BOTROUGHMIN + SBTCX(7)=BOTROUGHFAC +#endif +! +! +! 6.h Define Sdb. +! +#ifdef W3_DB0 + WRITE (NDSO,928) +#endif +! +#ifdef W3_DB1 + BJALFA = 1. + BJGAM = 0.73 + BJFLAG = .TRUE. +#endif +! +#ifdef W3_DB1 + CALL READNL ( NDSS, 'SDB1', STATUS ) + WRITE (NDSO,928) STATUS + BJALFA = MAX ( 0. , BJALFA ) + BJGAM = MAX ( 0. , BJGAM ) + WRITE (NDSO,929) BJALFA, BJGAM + IF ( BJFLAG ) THEN + WRITE (NDSO,*) ' Using Hmax/d ratio only.' + ELSE + WRITE (NDSO,*) & + ' Using Hmax/d in Miche style formulation.' + END IF + WRITE (NDSO,*) + SDBC1 = BJALFA + SDBC2 = BJGAM + FDONLY = BJFLAG +#endif +! +! +#ifdef W3_UOST + UOSTFILELOCAL = 'obstructions_local.'//ADJUSTL(TRIM(GNAME))//'.in' + UOSTFILESHADOW = 'obstructions_shadow.'//ADJUSTL(TRIM(GNAME))//'.in' + UOSTFACTORLOCAL = 1 + UOSTFACTORSHADOW = 1 + CALL READNL ( NDSS, 'UOST', STATUS ) + WRITE (NDSO,4500) STATUS + WRITE (NDSO,4501) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & + UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif +! +! 6.i Define Str. +! +#ifdef W3_TR0 + WRITE (NDSO,930) +#endif +! +! 6.j Define Sbs. +! +#ifdef W3_BS0 + WRITE (NDSO,932) +#endif +#ifdef W3_BS1 + WRITE (NDSO,932) +#endif +! +! 6.k Define Sxx and Sic. +! +#ifdef W3_IC1 + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & + //'user-specified ki values.',' Required ' & + //'field input: ice parameter 1.' +#endif +! +#ifdef W3_IC2 + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using ' & + //'under-ice boundary layer method.',' Required ' & + //'field input: ice parameters 1 and 2.' +#endif +! +#ifdef W3_IC3 + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using '& + //'Wang and Shen method.',' '& + //'Required field input: ice parameters 1, 2, 3 and 4.' +#endif +! +#ifdef W3_IC4 + WRITE (NDSO,935) + WRITE(NDSO,'(A/A)')' Sice will be calculated using '& + //'Empirical method.',' '& + //'Required field input: ice parameters (varies).' +#endif +! +#ifdef W3_IC5 + WRITE (NDSO,935) + WRITE(NDSO,'(A/A/)')' Sice will be calculated using '& + //'effective medium models.',' '& + //'Required field input: ice parameters 1, 2, 3 and 4.' +#endif +! +! 6.l Read unstructured data +! initialisation of logical related to unstructured grid + UGOBCAUTO = .TRUE. + UGBCCFL = .TRUE. + UGOBCDEPTH= -10. + UGOBCOK = .FALSE. + UGOBCFILE = 'unset' + EXPFSN = .TRUE. + EXPFSPSI = .FALSE. + EXPFSFCT = .FALSE. + IMPFSN = .FALSE. + IMPTOTAL = .FALSE. + EXPTOTAL = .FALSE. + IMPREFRACTION = .FALSE. + IMPFREQSHIFT = .FALSE. + IMPSOURCE = .FALSE. + SETUP_APPLY_WLV = .FALSE. + SOLVERTHR_SETUP=1E-14 + CRIT_DEP_SETUP=0.1 + JGS_TERMINATE_MAXITER = .TRUE. + JGS_TERMINATE_DIFFERENCE = .TRUE. + JGS_TERMINATE_NORM = .FALSE. + JGS_LIMITER = .FALSE. + JGS_BLOCK_GAUSS_SEIDEL = .TRUE. + JGS_USE_JACOBI = .TRUE. + JGS_MAXITER=100 + JGS_PMIN = 1 + JGS_DIFF_THR = 1.E-10 + JGS_NORM_THR = 1.E-20 + JGS_NLEVEL = 0 + JGS_SOURCE_NONLINEAR = .FALSE. +! read data from the unstructured devoted namelist + CALL READNL ( NDSS, 'UNST', STATUS ) + + B_JGS_USE_JACOBI = JGS_USE_JACOBI + B_JGS_TERMINATE_MAXITER = JGS_TERMINATE_MAXITER + B_JGS_TERMINATE_DIFFERENCE = JGS_TERMINATE_DIFFERENCE + B_JGS_TERMINATE_NORM = JGS_TERMINATE_NORM + B_JGS_LIMITER = JGS_LIMITER + B_JGS_BLOCK_GAUSS_SEIDEL = JGS_BLOCK_GAUSS_SEIDEL + B_JGS_MAXITER = JGS_MAXITER + B_JGS_PMIN = JGS_PMIN + B_JGS_DIFF_THR = JGS_DIFF_THR + B_JGS_NORM_THR = JGS_NORM_THR + B_JGS_NLEVEL = JGS_NLEVEL + B_JGS_SOURCE_NONLINEAR = JGS_SOURCE_NONLINEAR + + IF ((EXPFSN .eqv. .FALSE.).and.(EXPFSPSI .eqv. .FALSE.) & + .and.(EXPFSFCT .eqv. .FALSE.) & + .and.(IMPFSN .eqv. .FALSE.) & + .and.(EXPTOTAL .eqv. .FALSE.) & + .and.(IMPTOTAL .eqv. .FALSE.)) THEN + EXPFSN=.TRUE. ! This is the default scheme ... + END IF + nbSel=0 + + IF (EXPFSN) nbSel=nbSel+1 + IF (EXPFSPSI) nbSel=nbSel+1 + IF (EXPFSFCT) nbSel=nbSel+1 + IF (IMPFSN) nbSel=nbSel+1 + IF (IMPTOTAL) nbSel=nbSel+1 + IF (EXPTOTAL) nbSel=nbSel+1 + + IF (GTYPE .EQ. UNGTYPE) THEN + IF (nbSel .ne. 1) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN WW3_GRID:' + IF (nbSel .gt. 1) THEN + WRITE (NDSE,*) 'More than one scheme selected' + ELSE IF (nbSel .eq. 0) THEN + WRITE (NDSE,*) 'no scheme selected' + END IF + WRITE (NDSE,*)'Select only one of EXPFSN, EXPFSFCT, EXPFSPSI' + WRITE (NDSE,*)'IMPFSN, IMPTOTAL' + CALL EXTCDE ( 30 ) + END IF + END IF +! +! 6.m Select propagation scheme +! + WRITE (NDSO,950) +! + NRPROP = 0 + FLPROP = .TRUE. + PNAME = ' ' +#ifdef W3_PR0 + PNAME = 'Not defined ' + NRPROP = NRPROP + 1 + FLPROP = .FALSE. +#endif +#ifdef W3_PR1 + PNAME = 'First order upstream ' + NRPROP = NRPROP + 1 +#endif +#ifdef W3_UQ + PNAME = '3rd order UQ' +#endif +#ifdef W3_UNO + PNAME = '2nd order UNO' +#endif + J = LEN_TRIM(PNAME) +#ifdef W3_PR2 + PNAME = PNAME(1:J)//' + GSE diffusion ' + NRPROP = NRPROP + 1 +#endif +#ifdef W3_PR3 + PNAME = PNAME(1:J)//' + GSE averaging ' + NRPROP = NRPROP + 1 +#endif +! +#ifdef W3_SMC + PNAME = 'UNO2 on SMC grid + diffusion ' +#endif +! + IF ( (FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. .NOT. FLPROP ) THEN + WRITE (NDSE,1030) + CALL EXTCDE ( 20 ) + END IF +! + IF ( .NOT.(FLCX.OR.FLCY.OR.FLCTH.OR.FLCK) .AND. FLPROP ) THEN + WRITE (NDSE,1031) + END IF +! + IF ( NRPROP.EQ.0 ) THEN + WRITE (NDSE,1032) + CALL EXTCDE ( 21 ) + END IF +! + IF ( NRPROP .GT. 1 ) THEN + WRITE (NDSE,1033) NRPROP + CALL EXTCDE ( 22 ) + END IF +! +! 6.m Parameters for propagation scheme +! + WRITE (NDSO,951) PNAME +! + CFLTM = 0.7 +! +#ifdef W3_PR2 + DTIME = 0. + LATMIN = 70. +#endif +! +#ifdef W3_SMC + !! Default values of SMC grid parameters. JGLi06Apr2021 + NCel = 1 + NUFc = 1 + NVFc = 1 + NGLO = 1 + NARC = 1 + NBGL = 1 + NBAC = 1 + LvSMC = 1 + MRFct = 1 + ISHFT = 0 + JEQT = 0 + NBISMC = 0 + CFLSM = 0.7 + DTIMS = 360.0 + RFMAXD = 36.0 + UNO3 = .FALSE. + AVERG = .TRUE. + SEAWND = .FALSE. + Arctic = .FALSE. +#endif +! +#ifdef W3_PR3 + WDTHCG = 1.5 + WDTHTH = WDTHCG +#endif +! +#ifdef W3_PR1 + CALL READNL ( NDSS, 'PRO1', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLTM = MAX ( 0. , CFLTM ) + WRITE (NDSO,953) CFLTM +#endif +! +#ifdef W3_PR2 + CALL READNL ( NDSS, 'PRO2', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLTM = MAX ( 0. , CFLTM ) + DTIME = MAX ( 0. , DTIME ) + LATMIN = MIN ( 89. , ABS(LATMIN) ) + CLATMN = COS ( LATMIN * DERA ) + IF ( DTIME .EQ. 0. ) THEN + WRITE (NDSO,953) CFLTM, LATMIN + ELSE + WRITE (NDSO,954) CFLTM, DTIME/3600., LATMIN + END IF + DTME = DTIME +#endif +! +#ifdef W3_SMC + CALL READNL ( NDSS, 'PSMC', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' + WRITE (NDSO,952) STATUS(1:18) + CFLSM = MAX ( 0. , CFLSM ) + DTIMS = MAX ( 0. , DTIMS ) + RFMAXD = MIN ( 80.0, ABS(RFMAXD) ) + Refran = RFMAXD * DERA + !! Printing out SMC grid parameters. + WRITE (NDSO,1950) + WRITE (NDSO,1951) PNSMC + WRITE (NDSO,1953) CFLSM, DTIMS/3600., RFMAXD +#endif +! +#ifdef W3_SMC + FUNO3 = UNO3 + FVERG = AVERG + FSWND = SEAWND + ARCTC = Arctic + NBSMC = NBISMC + IF( FUNO3 ) WRITE (NDSO,*) & + " Advection use 3rd order UNO3 instead of UNO2 scheme." + IF( FVERG ) WRITE (NDSO,*) & + " Extra 1-2-1 average smoothing activated on SMC grid." + IF( FSWND ) WRITE (NDSO,*) & + " Sea-point only wind input is required for SMC grid. " + IF( ARCTC ) WRITE (NDSO,*) & + " Arctic polar part will be appended to this SMC grid." + NRLv = LvSMC + WRITE (NDSO,4001) NRLv + WRITE (NDSO,4002) JEQT + WRITE (NDSO,4302) ISHFT + WRITE (NDSO,4003) NBSMC +#endif +! +#ifdef W3_PR3 + CALL READNL ( NDSS, 'PRO3', STATUS ) + IF ( STATUS(18:18) .EQ. ':' ) STATUS(18:18) = ' ' +#endif + IF (GTYPE.NE.UNGTYPE) THEN +#ifdef W3_PR3 + WRITE (NDSO,952) STATUS(1:18) + CFLTM = MAX ( 0. , CFLTM ) + WRITE (NDSO,953) CFLTM, WDTHCG + IF ( WDTHCG*(XFR-1.) .GT. 1. ) WRITE (NDSO,955) 1./(XFR-1.) + WRITE (NDSO,954) WDTHTH + IF ( WDTHTH*DTH .GT. 1. ) WRITE (NDSO,955) 1./DTH + WRITE (NDSO,*) +#endif + ENDIF +#ifdef W3_PR3 + WDCG = WDTHCG + WDTH = WDTHTH +#endif +! + CTMAX = CFLTM +! +#ifdef W3_RTD + ! Set/ read in rotation values - these will be written out + ! later with the rest of the grid info + ! Default is a non-rotated lat-lon grid + PLAT = 90. + PLON = -180. + UNROT = .FALSE. + CALL READNL ( NDSS, 'ROTD', STATUS ) + PLON = MOD( PLON + 180., 360. ) - 180. + ! Ensure that a grid with pole at the geographic North is standard lat-lon + IF ( PLAT == 90. .AND. ( PLON /= -180. .OR. UNROT ) ) THEN + WRITE( NDSE, 1052 ) + CALL EXTCDE ( 33 ) + ENDIF + ! Default poles of output b. c. are non-rotated: + BPLAT = 90. + BPLON = -180. + CALL READNL ( NDSS, 'ROTB', STATUS ) + ! A b. c. dest. grid with pole at the geographic North must be non-rotated + DO I=1,9 + IF ( BPLAT(I) == 90. ) THEN + ! Require BPLON(I) == -180., but don't blaim the user if BPLON(I) == 180. + IF ( BPLON(I) == 180. ) BPLON(I) = -180. + IF ( BPLON(I) == -180. ) CYCLE + END IF + IF ( BPLAT(I) < 90. ) CYCLE + WRITE( NDSE, 1053 ) + CALL EXTCDE ( 34 ) + END DO +#endif +! +! 6.n Set miscellaneous parameters (ice, seeding, numerics ... ) +! + CICE0 = 0.5 + CICEN = 0.5 + LICE = 0. + ICEHFAC= 1.0 + ICEHMIN= 0.2 ! the 0.2 value is arbitrary and needs to be tuned. + ICEHINIT= 0.5 + ICESLN = 1.0 + ICEWIND= 1.0 + ICESNL = 1.0 + ICESDS = 1.0 + ICEHDISP= 0.6 ! Prevent from convergence crash in w3dispmd in the presence of ice, should be tuned + ICEDDISP= 80 + ICEFDISP= 2 + GSHIFT = 0.0D0 + PMOVE = 0.5 + XSEED = 1. + FLAGTR = 0 + XP = 0.15 + XR = 0.10 + XFILT = 0.05 + IHM = 100 + HSPM = 0.05 + WSM = 1.7 + WSC = 0.333 + FLC = .TRUE. + TRCKCMPR = .TRUE. + NOSW = 5 +! +! Gas fluxes +! + AIRCMIN = 2.0 ! cmin for whitecap coverage and entrained air + AIRGB = 0.2 ! volume of entrained air constant (Deike et al. 2017) +! +#ifdef W3_NCO +! NCEP operations retains first three swell systems. + NOSW=3 +#endif + PTM = 1 ! Default to standard WW3 partitioning. C. Bunney + PTFC = 0.1 ! Part. method 5 cutoff freq default. C. Bunney + FMICHE = 1.6 + RWNDC = 1. + WCOR1 = 99. + WCOR2 = 0. + BTBET = 1.2 ! β for c / [U cos(θ - φ)] < β +! Variables for Space-Time Extremes +! Default negative values make w3iogomd switch off space-time extremes +! forces user to provide NAMELIST if wanting to compute STE parameters + STDX = -1. + STDY = -1. + STDT = -1. + ICEDISP = .FALSE. + CALTYPE = 'standard' +! Variables for 3D array output + E3D=0 + I1E3D=1 + I2E3D=NK + P2SF = 0 + I1P2SF = 1 + I2P2SF = 15 + US3D = 0 + I1US3D = 1 + I2US3D = NK + USSP=0 + IUSSP=1 + STK_WN(:)=0.0 + STK_WN(1)=TPI/100. !Set default decay of 100 m for Stokes drift + TH1MF=0 + I1TH1M=1 + I2TH1M=NK + STH1MF=0 + I1STH1M=1 + I2STH1M=NK + TH2MF=0 + I1TH2M=1 + I2TH2M=NK + STH2MF=0 + I1STH2M=1 + I2STH2M=NK +! + FACBERG=1. +#ifdef W3_IS0 + WRITE (NDSO,944) +#endif +#ifdef W3_IS1 + ISC1 = 1. + ISC2 = 0. + CALL READNL ( NDSS, 'SIS1', STATUS ) + WRITE (NDSO,945) STATUS + WRITE (NDSO,946) ISC1, ISC2 + IS1C1 = ISC1 + IS1C2 = ISC2 +#endif +#ifdef W3_IS2 + ISC1 = 1. + IS2C2 = 0. ! 0.025 + IS2C3 = 0. ! 2.4253 + IS2CONC = 0. + IS2BACKSCAT = 1. + IS2BREAK = .FALSE. + IS2BREAKF = 3.6 + IS2FLEXSTR=6.00E+05 ! value used in Ardhuin et al. 2020 + IS2ISOSCAT=.TRUE. ! uses isotropic back-scatter + IS2DISP=.FALSE. !not dispersion only attenuation following Liu disp. eq. + IS2DUPDATE=.TRUE. + IS2FRAGILITY=0.9 + IS2DMIN=20 + IS2DAMP=0. + IS2CREEPB=0. + IS2CREEPC=0.4 ! This gives an impact of break-up over a wider freq. range +#endif +! ! compared to the 0.2 value in Boutin et al. 2018 +#ifdef W3_IS2 + IS2CREEPD=0.5 + IS2CREEPN=3.0 + IS2BREAKE=1. + IS2WIM1=1. + IS2ANDISB=.TRUE. !anelastic instead of inelastic dissipation if IS2CREEPB>0 + IS2ANDISE=0.55 !energy of activation + IS2ANDISD=2.0E-9 !see Ardhuin et al. 2020 + IS2ANDISN=1. !dependency on stress. Equal to 1 normally? + CALL READNL ( NDSS, 'SIS2', STATUS ) + WRITE (NDSO,947) STATUS + WRITE (NDSO,2948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, IS2DUPDATE, IS2FLEXSTR, IS2DISP, & + IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, IS2C3, IS2CONC, IS2CREEPB,& + IS2CREEPC, IS2CREEPD, IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, & + IS2ANDISB, IS2ANDISE, IS2ANDISD, IS2ANDISN +#endif +! +#ifdef W3_REF1 + REFCOAST=0. + REFMAP=0. + REFMAPD=0. + REFRMAX=1. + REFFREQPOW=2. + REFFREQ=0. + REFCOSP_STRAIGHT=4. + REFSLOPE=0.22 + REFSUBGRID=0. + REFICEBERG=0. + REFUNSTSOURCE=0. +#endif +! +#ifdef W3_REF1 + CALL READNL ( NDSS, 'REF1', STATUS ) + WRITE (NDSO,969) STATUS +#endif +! +#ifdef W3_IG1 + IGMETHOD = 2 + IGADDOUTP= 0 + IGSOURCE = 2 + IGSTERMS = 0 + IGMAXFREQ=0.03 + IGSOURCEATBP = 0 + IGBCOVERWRITE = .TRUE. + IGSWELLMAX = .TRUE. + IGKDMIN = 1.1 + IGFIXEDDEPTH = 0. + IGEMPIRICAL = 0.00125 +#endif +! +#ifdef W3_IG1 + CALL READNL ( NDSS, 'SIG1 ', STATUS ) + WRITE (NDSO,970) STATUS +#endif +! +#ifdef W3_IC2 + IC2DISPER = .FALSE. + IC2TURB = 1. + IC2TURBS = 0. + IC2ROUGH = 0.01 + IC2REYNOLDS = 1.5E5 + IC2SMOOTH = 2E5 + IC2VISC = 1. + IC2DMAX = 0. +#endif +! +#ifdef W3_IC3 + IC3MAXTHK = 100.0 + IC3MAXCNC = 100.0 + IC2TURB = 2.0 ! from run_test example by F.A. + IC2TURBS = 0. + IC2ROUGH = 0.02 ! from run_test example by F.A. (alt:0.1) + IC2REYNOLDS = 1.5E5 + IC2SMOOTH = 7.0E4 + IC2VISC = 2.0 + IC3CHENG = .TRUE. + USECGICE = .FALSE. + IC3HILIM = 100.0 + IC3KILIM = 100.0 + IC3HICE = -1.0 + IC3VISC = -2.0 + IC3DENS = -3.0 + IC3ELAS = -4.0 +#endif +!fixme: if USECGICE = .TRUE., don't allow use of IC3MAXTHK<100.0 + +#ifdef W3_IC4 + IC4METHOD = 1 !switch for methods within IC4 + IC4KI=0.0 + IC4FC=0.0 +#endif +! +#ifdef W3_IC5 + IC5MINIG = 1. + IC5MINWT = 0. + IC5MAXKRATIO = 1E9 + IC5MAXKI = 100. + IC5MINHW = 0. + IC5MAXITER = 100. + IC5RKICK = 0. + IC5KFILTER = 0.0025 + IC5VEMOD = 3. ! 1: EFS, 2: RP, 3: M2 (default) +#endif +! +#ifdef W3_IC2 + CALL READNL ( NDSS, 'SIC2 ', STATUS ) + WRITE (NDSO,971) STATUS +#endif +! +#ifdef W3_IC3 + CALL READNL ( NDSS, 'SIC3 ', STATUS ) + WRITE (NDSO,971) STATUS +#endif +! +#ifdef W3_IC4 + CALL READNL ( NDSS, 'SIC4 ', STATUS ) + WRITE (NDSO,971) STATUS +#endif +! +#ifdef W3_IC5 + CALL READNL ( NDSS, 'SIC5 ', STATUS ) + IC5VEMOD = MIN(MAX(1., IC5VEMOD), 3.) + WRITE (NDSO,971) STATUS + WRITE (NDSO,2971) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, IC5RKICK, & + IC5KFILTER, IC5MSTR(NINT(IC5VEMOD)) +#endif +! + CALL READNL ( NDSS, 'OUTS', STATUS ) + WRITE (NDSO,4970) STATUS +! +! +! output of frequency spectra, th1m ... +! + E3DF(1,1) = E3D + E3DF(2,1) = MIN(MAX(1,I1E3D),NK) + E3DF(3,1) = MIN(MAX(1,I2E3D),NK) + E3DF(1,2) = TH1MF + E3DF(2,2) = MIN(MAX(1,I1TH1M),NK) + E3DF(3,2) = MIN(MAX(1,I2TH1M),NK) + E3DF(1,3) = STH1MF + E3DF(2,3) = MIN(MAX(1,I1STH1M),NK) + E3DF(3,3) = MIN(MAX(1,I2STH1M),NK) + E3DF(1,4) = TH2MF + E3DF(2,4) = MIN(MAX(1,I1TH2M),NK) + E3DF(3,4) = MIN(MAX(1,I2TH2M),NK) + E3DF(1,5) = STH2MF + E3DF(2,5) = MIN(MAX(1,I1STH2M),NK) + E3DF(3,5) = MIN(MAX(1,I2STH2M),NK) +! +! output of microseismic source spectra +! + P2MSF(1) = P2SF + P2MSF(2) = MIN(MAX(1,I1P2SF),NK) + P2MSF(3) = MIN(MAX(1,I2P2SF),NK) +! +! output of Stokes drift profile +! + US3DF(1) = US3D + US3DF(2) = MAX( 1 , MIN( NK, I1US3D) ) + US3DF(3) = MAX( 1 , MIN( NK, I2US3D) ) +! +! output of Stokes drift partitions +! + USSPF(1) = USSP + USSPF(2) = MAX( 1 , MIN(25, IUSSP ) ) + IF (IUSSP.GT.25) THEN + WRITE(NDSE,*) ' *** WAVEWATCH III ERROR IN ww3_grid:' + WRITE(NDSE,*) " Stokes drift partition outputs not " + WRITE(NDSE,*) " intended for use with more than 25 " + WRITE(NDSE,*) " partitions. Please reduce IUSSP " + WRITE(NDSE,*) " specified in ww3_grid.inp to proceed " + CALL EXTCDE( 31) + ENDIF + + DO J=1,USSPF(2) + USSP_WN(j) = STK_WN(J) + ENDDO + +! + WRITE (NDSO,4971) P2MSF(1:3) + WRITE (NDSO,4972) US3DF(1:3) + WRITE (NDSO,4973) E3DF(1:3,1) + WRITE (NDSO,4974) USSPF(1:2) + DO J=1,USSPF(2) + WRITE(NDSO,4975) J,USSP_WN(J) + ENDDO +! + CALL READNL ( NDSS, 'MISC', STATUS ) + WRITE (NDSO,960) STATUS +! + IF ( FLAGTR.LT.0 .OR. FLAGTR.GT.6 ) FLAGTR = 0 + CICEN = MIN ( 1. , MAX ( 0. , CICEN ) ) + ICESLN = MIN ( 1. , MAX ( 0. , ICESLN ) ) + ICEWIND = MIN ( 1. , MAX ( 0. , ICEWIND ) ) + ICESDS = MIN ( 1. , MAX ( 0. , ICESDS ) ) + ICESNL = MIN ( 1. , MAX ( 0. , ICESNL ) ) + FICEN = CICEN + GRIDSHIFT=GSHIFT + ICESCALES(1)=ICESLN + ICESCALES(2)=ICEWIND + ICESCALES(3)=ICESNL + ICESCALES(4)=ICESDS + CMPRTRCK=TRCKCMPR + CICE0 = MIN ( CICEN , MAX ( 0. , CICE0 ) ) + FICEL = LICE + IICEHMIN = ICEHMIN + IICEHFAC = ICEHFAC + IICEHINIT = ICEHINIT + IICEDISP= ICEDISP + IICEHDISP = ICEHDISP + IICEDDISP = ICEDDISP + IICEFDISP = ICEFDISP + PMOVE = MAX ( 0. , PMOVE ) + PFMOVE = PMOVE +! + BTBETA = MIN(MAX (1., BTBET), 2.) + AAIRCMIN = ALOG(GRAV/AIRCMIN/SIG(1))/ALOG(XFR)+1 ! goes from phase speed C=g/sig to index + AAIRGB = AIRGB +! +! Notes: Presently, if we select CICE0.ne.CICEN requires an obstruction +! grid, that is initialized with zeros as default. + IF ( FLAGTR .LT. 3 ) THEN + IF (CICE0.NE.CICEN) THEN + CICE0 = CICEN + IF (STATUS=='(user def. values) :') WRITE (NDSO,2961) + END IF + END IF +#ifdef W3_IC0 + IF ( CICE0.EQ.CICEN .AND. FLAGTR.GE.3 ) FLAGTR = FLAGTR - 2 +#endif + WRITE (NDSO,961) CICE0, CICEN + WRITE (NDSO,8972) ICEWIND + FICE0 = CICE0 +! Variables for Space-Time Extremes + STEXU = STDX + IF ( STDY .LE. 0. ) THEN + STDY = STDX + END IF + STEYU = STDY + STEDU = STDT + IF ( STDX .GT. 0 ) THEN + WRITE (NDSO,1040) STDX + WRITE (NDSO,1041) STDY + ELSE + WRITE (NDSO,1042) + END IF + IF ( STDT .GT. 0 ) THEN + WRITE (NDSO,1043) STDT + ELSE + WRITE (NDSO,1044) + END IF +#ifdef W3_MGG + WRITE (NDSO,962) PMOVE +#endif +! +#ifdef W3_SEED + XSEED = MAX ( 1. , XSEED ) + WRITE (NDSO,964) XSEED +#endif +#ifdef W3_SCRIP + WRITE (NDSO,963) GSHIFT +#endif + WRITE (NDSO,1972) TRCKCMPR + FACSD = XSEED +#ifdef W3_RWND + RWINDC = RWNDC +#endif +#ifdef W3_WCOR + WWCOR(1) = WCOR1 + WWCOR(2) = WCOR2 +#endif +! + XP = MAX ( 1.E-6 , XP ) + XR = MAX ( 1.E-6 , XR ) + XREL = XR + XFILT = MAX ( 0. , XFILT ) + XFLT = XFILT + WRITE (NDSO,965) XP, XR, XFILT + FACP = XP / PI * 0.62E-3 * TPI**4 / GRAV**2 +! + IHMAX = MAX ( 50, IHM ) + HSPMIN = MAX ( 0.0001 , HSPM ) + WSMULT = MAX ( 1. , WSM ) + WSCUT = MIN ( 1.0001 , MAX ( 0. , WSC ) ) + FLCOMB = FLC + NOSWLL = MAX ( 1 , NOSW ) + PTMETH = PTM ! Partitioning method. Chris Bunney (Jan 2016) + PTFCUT = PTFC ! Freq cutoff for partitiong method 5 + PMNAM2 = "" + IF( PTMETH .EQ. 1 ) THEN + PMNAME = "WW3 default" + ELSE IF( PTMETH .EQ. 2 ) THEN + PMNAME = "Watershedding plus wind cut-off" + ELSE IF( PTMETH .EQ. 3 ) THEN + PMNAME = "Watershedding only" + WSCUT = 0.0 ! We don't want to classify by ws frac + PMNAM2 = "WSC set to 0.0" + ELSE IF( PTMETH .EQ. 4 ) THEN + PMNAME = "Wind speed cut-off only" + PMNAM2 = "WSC set to 0.0, NOSW set to 1" + WSCUT = 0.0 ! We don't want to classify by ws frac + NOSWLL = 1 ! Only ever one swell + ELSE IF( PTMETH .EQ. 5 ) THEN + WRITE(PMNAME, '("2-Band hi/low cutoff at ", F4.2,"Hz")') PTFCUT + PMNAM2 = "WSC set to 0.0, NOSW set to 1" + WSCUT = 0.0 ! We don't want to classify by ws frac + NOSWLL = 1 ! Only ever one swell + ELSE + WRITE( NDSE, * ) & + "*** Error - unknown partitioing method (PTM)! ***" + CALL EXIT(1) + ENDIF + + IF ( FLCOMB ) THEN + J = 1 + ELSE + J = 2 + END IF + WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J), NOSWLL + WRITE (NDSO,5971) PMNAME + IF( PMNAM2 .NE. "" ) WRITE (NDSO,5972) PMNAM2 +!! WRITE (NDSO,966) IHMAX, HSPMIN, WSMULT, WSCUT, YESXNO(J) +! + FHMAX = MAX ( 0.01 , FMICHE ) + J = 2 +#ifdef W3_MLIM + J = 1 +#endif + WRITE (NDSO,967) FHMAX, FHMAX/SQRT(2.), YESXNO(J) + IF ( FHMAX.LT.0.50 .AND. J.EQ.1 ) WRITE (NDST,968) +! + IF (TRIM(CALTYPE) .NE. 'standard' .AND. & + TRIM(CALTYPE) .NE. '360_day' .AND. & + TRIM(CALTYPE) .NE. '365_day' ) GOTO 2003 + WRITE (NDST,1973) CALTYPE + WRITE (NDSO,*) +! +! 6.x Read values for FLD stress calculation +! +#ifdef W3_FLD1 + TAILTYPE = 0 + TAILLEV = 0.006 + TAILT1 = 1.25 + TAILT2 = 3.00 +#endif +#ifdef W3_FLD2 + TAILTYPE = 0 + TAILLEV = 0.006 + TAILT1 = 1.25 + TAILT2 = 3.00 +#endif +! +#ifdef W3_FLD1 + CALL READNL ( NDSS, 'FLD1', STATUS ) + TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) + TAIL_LEV = TAILLEV + TAIL_ID = TAILTYPE + TAIL_TRAN1 = TAILT1 + TAIL_TRAN2 = TAILT2 +#endif +#ifdef W3_FLD2 + CALL READNL ( NDSS, 'FLD2', STATUS ) + TAILLEV = MIN( MAX ( 0.0005 , TAILLEV ), 0.04) + TAIL_LEV = TAILLEV + TAIL_ID = TAILTYPE + TAIL_TRAN1 = TAILT1 + TAIL_TRAN2 = TAILT2 +#endif +! +! 6.o End of namelist processing +! + IF (FLGNML) THEN + CLOSE (NDSS) + ELSE + CLOSE (NDSS,STATUS='DELETE') + END IF +! + IF ( FLNMLO ) THEN + WRITE (NDSO,917) +#ifdef W3_FLX3 + WRITE (NDSO,2810) CDMAX*1.E3, CTYPE +#endif +#ifdef W3_FLX4 + WRITE (NDSO,2810) CDFAC +#endif +#ifdef W3_LN1 + WRITE (NDSO,2820) CLIN, RFPM, RFHF +#endif +#ifdef W3_ST1 + WRITE (NDSO,2920) CINP +#endif + IF ( .NOT. FLSTB2 ) THEN +#ifdef W3_ST2 + WRITE (NDSO,2920) ZWND, SWELLF +#endif + ELSE +#ifdef W3_STAB2 + WRITE (NDSO,2921) ZWND, SWELLF, STABSH, STABOF, & + CNEG, CPOS, FNEG +#endif + END IF +! +#ifdef W3_ST3 + WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + SWELLF +#endif +#ifdef W3_ST4 + WRITE (NDSO,2920) ZWND, ALPHA0, Z0MAX, BETAMAX, SINTHP, ZALP, & + TAUWSHELTER, SWELLFPAR, SWELLF, SWELLF2, SWELLF3, SWELLF4, & + SWELLF5, SWELLF6, SWELLF7, Z0RAT, SINBR +#endif +#ifdef W3_ST6 + WRITE (NDSO,2920) SINA0, SINWS, SINFC +#endif +#ifdef W3_NL1 + WRITE (NDSO,2922) LAMBDA, NLPROP, KDCONV, KDMIN, & + SNLCS1, SNLCS2, SNLCS3 +#endif +#ifdef W3_NL2 + WRITE (NDSO,2922) IQTYPE, TAILNL, NDEPTH + IF ( IQTYPE .EQ. 3 ) THEN + IF ( NDEPTH .EQ. 1 ) THEN + WRITE (NDSO,3923) DPTHNL(1) + ELSE + WRITE (NDSO,4923) DPTHNL(1) + END IF + WRITE (NDSO,5923) DPTHNL(2:NDEPTH-1) + WRITE (NDSO,6923) DPTHNL(NDEPTH) + END IF +#endif +#ifdef W3_NL3 + WRITE (NDSO,2922) NQDEF, MSC, NSC, KDFD, KDFS + IF ( NQDEF .EQ. 1 ) THEN + WRITE (NDSO,3923) QPARMS(1:5) + ELSE + WRITE (NDSO,4923) QPARMS(1:5) + DO J=2, NQDEF-1 + WRITE (NDSO,5923) QPARMS((J-1)*5+1:J*5) + END DO + WRITE (NDSO,6923) QPARMS((NQDEF-1)*5+1:NQDEF*5) + END IF +#endif +#ifdef W3_NL4 + WRITE (NDSO,2922) INDTSA, ALTLP +#endif +#ifdef W3_NL5 + WRITE (NDSO,2922) QR5DPT, QR5OML, QI5DIS, QI5KEV, QI5IPL, QI5PMX +#endif +#ifdef W3_NLS + WRITE (NDSO,8922) A34, FHFC, DNM, FC1, FC2, FC3 +#endif +#ifdef W3_ST1 + WRITE (NDSO,2924) CDIS, APM +#endif +#ifdef W3_ST2 + WRITE (NDSO,2924) SDSA0, SDSA1, SDSA2, SDSB0, SDSB1, PHIMIN +#endif +#ifdef W3_ST3 + WRITE (NDSO,2924) SDSC1, WNMEANP, FXPM3, FXFM3, SDSDELTA1, & + SDSDELTA2 +#endif + +#ifdef W3_ST4 + WRITE (NDSO,2924) SDSBCHOICE, SDSC2, SDSCUM, SDSC4, & + SDSC5, SDSC6, & + WNMEANP, FXPM3, FXFM3, FXFMAGE, & + SDSBINT, SDSBCK, SDSABK, SDSPBK, SDSHCK, & + SDSBR, SDSSTRAIN, SDSSTRAINA, SDSSTRAIN2, & + SDSBT, SDSP, SDSISO, SDSCOS, SDSDTH, SDSBRF1, & + SDSBRFDF, SDSBM0, SDSBM1, SDSBM2, SDSBM3, SDSBM4, & + SPMSS, SDKOF, SDSMWD, SDSFACMTF, SDSNMTF,SDSMWPOW,& + SDSCUMP, SDSNUW, WHITECAPWIDTH, WHITECAPDUR +#endif +#ifdef W3_ST6 + WRITE (NDSO,2924) SDSET, SDSA1, SDSA2, SDSP1, SDSP2 + WRITE (NDSO,2937) SWLB1, CSTB1 +#endif +#ifdef W3_BT1 + WRITE (NDSO,2926) GAMMA +#endif +#ifdef W3_BT4 + WRITE (NDSO,2926) SEDMAPD50, SED_D50_UNIFORM, & + RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4, SIGDEPTH, & + BOTROUGHMIN, BOTROUGHFAC +#endif +#ifdef W3_DB1 + IF ( BJFLAG ) THEN + WRITE (NDSO,2928) BJALFA, BJGAM, '.TRUE.' + ELSE + WRITE (NDSO,2928) BJALFA, BJGAM, '.FALSE.' + END IF +#endif +#ifdef W3_PR1 + WRITE (NDSO,2953) CFLTM +#endif +#ifdef W3_PR2 + WRITE (NDSO,2953) CFLTM, DTIME, LATMIN +#endif +#ifdef W3_SMC + WRITE (NDSO,2954) CFLSM, DTIMS, Arctic, RFMAXD, UNO3, & + AVERG, LvSMC, NBISMC, ISHFT, JEQT, SEAWND +#endif +#ifdef W3_PR3 + WRITE (NDSO,2953) CFLTM, WDTHCG, WDTHTH +#endif +! + WRITE (NDSO,2956) UGBCCFL, UGOBCAUTO, UGOBCDEPTH,TRIM(UGOBCFILE), & + EXPFSN, EXPFSPSI, EXPFSFCT, IMPFSN, EXPTOTAL,& + IMPTOTAL, IMPREFRACTION, IMPFREQSHIFT, & + IMPSOURCE, SETUP_APPLY_WLV, & + JGS_TERMINATE_MAXITER, & + JGS_TERMINATE_DIFFERENCE, & + JGS_TERMINATE_NORM, & + JGS_LIMITER, & + JGS_USE_JACOBI, & + JGS_BLOCK_GAUSS_SEIDEL, & + JGS_MAXITER, & + JGS_PMIN, & + JGS_DIFF_THR, & + JGS_NORM_THR, & + JGS_NLEVEL, & + JGS_SOURCE_NONLINEAR +! + WRITE (NDSO,2976) P2SF, I1P2SF, I2P2SF, & + US3D, I1US3D, I2US3D, & + USSP, IUSSP, & + E3D, I1E3D, I2E3D, & + TH1MF, I1TH1M, I2TH1M, & + STH1MF, I1STH1M, I2STH1M, & + TH2MF, I1TH2M, I2TH2M, & + STH2MF, I1STH2M, I2STH2M +! +#ifdef W3_REF1 + WRITE(NDSO,2986) REFCOAST, REFFREQ, REFSLOPE, REFMAP, & + REFMAPD, REFSUBGRID , REFRMAX, REFFREQPOW, & + REFICEBERG, REFCOSP_STRAIGHT, REFUNSTSOURCE +#endif +! +#ifdef W3_IG1 + WRITE(NDSO,2977) IGMETHOD, IGADDOUTP, IGSOURCE, & + IGSTERMS, IGBCOVERWRITE, IGSWELLMAX, & + IGMAXFREQ, IGSOURCEATBP, IGKDMIN, & + IGFIXEDDEPTH, IGEMPIRICAL +#endif +! +#ifdef W3_IC2 + WRITE(NDSO,2978) IC2DISPER, IC2TURB, IC2ROUGH, & + IC2REYNOLDS, IC2SMOOTH, IC2VISC, IC2TURBS, & + IC2DMAX +#endif +! +#ifdef W3_IC3 + WRITE(NDSO,2979) IC3MAXTHK, IC3MAXCNC, IC2TURB, & + IC2ROUGH, IC2REYNOLDS, IC2SMOOTH, & + IC2VISC, IC2TURBS, IC3CHENG, & + USECGICE, IC3HILIM, IC3KILIM, & + IC3HICE, IC3VISC, IC3DENS, IC3ELAS +#endif +! +#ifdef W3_IC4 + WRITE(NDSO,NML=SIC4) +#endif +! +#ifdef W3_IC5 + WRITE(NDSO,2981) IC5MINIG, IC5MINWT, IC5MAXKRATIO, & + IC5MAXKI, IC5MINHW, IC5MAXITER, & + IC5RKICK, IC5KFILTER, IC5VEMOD +#endif +! +#ifdef W3_IS1 + WRITE (NDSO,2946) IS1C1, IS1C2 +#endif +! +#ifdef W3_IS2 + WRITE (NDSO,948) ISC1, IS2BACKSCAT, IS2ISOSCAT, IS2BREAK, & + IS2DUPDATE, IS2FLEXSTR, IS2DISP, IS2DAMP, IS2FRAGILITY, IS2DMIN, IS2C2, & + IS2C3, IS2CONC, IS2CREEPB, IS2CREEPC, IS2CREEPD, & + IS2CREEPN, IS2BREAKE, IS2BREAKF, IS2WIM1, IS2ANDISB, & + IS2ANDISE, IS2ANDISD, IS2ANDISN +#endif +! +#ifdef W3_UOST + WRITE (NDSO, 4502) ADJUSTL(TRIM(UOSTFILELOCAL)), ADJUSTL(TRIM(UOSTFILESHADOW)), & + UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif + +! + IF ( FLCOMB ) THEN + WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & + XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & + WSCUT, '.TRUE.', NOSWLL, FHMAX, & + RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & + STDX, STDY, STDT, ICEHMIN, ICEHFAC, & + ICEHINIT, ICEDISP, ICEHDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEDDISP,ICEFDISP, CALTYPE, TRCKCMPR, & + BTBETA + ELSE + WRITE (NDSO,2966) CICE0, CICEN, LICE, PMOVE, XSEED, FLAGTR, & + XP, XR, XFILT, IHMAX, HSPMIN, WSMULT, & + WSCUT, '.FALSE.', NOSWLL, FHMAX, & + RWNDC, WCOR1, WCOR2, FACBERG, GSHIFT, & + STDX, STDY, STDT, ICEHMIN, ICEHFAC, & + ICEHINIT, ICEDISP, ICEHDISP, & + ICESLN, ICEWIND, ICESNL, ICESDS, & + ICEDDISP, ICEFDISP, CALTYPE, TRCKCMPR,& + BTBETA + END IF +! +#ifdef W3_FLD1 + WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 +#endif +#ifdef W3_FLD2 + WRITE(NDSO,2987) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 +#endif +#ifdef W3_RTD + WRITE(NDSO,4991) PLAT, PLON, UNROT + WRITE(NDSO,4992) BPLAT, BPLON +#endif +! + WRITE (NDSO,918) + END IF +! +! 6.p Set various other values ... +! ... Tail in integration --> scale factor for A to E conv +! + FTE = 0.25 * SIG(NK) * DTH * SIG(NK) + FTF = 0.20 * DTH * SIG(NK) + FTWN = 0.20 * SQRT(GRAV) * DTH * SIG(NK) + FTTR = FTF + FTWL = GRAV / 6. / SIG(NK) * DTH * SIG(NK) +#ifdef W3_ST3 + STXFTF = 1/(FACHF-1.-WNMEANP*2) & + * SIG(NK)**(2+WNMEANP*2) * DTH + STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & + * SIG(NK)**(2+WNMEANPTAIL*2) * DTH + STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & + * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH + SSTXFTF = STXFTF + SSTXFTFTAIL = STXFTFTAIL + SSTXFTWN = STXFTWN +#endif +! +#ifdef W3_ST4 + STXFTF = 1/(FACHF-1.-WNMEANP*2) & + * SIG(NK)**(2+WNMEANP*2) * DTH + STXFTFTAIL = 1/(FACHF-1.-WNMEANPTAIL*2) & + * SIG(NK)**(2+WNMEANPTAIL*2) * DTH + STXFTWN = 1/(FACHF-1.-WNMEANP*2) * SIG(NK)**(2) & + * (SIG(NK)/SQRT(GRAV))**(WNMEANP*2) * DTH + SSTXFTF = STXFTF + SSTXFTFTAIL = STXFTFTAIL + SSTXFTWN = STXFTWN +#endif +! +! ... High frequency cut-off +! + FXFM = 2.5 +#ifdef W3_ST6 + FXFM = SIN6FC +#endif + FXPM = 4.0 + FXPM = FXPM * GRAV / 28. + FXFM = FXFM * TPI + XFC = 3.0 +#ifdef W3_ST2 + XFH = 2.0 + XF1 = 1.75 + XF2 = 2.5 + XFT = XF2 +#endif +! + FACTI1 = 1. / LOG(XFR) + FACTI2 = 1. - LOG(TPI*FR1) * FACTI1 +! +! Setting of FACHF moved to before !/NL2 set-up for consistency +! +#ifdef W3_NL2 + FACHF = -TAILNL +#endif + FACHFA = XFR**(-FACHF-2) + FACHFE = XFR**(-FACHF) +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 7. Read and prepare the grid. +! 7.a Type of grid +! + IF (FLGNML) THEN + GSTRG=TRIM(NML_GRID%TYPE) + IF (TRIM(NML_GRID%COORD).EQ.'SPHE') FLAGLL=.TRUE. + IF (TRIM(NML_GRID%COORD).EQ.'CART') FLAGLL=.FALSE. + CSTRG=TRIM(NML_GRID%CLOS) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) GSTRG, FLAGLL, CSTRG + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + + SELECT CASE (TRIM(GSTRG)) + CASE ('RECT') + GTYPE = RLGTYPE + WRITE (NDSO,3000) 'rectilinear' + CASE ('CURV') + GTYPE = CLGTYPE + WRITE (NDSO,3000) 'curvilinear' + CASE ('UNST') + GTYPE = UNGTYPE + WRITE (NDSO,3000) 'unstructured' +!!Li Add SMC grid type option. JGLi12Oct2020 + CASE ('SMCG') + GTYPE = SMCTYPE + WRITE (NDSO,3000) 'SMC Grid' + CASE DEFAULT + WRITE (NDSE,1007) TRIM(GSTRG) + CALL EXTCDE ( 25 ) + END SELECT +! + IF ( FLAGLL ) THEN + FACTOR = 1. + WRITE (NDSO,3001) 'spherical' + ELSE + FACTOR = 1.E-3 + WRITE (NDSO,3001) 'Cartesian' + END IF +! +! Only process grid closure string for logically rectangular grids. +! Closure setting for unstructured grids is NONE. + ICLOSE = ICLOSE_NONE + IF ( GTYPE.NE.UNGTYPE ) THEN + SELECT CASE (TRIM(CSTRG)) + CASE ('NONE') + ICLOSE = ICLOSE_NONE + WRITE (NDSO,3002) 'none' + CASE ('SMPL') + ICLOSE = ICLOSE_SMPL + WRITE (NDSO,3002) 'simple' + CASE ('TRPL') + WRITE (NDSE,'(/2A)') ' *** WARNING WW3_GRID: TRIPOLE ', & + 'GRID CLOSURE IMPLEMENTATION IS INCOMPLETE ***' + ICLOSE = ICLOSE_TRPL + WRITE (NDSO,3002) 'tripole' + IF ( GTYPE.EQ.RLGTYPE ) THEN + WRITE (NDSE,1009) + CALL EXTCDE ( 25 ) + END IF + CASE DEFAULT + ! Check for old style GLOBAL input + SELECT CASE (TRIM(CSTRG)) + CASE ('T','t','.TRU','.tru') + ICLOSE = ICLOSE_SMPL + WRITE (NDSO,3002) 'simple' + WRITE (NDSE,1013) + CASE ('F','f','.FAL','.fal') + ICLOSE = ICLOSE_NONE + WRITE (NDSO,3002) 'none' + WRITE (NDSE,1013) + CASE DEFAULT + WRITE (NDSE,1012) TRIM(CSTRG) + CALL EXTCDE ( 25 ) + END SELECT + END SELECT + IF ( ICLOSE.NE.ICLOSE_NONE .AND. .NOT.FLAGLL ) THEN + WRITE (NDSE,1008) + CALL EXTCDE ( 25 ) + END IF + END IF !GTYPE.NE.UNGTYPE +! +! 7.b Size of grid +! + IF (FLGNML) THEN + SELECT CASE ( GTYPE ) +!!Li SMCTYPE shares domain info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + NX = NML_RECT%NX + NY = NML_RECT%NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY + CASE ( CLGTYPE ) + NX = NML_CURV%NX + NY = NML_CURV%NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY + CASE ( UNGTYPE ) + NY=1 + END SELECT + ELSE + IF ( GTYPE.NE.UNGTYPE) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NX, NY + NX = MAX ( 3 , NX ) + NY = MAX ( 3 , NY ) + WRITE (NDSO,3003) NX, NY + ELSE + NY =1 + END IF + END IF +! +! Propagation specific to unstructured grids +! + DO_CHANGE_WLV=.FALSE. + IF ( GTYPE.EQ.UNGTYPE) THEN + UNSTSCHEMES(:)=0 + IF (EXPFSN) UNSTSCHEMES(1)=1 + IF (EXPFSPSI) UNSTSCHEMES(2)=1 + IF (EXPFSFCT) UNSTSCHEMES(3)=1 + IF (IMPFSN) UNSTSCHEMES(4)=1 + UNSTSCHEME=-1 + DO IX=1,4 + IF (UNSTSCHEMES(IX).EQ.1) THEN + UNSTSCHEME=IX + EXIT + END IF + END DO + + FSBCCFL = UGBCCFL + SELECT CASE (UNSTSCHEME) + CASE (1) + FSN = EXPFSN + PNAME2 = 'N Explicit (Fluctuation Splitting) ' + CASE (2) + FSPSI = EXPFSPSI + PNAME2 = 'PSI Explicit (Fluctuation Splitting) ' + CASE (3) + FSFCT = EXPFSFCT + PNAME2 = ' Flux Corrected Transport Explicit' + CASE (4) + FSNIMP = IMPFSN + PNAME2 = 'N Implicit (Fluctuation Splitting) ' + END SELECT +! + IF (SUM(UNSTSCHEMES).GT.1) WRITE(NDSO,1035) + WRITE (NDSO,2951) PNAME2 + IF (IMPTOTAL) THEN + FSTOTALIMP = IMPTOTAL + PNAME2 = 'N Implicit (Fluctuation Splitting) for total implicit' + END IF + IF (EXPTOTAL) THEN + FSTOTALEXP = EXPTOTAL + PNAME2 = 'N Explicit (Fluctuation Splitting) for one exchange explicit DC HPCF ' + END IF + IF (IMPREFRACTION .and. IMPTOTAL .AND. FLCTH) THEN + FSREFRACTION = .TRUE. + PNAME2 = 'Refraction done implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSREFRACTION = .FALSE. + END IF + IF (IMPFREQSHIFT .and. IMPTOTAL .AND. FLCK) THEN + FSFREQSHIFT = .TRUE. + PNAME2 = 'Frequency shifting done implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSFREQSHIFT = .FALSE. + END IF + IF (IMPSOURCE .and. IMPTOTAL .AND. FLSOU) THEN + FSSOURCE = .TRUE. + PNAME2 = 'Source terms integrated implicitly' + WRITE (NDSO,2951) PNAME2 + ELSE + FSSOURCE = .FALSE. + END IF + IF (SETUP_APPLY_WLV) THEN + DO_CHANGE_WLV = SETUP_APPLY_WLV + PNAME2 = ' we change WLV' + WRITE (NDSO,2952) PNAME2 + END IF + SOLVERTHR_STP = SOLVERTHR_SETUP + CRIT_DEP_STP = CRIT_DEP_SETUP + END IF + +! +! 7.c Grid coordinates (branch here based on grid type) +! + IF ( GTYPE.NE.UNGTYPE) ALLOCATE ( XGRDIN(NX,NY), YGRDIN(NX,NY) ) + SELECT CASE ( GTYPE ) +! +! 7.c.1 Rectilinear grid +! +!!Li SMC grid shares domain info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) +! + IF (FLGNML) THEN + SX = NML_RECT%SX + SY = NML_RECT%SY + VSC = NML_RECT%SF + X0 = NML_RECT%X0 + Y0 = NML_RECT%Y0 + VSC0 = NML_RECT%SF0 + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) SX, SY, VSC + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) X0, Y0, VSC0 + END IF +! + VSC = MAX ( 1.E-7 , VSC ) + SX = SX / VSC + SY = SY / VSC + SX = MAX ( 1.E-7 , SX ) + SY = MAX ( 1.E-7 , SY ) + IF ( ICLOSE.EQ.ICLOSE_SMPL ) SX = 360. / REAL(NX) +! + VSC0 = MAX ( 1.E-7 , VSC0 ) + X0 = X0 / VSC0 + Y0 = Y0 / VSC0 +! + IF ( FLAGLL ) THEN + WRITE (NDSO,3004) FACTOR*SX, FACTOR*SY, & + FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & + FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) + ELSE + WRITE (NDSO,3005) FACTOR*SX, FACTOR*SY, & + FACTOR*X0, FACTOR*(X0+REAL(NX-1)*SX), & + FACTOR*Y0, FACTOR*(Y0+REAL(NY-1)*SY) + END IF +! + DO IY=1, NY + DO IX=1, NX + XGRDIN(IX,IY) = X0 + REAL(IX-1)*SX + YGRDIN(IX,IY) = Y0 + REAL(IY-1)*SY + END DO + END DO +! +! 7.c.2 Curvilinear grid +! + CASE ( CLGTYPE ) +! +! 7.c.2.a Process x-coordinates +! + IF (FLGNML) THEN + NDSG = NML_CURV%XCOORD%IDF + VSC = NML_CURV%XCOORD%SF + VOF = NML_CURV%XCOORD%OFF + IDLA = NML_CURV%XCOORD%IDLA + IDFM = NML_CURV%XCOORD%IDFM + RFORM = TRIM(NML_CURV%XCOORD%FORMAT) + FROM = TRIM(NML_CURV%XCOORD%FROM) + FNAME = TRIM(NML_CURV%XCOORD%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & + IDLA, IDFM, RFORM, FROM, FNAME + END IF +! + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 +! + WRITE (NDSO,3006) NDSG, VSC, VOF, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & + WRITE (NDSO,3009) TRIM(FNAME) +! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + IF (.NOT.FLGNML) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + END IF + ELSE + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF !IDFM + END IF !NDSG +! + CALL INA2R ( XGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) +! +! 7.c.2.b Process y-coordinates +! + IF (FLGNML) THEN + NDSG = NML_CURV%YCOORD%IDF + VSC = NML_CURV%YCOORD%SF + VOF = NML_CURV%YCOORD%OFF + IDLA = NML_CURV%YCOORD%IDLA + IDFM = NML_CURV%YCOORD%IDFM + RFORM = TRIM(NML_CURV%YCOORD%FORMAT) + FROM = TRIM(NML_CURV%YCOORD%FROM) + FNAME = TRIM(NML_CURV%YCOORD%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSG, VSC, VOF, & + IDLA, IDFM, RFORM, FROM, FNAME + END IF +! + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 +! + WRITE (NDSO,3007) NDSG, VSC, VOF, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,3008) TRIM(RFORM) + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & + WRITE (NDSO,3009) TRIM(FNAME) +! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + IF (.NOT.FLGNML) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + END IF + ELSE + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME),& + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF !IDFM + END IF !NDSG +! + CALL INA2R ( YGRDIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) +! +! 7.c.2.c Check for obvious errors in grid definition or input +! +! ....... Check for inverted grid (can result from wrong IDLA) + IF ( (XGRDIN(2,1)-XGRDIN(1,1))*(YGRDIN(1,2)-YGRDIN(1,1)) .LT. & + (YGRDIN(2,1)-YGRDIN(1,1))*(XGRDIN(1,2)-XGRDIN(1,1)) ) THEN + WRITE (NDSE,1011) IDLA +!.........Notes: here, we are checking to make sure that the j axis is ~90 degrees +!................counter-clockwise from the i axis (the standard cartesian setup). +!................So, it is a check on the handedness of the grid. +!................We have confirmed for one case that a left-handed grid produces +!................errors in SCRIP. We have not confirmed that left-handed grids necessarily +!................produce errors in single-grid simulations, or that they necessarily +!................produce errors in all multi-grid simulations. +!................Note that transposing or flipping a grid will generally change the handedness. + CALL EXTCDE (25) + END IF +! +! 7.c.3 Unstructured grid +! + CASE ( UNGTYPE ) +! + MAXX = 0. + MAXY = 0. + DXYMAX = 0. + WRITE (NDSO,1150) + + IF (FLGNML) THEN + ZLIM = NML_GRID%ZLIM + DMIN = NML_GRID%DMIN + NDSG = NML_UNST%IDF + VSC = NML_UNST%SF + IDLA = NML_UNST%IDLA + IDFM = NML_UNST%IDFM + RFORM = TRIM(NML_UNST%FORMAT) + FROM = 'NAME' + FNAME = TRIM(NML_UNST%FILENAME) + UGOBCFILE = TRIM(NML_UNST%UGOBCFILE) + END IF + END SELECT !GTYPE +! +! 7.d Depth information for grid +! + IF (FLGNML) THEN + IF (GTYPE.NE.UNGTYPE) THEN + ZLIM = NML_GRID%ZLIM + DMIN = NML_GRID%DMIN + NDSG = NML_DEPTH%IDF + VSC = NML_DEPTH%SF + IDLA = NML_DEPTH%IDLA + IDFM = NML_DEPTH%IDFM + RFORM = TRIM(NML_DEPTH%FORMAT) + FROM = TRIM(NML_DEPTH%FROM) + FNAME = TRIM(NML_DEPTH%FILENAME) + END IF + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) ZLIM, DMIN, NDSG, VSC, IDLA, & + IDFM, RFORM, FROM, FNAME + END IF +! + DMIN = MAX ( 1.E-3 , DMIN ) + IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFM.LT.1 .OR. IDFM.GT.3) IDFM = 1 +! + WRITE (NDSO,972) NDSG, ZLIM, DMIN, VSC, IDLA, IDFM + IF (IDFM.EQ.2) WRITE (NDSO,973) TRIM(RFORM) + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSI) & + WRITE (NDSO,974) TRIM(FNAME) +! +! 7.e Read bottom depths +! + IF ( GTYPE.NE.UNGTYPE ) THEN +! +! Reading depths on structured grid +! + ALLOCATE ( ZBIN(NX,NY), OBSX(NX,NY), OBSY(NX,NY) ) +! +! Initialize subgrid obstructions with zeros. + ZBIN(:,:)=0. + OBSX(:,:)=0. + OBSY(:,:)=0. + +!Li Suspended for SMC grid, which uses depth stored in its cell array. +!Li JGLi15Oct2014 + IF( GTYPE .NE. SMCTYPE ) THEN +! + IF ( NDSG .EQ. NDSI ) THEN + IF ( IDFM .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSG + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE ! NDSG.NE.NDSI + IF ( IDFM .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & + FORM='UNFORMATTED',& + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSG,FILE=TRIM(FNMPRE)//TRIM(FNAME), & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSG, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF + END IF !( NDSG .EQ. NDSI ) +! + CALL INA2R ( ZBIN, NX, NY, 1, NX, 1, NY, NDSG, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, 0.0) +! +!Li End of IF( GTYPE .NE. SMCTYPE ) block + ENDIF +! + ELSE +! +! Reading depths on unstructured grid (this also sets number of mesh points, NX) +! + CALL READMSH(NDSG,FNAME) + ALLOCATE(ZBIN(NX, NY),OBSX(NX,NY),OBSY(NX,NY)) + ZBIN(:,1) = VSC*XYB(:,3) +#ifdef W3_DEBUGSTP + WRITE(740,*) 'VSC=', VSC + WRITE(740,*) 'Printing ZBIN 1' + DO IX=1,NX + WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) + END DO +#endif +! +! subgrid obstructions are not yet handled in unstructured grids +! + OBSX(:,:)=0. + OBSY(:,:)=0. + + END IF +! +! 7.f Set up temporary map +! + ALLOCATE ( TMPSTA(NY,NX), TMPMAP(NY,NX) ) + TMPSTA = 0 +! +#ifdef W3_DEBUGSTP + WRITE(740,*) 'Printing ZBIN 2' + DO IX=1,NX + WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) + END DO +#endif + IF (GTYPE .EQ. UNGTYPE) THEN + TMPSTA = 1 + ELSE + DO IY=1, NY + DO IX=1, NX + IF ( ZBIN(IX,IY) .LE. ZLIM ) TMPSTA(IY,IX) = 1 + END DO + END DO + ENDIF +! +!Li Suspended for SMC grid. JGLi15Oct2014 + IF( GTYPE .NE. SMCTYPE ) THEN +! +! 7.g Subgrid information +! + TRFLAG = FLAGTR + IF ( TRFLAG.GT.6 .OR. TRFLAG.LT.0 ) TRFLAG = 0 +! + IF ( TRFLAG .EQ. 0 ) THEN + WRITE (NDSO,976) 'Not available.' + ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN + WRITE (NDSO,976) 'In between grid points.' + ELSE + WRITE (NDSO,976) 'At grid points.' + END IF +! + IF ( TRFLAG .NE. 0 ) THEN +! +! 7.g.1 Info from input file +! + IF (FLGNML) THEN + NDSTR = NML_OBST%IDF + VSC = NML_OBST%SF + IDLA = NML_OBST%IDLA + IDFT = NML_OBST%IDFM + RFORM = TRIM(NML_OBST%FORMAT) + FROM = TRIM(NML_OBST%FROM) + TNAME = TRIM(NML_OBST%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF +! + IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 +! + WRITE (NDSO,977) NDSTR, VSC, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME +! +! 7.g.2 Open file and check if necessary +! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE IF ( NDSTR .EQ. NDSG ) THEN + IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & + ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN + WRITE (NDSE,1005) IDFM, IDFT + CALL EXTCDE (24) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & + IOSTAT=IERR) + ELSE + OPEN (NDSTR, FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF + END IF +! +! 7.g.3 Read the data +! + CALL INA2R ( OBSX, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFT, RFORM, IDLA, VSC, 0.0) +! + IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) +! + CALL INA2R ( OBSY, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFT, RFORM, IDLA, VSC, 0.0) +! +! 7.g.4 Limit +! + DO IX=1, NX + DO IY=1, NY + OBSX(IX,IY) = MAX( 0. , MIN(1.,OBSX(IX,IY)) ) + OBSY(IX,IY) = MAX( 0. , MIN(1.,OBSY(IX,IY)) ) + END DO + END DO +! + WRITE (NDSO,*) +! + END IF ! TRFLAG +! +!Li End of IF( GTYPE .NE. SMCTYPE ) block + END IF +! +#ifdef W3_RTD + ! 7.h Calculate rotation angles for configs with rotated pole + PoLon = PLON + PoLat = PLAT + FLAGUNR = UNROT + ! Default values PLON=-180, PLAT=90, UNROT=.FALSE. for standard lat-lon + + ALLOCATE( AnglDin(NX,NY) ) + ! For standard lat-lon the rotation angles are zero + IF ( PoLat == 90. ) THEN + AnglDin = 0. + ELSE + ALLOCATE(StdLat(NX,NY), StdLon(NX,NY)) + + ! Calculate rotation angles; (StdLon/Lat are returned, but not used) + ! The regular grid X/YGRDIN are used as equatorial lon and lat + CALL W3EQTOLL( YGRDIN, XGRDIN, StdLat, StdLon, AnglDin, & + PoLat, PoLon, NX*NY ) + + ! Clean up + DEALLOCATE( StdLat, StdLon ) + END IF + ! Write out rotation information + WRITE (NDSO,4203) PoLat, PoLon + WRITE (NDSO,4200) + WRITE (NDSO,4201) ( IX, IX=1,NX,NX/3) + WRITE (NDSO,4202) 1,(AnglDin(IX, 1), IX=1,NX,NX/3) + WRITE (NDSO,4202) NY,(AnglDin(IX,NY), IX=1,NX,NX/3) + IF ( FLAGUNR ) WRITE (NDSO,4204) + WRITE (NDSO,*) ' ' + +#endif +! +#ifdef W3_SMC + !! 7.i Read SMC grid cell and face integer arrays. + IF( GTYPE .EQ. SMCTYPE ) THEN + + !! Overwrite 2 parameters for SMC grid. JGLi03Mar2021 + DTMS = DTIMS + CTMAX = CFLSM +#endif +! +#ifdef W3_SMC + IF (FLGNML) THEN + NDSTR = NML_SMC%MCELS%IDF + IDLA = NML_SMC%MCELS%IDLA + IDFM = NML_SMC%MCELS%IDFM + RFORM = TRIM(NML_SMC%MCELS%FORMAT) + TNAME = TRIM(NML_SMC%MCELS%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvCelsk( 0:NRLv ) ) + READ (NDSTR,*) NLvCelsk + NCel=NLvCelsk(0) + NGLO=NCel + WRITE (NDSO,4004) NCel, NLvCelsk + + ALLOCATE ( IJKCelin( 5, NCel) ) + CALL INA2I ( IJKCelin, 5, NCel, 1, 5, 1, NCel, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index JEQT + IJKCelin( 2, :) = IJKCelin( 2, :) + JEQT + !!Li Offset to change i-index = 0 to regular grid index ISHFT + IJKCelin( 1, :) = IJKCelin( 1, :) + ISHFT + + WRITE (NDSO,4005) TNAME + WRITE (NDSO,4006) 1,(IJKCelin(ix, 1), ix=1,5) + WRITE (NDSO,4006) NCel,(IJKCelin(ix, NCel), ix=1,5) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%ISIDE%IDF + IDLA = NML_SMC%ISIDE%IDLA + IDFM = NML_SMC%ISIDE%IDFM + RFORM = TRIM(NML_SMC%ISIDE%FORMAT) + TNAME = TRIM(NML_SMC%ISIDE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvUFcsk( 0:NRLv ) ) + READ (NDSTR,*) NLvUFcsk + NUFc = NLvUFcsk(0) + NGUI = NUFc + WRITE (NDSO,4007) NUFc, NLvUFcsk + + ALLOCATE ( IJKUFcin( 7, NUFc) ) + CALL INA2I ( IJKUFcin, 7, NUFc, 1, 7, 1, NUFc, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKUFcin( 2, :) = IJKUFcin( 2, :) + JEQT + IJKUFcin( 1, :) = IJKUFcin( 1, :) + ISHFT + + WRITE (NDSO,4008) TNAME + WRITE (NDSO,4009) 1,(IJKUFcin(ix, 1), ix=1,7) + WRITE (NDSO,4009) NUFc,(IJKUFcin(ix, NUFc), ix=1,7) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%JSIDE%IDF + IDLA = NML_SMC%JSIDE%IDLA + IDFM = NML_SMC%JSIDE%IDFM + RFORM = TRIM(NML_SMC%JSIDE%FORMAT) + TNAME = TRIM(NML_SMC%JSIDE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NLvVFcsk( 0:NRLv ) ) + READ (NDSTR,*) NLvVFcsk + NVFc= NLvVFcsk(0) + NGVJ= NVFc + WRITE (NDSO,4010) NVFc, NLvVFcsk + + ALLOCATE ( IJKVFcin( 8, NVFc) ) + CALL INA2I ( IJKVFcin, 8, NVFc, 1, 8, 1, NVFc, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKVFcin( 2, :) = IJKVFcin( 2, :) + JEQT + IJKVFcin( 1, :) = IJKVFcin( 1, :) + ISHFT + + WRITE (NDSO,4011) TNAME + WRITE (NDSO,4012) 1,(IJKVFcin(ix, 1), ix=1,8) + WRITE (NDSO,4012) NVFc,(IJKVFcin(ix, NVFc), ix=1,8) + WRITE (NDSO,*) ' ' + + !!Li Subgrid obstruction for each SMCels. JGLi15Oct2014 + IF (FLGNML) THEN + NDSTR = NML_SMC%SUBTR%IDF + IDLA = NML_SMC%SUBTR%IDLA + IDFM = NML_SMC%SUBTR%IDFM + RFORM = TRIM(NML_SMC%SUBTR%FORMAT) + TNAME = TRIM(NML_SMC%SUBTR%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NCObst, JObs + WRITE (NDSO,4110) NCObst, JObs + + ALLOCATE ( IJKObstr( JObs, NCObst) ) + CALL INA2I ( IJKObstr, JObs, NCObst, 1, JObs, 1, NCObst, NDSTR, NDST, & + NDSE, IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + + WRITE (NDSO,4111) TNAME + WRITE (NDSO,4012) 1, (IJKObstr(ix, 1), ix=1,JObs) + WRITE (NDSO,4012) NCObst, (IJKObstr(ix, NCObst), ix=1,JObs) + WRITE (NDSO,*) ' ' + + !!Li Bounary cell sequential numbers are read only if NBISMC>0 + IF( NBISMC .GT. 0 ) THEN + IF (FLGNML) THEN + NDSTR = NML_SMC%BUNDY%IDF + IDLA = NML_SMC%BUNDY%IDLA + IDFM = NML_SMC%BUNDY%IDFM + RFORM = TRIM(NML_SMC%BUNDY%FORMAT) + TNAME = TRIM(NML_SMC%BUNDY%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + ALLOCATE ( NBICelin( NBISMC ) ) + CALL INA2I ( NBICelin, 1, NBISMC, 1, 1, 1, NBISMC, NDSTR, NDST, & + NDSE, IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + + WRITE (NDSO,4013) TNAME + WRITE (NDSO,4014) 1, NBICelin( 1) + WRITE (NDSO,4014) NBISMC, NBICelin(NBISMC) + WRITE (NDSO,*) ' ' + ENDIF + +#endif +! +#ifdef W3_SMC + !! 7.j Read Arctic grid cell and boundary cell integer arrays. + IF( ARCTC ) THEN + + IF (FLGNML) THEN + NDSTR = NML_SMC%MBARC%IDF + IDLA = NML_SMC%MBARC%IDLA + IDFM = NML_SMC%MBARC%IDFM + RFORM = TRIM(NML_SMC%MBARC%FORMAT) + TNAME = TRIM(NML_SMC%MBARC%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NARC, NBGL, NBAC + WRITE (NDSO,4015) NARC, NBGL, NBAC + + ALLOCATE ( IJKCelAC( 5, NARC) ) + CALL INA2I ( IJKCelAC, 5, NARC, 1, 5, 1, NARC, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index JEQT + IJKCelAC( 2, :) = IJKCelAC( 2, :) + JEQT + IJKCelAC( 1, :) = IJKCelAC( 1, :) + ISHFT + + WRITE (NDSO,4016) TNAME + WRITE (NDSO,4006) 1,(IJKCelAC(ix, 1), ix=1,5) + WRITE (NDSO,4006) NARC,(IJKCelAC(ix, NARC), ix=1,5) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%AISID%IDF + IDLA = NML_SMC%AISID%IDLA + IDFM = NML_SMC%AISID%IDFM + RFORM = TRIM(NML_SMC%AISID%FORMAT) + TNAME = TRIM(NML_SMC%AISID%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NAUI + WRITE (NDSO,4017) NAUI + + ALLOCATE ( IJKUFcAC( 7, NAUI) ) + CALL INA2I ( IJKUFcAC, 7, NAUI, 1, 7, 1, NAUI, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKUFcAC( 2, :) = IJKUFcAC( 2, :) + JEQT + IJKUFcAC( 1, :) = IJKUFcAC( 1, :) + ISHFT + !!Li Offset Arctic cell sequential numbers by global cell number NGLO + DO IP=1, NAUI + DO IX=4,7 + IF( IJKUFcAC(IX,IP) > 0 ) IJKUFcAC(IX,IP) = IJKUFcAC(IX,IP) + NGLO + ENDDO + ENDDO + + WRITE (NDSO,4018) TNAME + WRITE (NDSO,4009) 1,(IJKUFcAC(ix, 1), ix=1,7) + WRITE (NDSO,4009) NAUI,(IJKUFcAC(ix, NAUI), ix=1,7) + WRITE (NDSO,*) ' ' + + IF (FLGNML) THEN + NDSTR = NML_SMC%AJSID%IDF + IDLA = NML_SMC%AJSID%IDLA + IDFM = NML_SMC%AJSID%IDFM + RFORM = TRIM(NML_SMC%AJSID%FORMAT) + TNAME = TRIM(NML_SMC%AJSID%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFM, RFORM, TNAME + END IF + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='FORMATTED',STATUS='OLD',ERR=2000) + READ (NDSTR,*) NAVJ + WRITE (NDSO,4019) NAVJ + + ALLOCATE ( IJKVFcAC( 8, NAVJ) ) + CALL INA2I ( IJKVFcAC, 8, NAVJ, 1, 8, 1, NAVJ, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, 1, 0) + CLOSE(NDSTR) + !!Li Offset to change Equator index = 0 to regular grid index + IJKVFcAC( 2, :) = IJKVFcAC( 2, :) + JEQT + IJKVFcAC( 1, :) = IJKVFcAC( 1, :) + ISHFT + !!Li Offset Arctic cell sequential numbers by global cell number NGLO + DO IP=1, NAVJ + DO IY=4,7 + IF( IJKVFcAC(IY,IP) > 0 ) IJKVFcAC(IY,IP) = IJKVFcAC(IY,IP) + NGLO + ENDDO + ENDDO + + WRITE (NDSO,4020) TNAME + WRITE (NDSO,4012) 1,(IJKVFcAC(ix, 1), ix=1,8) + WRITE (NDSO,4012) NAVJ,(IJKVFcAC(ix, NAVJ), ix=1,8) + WRITE (NDSO,*) ' ' + + !!Li Reset total cell and face numbers + NCel = NGLO + NARC + NUFc = NGUI + NAUI + NVFc = NGVJ + NAVJ + !!Li Also append Arctic part into base level sub-loops + NLvCelsk(NRLv)=NLvCelsk(NRLv)+NARC + NLvUFcsk(NRLv)=NLvUFcsk(NRLv)+NAUI + NLvVFcsk(NRLv)=NLvVFcsk(NRLv)+NAVJ + !!Li Reset NBAC to total number of boundary cells. + NBAC = NBGL + NBAC + + ENDIF !! ARCTC section. + + ENDIF !! GTYPE .EQ. SMCTYPE +#endif +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 8. Finalize status maps +! 8.a Defines open boundary conditions for UNST grids +! + J = LEN_TRIM(UGOBCFILE) + IF (GTYPE.EQ.UNGTYPE.AND.UGOBCFILE(:J).NE.'unset') & + CALL READMSHOBC(NDSG,UGOBCFILE,TMPSTA,UGOBCOK) + IF ((GTYPE.EQ.UNGTYPE).AND.UGOBCAUTO.AND.(.NOT.UGOBCOK)) & + CALL UG_GETOPENBOUNDARY(TMPSTA,ZBIN,UGOBCDEPTH) +#ifdef W3_DEBUGSTP + WRITE(740,*) 'Printing ZBIN 4' + DO IX=1,NX + WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) + END DO +#endif +! +! 8.b Determine where to get the data +! + IF (FLGNML) THEN + NDSTR = NML_MASK%IDF + IDLA = NML_MASK%IDLA + IDFT = NML_MASK%IDFM + RFORM = TRIM(NML_MASK%FORMAT) + FROM = TRIM(NML_MASK%FROM) + TNAME = TRIM(NML_MASK%FILENAME) + IF (TNAME.EQ.'unset' .OR. TNAME.EQ.'UNSET') FROM='PART' + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF +! +! ... Data to be read in parts +! +#ifdef W3_DEBUGGRID + WRITE(740+IAPROC,*) 'FROM=', TRIM(FROM) +#endif + IF ( FROM .EQ. 'PART' ) THEN +! +! 8.b Update TMPSTA with input boundary data (ILOOP=1) +! and excluded points (ILOOP=2) +! + IF ( ICLOSE .EQ. ICLOSE_TRPL ) THEN + WRITE(NDSE,*)'PROGRAM W3GRID STATUS MAP CALCULATION IS '// & + 'NOT TESTED FOR TRIPOLE GRIDS FOR CASE WHERE USER OPTS '// & + 'TO READ DATA IN PARTS. STOPPING NOW (107).' + CALL EXTCDE ( 107 ) + END IF +#ifdef W3_DEBUGGRID + nbCase1=0 + nbCase2=0 + nbCase3=0 + nbCase4=0 + nbCase5=0 + nbCase6=0 + nbCase7=0 + nbCase8=0 +#endif + DO ILOOP=1, 2 +! + I = 1 + IF ( ILOOP .EQ. 1 ) THEN + WRITE (NDSO,979) 'boundary points' + NSTAT = 2 + ELSE + WRITE (NDSO,979) 'excluded points' + NSTAT = -1 + END IF + FIRST = .TRUE. +! + DO + IF (FLGNML) THEN + ! inbound points + IF (ILOOP.EQ.1) THEN + IF (NML_INBND_COUNT%N_POINT.GT.0 .AND. I.LE.NML_INBND_COUNT%N_POINT) THEN + IX = NML_INBND_POINT(I)%X_INDEX + IY = NML_INBND_POINT(I)%Y_INDEX + CONNCT = NML_INBND_POINT(I)%CONNECT + I=I+1 + ELSE + EXIT + END IF + ! excluded points + ELSE IF (ILOOP.EQ.2) THEN + IF (NML_EXCL_COUNT%N_POINT.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_POINT) THEN + IX = NML_EXCL_POINT(I)%X_INDEX + IY = NML_EXCL_POINT(I)%Y_INDEX + CONNCT = NML_EXCL_POINT(I)%CONNECT + I=I+1 + ELSE + EXIT + END IF + END IF + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) IX, IY, CONNCT + END IF +#ifdef W3_DEBUGGRID + WRITE(740+IAPROC,*) 'read IX=', IX + WRITE(740+IAPROC,*) 'read IY=', IY + WRITE(740+IAPROC,*) 'read CONNCT=', CONNCT +#endif + +! +! ... Check if last point reached. +! + IF (IX.EQ.0 .AND. IY.EQ.0) EXIT +! +! ... Check if point in grid. +! + IF (GTYPE.EQ.UNGTYPE.AND.(UGOBCAUTO.OR.UGOBCOK)) CYCLE + IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN + WRITE (NDSO,981) + WRITE (NDSO,*) ' ', IX, IY + CYCLE + END IF +! +! ... Check if intermediate points are to be added. +! +#ifdef W3_DEBUGGRID + WRITE(740+IAPROC,*) 'CONNCT=', CONNCT + WRITE(740+IAPROC,*) 'FIRST=', FIRST +#endif + IF ( CONNCT .AND. .NOT.FIRST ) THEN + IDX = IX - IXO + IDY = IY - IYO + IF ( IDX.EQ.0 .OR. IDY.EQ.0 .OR. & + ABS(IDX).EQ.ABS(IDY) ) THEN + NBA = MAX ( MAX(ABS(IDX),ABS(IDY))-1 , 0 ) + IF (IDX.NE.0) IDX = SIGN(1,IDX) + IF (IDY.NE.0) IDY = SIGN(1,IDY) + IX = IXO + IY = IYO + DO IBA=1, NBA + IX = IX + IDX + IY = IY + IDY + IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN + TMPSTA(IY,IX) = NSTAT + ELSE + WRITE(NDSO,*) 'WARNING: POINT (',IX,',',IY, & + ') CANNOT BE GIVEN THE STATUS ',NSTAT + END IF + END DO + IX = IX + IDX + IY = IY + IDY + ELSE + WRITE (NDSO,982) + WRITE (NDSO,*) ' ', IX , IY + WRITE (NDSO,*) ' ', IXO, IYO + END IF + END IF +! +! ... Check if point itself is to be added +! + IF ( TMPSTA(IY,IX).EQ.1 .OR. J.EQ.2 ) THEN +#ifdef W3_DEBUGGRID + nbCase2=nbCase2+1 +#endif + TMPSTA(IY,IX) = NSTAT + END IF +! +! ... Save data of previous point +! + IXO = IX + IYO = IY + FIRST = .FALSE. +! +! ... Branch back to read. +! + END DO +! +! 8.c Final processing excluded points +! + IF ( ILOOP .EQ. 2 ) THEN +! + I = 1 + DO + IF (FLGNML) THEN + ! excluded bodies + IF (NML_EXCL_COUNT%N_BODY.GT.0 .AND. I.LE.NML_EXCL_COUNT%N_BODY) THEN + IX = NML_EXCL_BODY(I)%X_INDEX + IY = NML_EXCL_BODY(I)%Y_INDEX + I=I+1 + ELSE + EXIT + END IF + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) IX, IY + END IF +! +! ... Check if last point reached. +! + IF (IX.EQ.0 .AND. IY.EQ.0) EXIT +! +! ... Check if point in grid. +! + IF (IX.LT.1 .OR. IX.GT.NX .OR. IY.LT.1 .OR. IY.GT.NY) THEN + WRITE (NDSO,981) + WRITE (NDSO,*) ' ', IX, IY + CYCLE + END IF +! +! ... Check if point already excluded +! + IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN + WRITE (NDSO,1981) + WRITE (NDSO,*) ' ', IX, IY + CYCLE + END IF +! +! ... Search for points to exclude +! + TMPMAP = TMPSTA + J = 1 + IX1 = IX + IY1 = IY +! + JJ = TMPSTA(IY,IX) +#ifdef W3_DEBUGGRID + nbCase3=nbCase3 + 1 +#endif + TMPSTA(IY,IX) = NSTAT + DO + NBT = 0 + DO IX=MAX(1,IX1-J), MIN(IX1+J,NX) + DO IY=MAX(1,IY1-J), MIN(IY1+J,NY) + IF ( TMPSTA(IY,IX) .EQ. JJ ) THEN + IF (IX.GT.1) THEN + IF (TMPSTA(IY ,IX-1).EQ.NSTAT & + .AND. TMPMAP(IY ,IX-1).EQ.JJ ) THEN +#ifdef W3_DEBUGGRID + nbCase4=nbCase4 + 1 +#endif + TMPSTA(IY,IX) = NSTAT + END IF + END IF + IF (IX.LT.NX) THEN + IF (TMPSTA(IY ,IX+1).EQ.NSTAT & + .AND. TMPMAP(IY ,IX+1).EQ.JJ ) THEN +#ifdef W3_DEBUGGRID + nbCase5=nbCase5 + 1 +#endif + TMPSTA(IY,IX) = NSTAT + END IF + END IF + IF (IY.LT.NY) THEN + IF (TMPSTA(IY+1,IX ).EQ.NSTAT & + .AND. TMPMAP(IY+1,IX ).EQ.JJ ) THEN +#ifdef W3_DEBUGGRID + nbCase6=nbCase6 + 1 +#endif + TMPSTA(IY,IX) = NSTAT + END IF + END IF + IF (IY.GT.1) THEN + IF (TMPSTA(IY-1,IX ).EQ.NSTAT & + .AND. TMPMAP(IY-1,IX ).EQ.JJ ) THEN +#ifdef W3_DEBUGGRID + nbCase7=nbCase7 + 1 +#endif + TMPSTA(IY,IX) = NSTAT + END IF + END IF + IF (TMPSTA(IY,IX).EQ.NSTAT) NBT = NBT + 1 + END IF + END DO + END DO +! + IF ( NBT .NE. 0 ) THEN + J = J + 1 + ELSE + EXIT + END IF + END DO + END DO +! +! ... Outer boundary excluded points +! + IF ( GTYPE.NE.UNGTYPE ) THEN + + DO IX=1, NX + IF ( TMPSTA( 1,IX) .EQ. 1 ) TMPSTA( 1,IX) = NSTAT + IF ( TMPSTA(NY,IX) .EQ. 1 ) TMPSTA(NY,IX) = NSTAT + END DO +! + IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN + DO IY=2, NY-1 + IF ( TMPSTA(IY, 1) .EQ. 1 ) TMPSTA(IY, 1) = NSTAT + IF ( TMPSTA(IY,NX) .EQ. 1 ) TMPSTA(IY,NX) = NSTAT + END DO + END IF + + END IF ! GTYPE +! + END IF ! ILOOP .EQ. 2 +! +! ... Branch back input / excluded points ( ILOOP in 8.b ) +! + END DO +#ifdef W3_DEBUGGRID + WRITE(740+IAPROC,*) 'nbCase1=', nbCase1 + WRITE(740+IAPROC,*) 'nbCase2=', nbCase2 + WRITE(740+IAPROC,*) 'nbCase3=', nbCase3 + WRITE(740+IAPROC,*) 'nbCase4=', nbCase4 + WRITE(740+IAPROC,*) 'nbCase5=', nbCase5 + WRITE(740+IAPROC,*) 'nbCase6=', nbCase6 + WRITE(740+IAPROC,*) 'nbCase7=', nbCase7 + WRITE(740+IAPROC,*) 'nbCase8=', nbCase8 + nbTMPSTA0=0 + nbTMPSTA1=0 + nbTMPSTA2=0 + DO IX=1,NX + DO IY=1,NY + WRITE(740+IAPROC,*) 'IX/IY/TMPSTA=', IX, IY, TMPSTA(IY,IX) + IF (TMPSTA(IY,IX) .eq. 0) nbTMPSTA0=nbTMPSTA0+1 + IF (TMPSTA(IY,IX) .eq. 1) nbTMPSTA1=nbTMPSTA1+1 + IF (TMPSTA(IY,IX) .eq. 2) nbTMPSTA2=nbTMPSTA2+1 + END DO + END DO + WRITE(740+IAPROC,*) 'nbTMPSTA0=', nbTMPSTA0 + WRITE(740+IAPROC,*) 'nbTMPSTA1=', nbTMPSTA1 + WRITE(740+IAPROC,*) 'nbTMPSTA2=', nbTMPSTA2 + FLUSH(740+IAPROC) +#endif +! + ELSE ! FROM .EQ. PART +! +! 8.d Read the map from file instead +! + NSTAT = -1 + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 + +!!Li Suspended for SMC grid though the file input line in ww3_grid.inp +!!Li is kept to divert the program into this block. JGLi15Oct2014 +!!Li + IF( GTYPE .NE. SMCTYPE ) THEN +!!Li +! + WRITE (NDSO,978) NDSTR, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME') WRITE (NDSO,974) TNAME +! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & + IOSTAT=IERR) + ELSE + OPEN (NDSTR, FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF + END IF +! + ALLOCATE ( READMP(NX,NY) ) + CALL INA2I ( READMP, NX, NY, 1, NX, 1, NY, NDSTR, NDST, & + NDSE, IDFT, RFORM, IDLA, 1, 0 ) +! + IF ( ICLOSE.EQ.ICLOSE_NONE ) THEN + DO IY=2, NY-1 + IF ( READMP( 1,IY) .EQ. 1 ) READMP( 1,IY) = 3 + IF ( READMP(NX,IY) .EQ. 1 ) READMP(NX,IY) = 3 + END DO + END IF +! + DO IX=1, NX + IF ( READMP(IX, 1) .EQ. 1 ) READMP(IX, 1) = 3 + IF ( READMP(IX,NY) .EQ. 1 .AND. ICLOSE .NE. ICLOSE_TRPL) & + READMP(IX,NY) = 3 + END DO +! + DO IY=1, NY + DO IX=1, NX + IF ( READMP(IX,IY) .EQ. 3 ) THEN + TMPSTA(IY,IX) = NSTAT + ELSE + TMPSTA(IY,IX) = READMP(IX,IY) + ! force to dry the sea points over zlim + IF ( ZBIN(IX,IY) .GT. ZLIM ) TMPSTA(IY,IX) = 0 + END IF + END DO + END DO + DEALLOCATE ( READMP ) +!!Li + ENDIF !! GTYPE .NE. SMCTYPE +! + END IF !FROM .NE. 'PART' +! +! 8.e Get NSEA and other counters +! + NSEA = 0 + NLAND = 0 + NBI = 0 + NBT = 0 +! + DO IX=1, NX + DO IY=1, NY + IF ( TMPSTA(IY,IX) .GT. 0 ) NSEA = NSEA + 1 + IF ( TMPSTA(IY,IX) .EQ. 0 ) NLAND = NLAND + 1 + IF ( TMPSTA(IY,IX) .LT. 0 ) NBT = NBT + 1 + IF ( TMPSTA(IY,IX) .EQ. 2 ) NBI = NBI + 1 + END DO + END DO +! +#ifdef W3_SMC + IF( GTYPE .EQ. SMCTYPE ) THEN + !Li Moved before FLBPI is defined with NBI value. JGLi05Jun2015 + !Li Overwrite NSEA with NCel for SMC grid. + NSEA = NCel + !Li Use input NBI number for SMC grid because merged + !Li cells are over-counted by model. + NBI = NBISMC + !Li No land points are used in SMC grid. JGLi26Feb2016 + NLAND = 0 + ENDIF !! GTYPE .EQ. SMCTYPE +#endif +! + WRITE (NDSO,980) + FLBPI = NBI .GT. 0 + IF ( .NOT. FLBPI ) THEN + WRITE (NDSO,985) + ELSE + WRITE (NDSO,986) NBI +#ifdef W3_O1 + IF ( FLAGLL ) THEN + WRITE (NDSO, 987) + ELSE + WRITE (NDSO,1987) + END IF + IBI = 1 + DO IY=1, NY + DO IX=1, NX + IF (GTYPE.NE.UNGTYPE) THEN + X = FACTOR * ( XGRDIN(IX,IY) ) + Y = FACTOR * ( YGRDIN(IX,IY) ) + ELSE + X = FACTOR * XYB(IX,1) + Y = FACTOR * XYB(IX,2) + END IF + IF ( TMPSTA(IY,IX).EQ.2 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO, 988) IBI, IX, IY, X, Y + ELSE + WRITE (NDSO,1988) IBI, IX, IY, X, Y + END IF + IBI = IBI + 1 + END IF + END DO + END DO +#endif + END IF +! + WRITE (NDSO,1980) + IF ( NBT .EQ. 0 ) THEN + WRITE (NDSO,1985) + ELSE + WRITE (NDSO,1986) NBT + END IF +! +! 8.f Set up all maps +! + CALL W3DIMX ( 1, NX, NY, NSEA, NDSE, NDST & +#ifdef W3_SMC + , NCel, NUFc, NVFc, NRLv, NBSMC & + , NARC, NBAC, NSPEC & +#endif + ) +#ifdef W3_SMC + WRITE (NDSO,4021) NCel +#endif +! +! 8.g Activation of reflections and scattering + FFACBERG=FACBERG +#ifdef W3_REF1 + REFPARS(1)=REFCOAST + REFPARS(2)=REFSUBGRID + REFPARS(3)=REFUNSTSOURCE + REFPARS(4)=REFICEBERG + REFPARS(6)=REFFREQ + REFPARS(7)=REFSLOPE + REFPARS(8)=REFCOSP_STRAIGHT + REFPARS(9)=REFRMAX + REFPARS(10)=REFFREQPOW + IF (GTYPE.EQ.UNGTYPE) REFPARS(2:5)=0. + IF (REFMAP.EQ.0) THEN + REFLC(3,:)=REFPARS(7) + END IF +#endif + + + IF (GTYPE.NE.UNGTYPE) THEN + DO IY=1, NY + DO IX=1, NX + XGRD(IY,IX) = XGRDIN(IX,IY) + YGRD(IY,IX) = YGRDIN(IX,IY) + END DO + END DO + DEALLOCATE ( XGRDIN, YGRDIN ) + CALL W3GNTX ( 1, 6, 6 ) + ELSE +! +!FA: This distinction between structured and unstructured +! should be removed when XYB is replaced by XGRD and YGRD +! + DO IX=1, NX + XGRD(:,IX) = XYB(IX,1) + YGRD(:,IX) = XYB(IX,2) + END DO + END IF ! GTYPE +! +#ifdef W3_SMC + !!Li Shelter MAPSTA LLG definition for SMC + IF( GTYPE .NE. SMCTYPE ) THEN +#endif +! + MAPSTA = TMPSTA + MAPFS = 0 +! +#ifdef W3_T + ALLOCATE ( MAPOUT(NX,NY) ) + MAPOUT = 0 +#endif +! +#ifdef W3_T + IX3 = 1 + NX/60 + IY3 = 1 + NY/60 + CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 1, 0., & + 1, NX, IX3, 1, NY, IY3, 'Zb', 'm') +#endif +! +#ifdef W3_DEBUGSTP + WRITE(740,*) 'Printing ZBIN 5' + DO IX=1,NX + WRITE(740,*) 'IX/ZBIN=', IX, ZBIN(IX,1) + END DO +#endif + TRNX = 0. + TRNY = 0. +! + ISEA = 0 + DO IY=1, NY + DO IX=1, NX + IF ( TMPSTA(IY,IX) .EQ. NSTAT ) THEN + MAPSTA(IY,IX) = 0 + MAPST2(IY,IX) = 1 + TMPSTA(IY,IX) = 3 + ELSE + MAPSTA(IY,IX) = TMPSTA(IY,IX) + MAPST2(IY,IX) = 0 + END IF + IF ( MAPSTA(IY,IX) .NE. 0 ) THEN + ISEA = ISEA + 1 + MAPFS (IY,IX) = ISEA + ZB(ISEA) = ZBIN(IX,IY) +#ifdef W3_T + MAPOUT(IX,IY) = 1 +#endif + MAPSF(ISEA,1) = IX + MAPSF(ISEA,2) = IY + IF ( FLAGLL ) THEN + Y = YGRD(IY,IX) + CLATS(ISEA) = COS(Y*DERA) + CLATIS(ISEA) = 1. / CLATS(ISEA) + CTHG0S(ISEA) = - TAN(DERA*Y) / RADIUS + ELSE + CLATS(ISEA) = 1. + CLATIS(ISEA) = 1. + CTHG0S(ISEA) = 0. + END IF + END IF + +!/ ------------------------------------------------------------------- / + +! notes: Oct 22 2012: I moved the following "if-then" statement from +! inside the "IF ( MAPSTA(IY,IX) .NE. 0 )" statement to outside that +! statement. This is needed since later on, ATRNX is computed from +! TRNX(ix-1) , TRNX(ix) etc. which causes boundary effects if the +! MAPSTA=0 values are set to TRNX=0 + + IF ( TRFLAG .NE. 0 ) THEN + TRNX(IY,IX) = 1. - OBSX(IX,IY) + TRNY(IY,IX) = 1. - OBSY(IX,IY) + END IF + + END DO + END DO +#ifdef W3_DEBUGSTP + DO ISEA=1,NSEA + WRITE(740,*) 'ISEA,ZB=', ISEA, ZB(ISEA) + END DO + FLUSH(740) +#endif +! +#ifdef W3_SMC + !!Li SMC grid definition of mapping arrays. + ELSE +#endif +! +#ifdef W3_SMC + !!Li Pass refined level cell and face counts to NLv*(NRLv) + NLvCel(0)=0 + NLvUFc(0)=0 + NLvVFc(0)=0 + DO IP = 1, NRLv + NLvCel(IP)=NLvCelsk(IP) + NLvCel(IP-1) + NLvUFc(IP)=NLvUFcsk(IP) + NLvUFc(IP-1) + NLvVFc(IP)=NLvVFcsk(IP) + NLvVFc(IP-1) + ENDDO + WRITE (NDSO,4022) NLvCel + WRITE (NDSO,4023) NLvUFc + WRITE (NDSO,4024) NLvVFc + + !Li Redefine MAPSF MAPFS MAPSTA MAPST2 CLATS and ZB for SMC Grid, + !Li using SMC grid cell array and assuming NSEA=NCel. + MAPSTA = 0 + MAPST2 = 1 + MAPFS = 0 + + !Li Pass input SMC arrays to newly declared grid arrays. + WRITE (NDSO,4025) NCel + IJKCel(:, 1:NGLO)=IJKCelin(:, 1:NGLO) + IJKUFc(:, 1:NGUI)=IJKUFcin(:, 1:NGUI) + IJKVFc(:, 1:NGVJ)=IJKVFcin(:, 1:NGVJ) + !Li Append Arctic part + IF( ARCTC ) THEN + IJKCel(:, NGLO+1:NCel)=IJKCelAC(:, 1:NARC) + IJKUFc(:, NGUI+1:NUFc)=IJKUFcAC(:, 1:NAUI) + IJKVFc(:, NGVJ+1:NVFc)=IJKVFcAC(:, 1:NAVJ) + ENDIF !! ARCTC + + WRITE (NDSO,4026) + WRITE (NDSO,4006) 1,(IJKCel(ix, 1), ix=1,5) + JJ=NCel + WRITE (NDSO,4006) JJ,(IJKCel(ix, JJ), ix=1,5) + WRITE (NDSO,*) ' ' + WRITE (NDSO,4027) + WRITE (NDSO,4009) 1,(IJKUFc(ix, 1), ix=1,7) + JJ=NUFc + WRITE (NDSO,4009) JJ,(IJKUFc(ix, JJ), ix=1,7) + WRITE (NDSO,*) ' ' + WRITE (NDSO,4028) + WRITE (NDSO,4012) 1,(IJKVFc(ix, 1), ix=1,8) + JJ=NVFc + WRITE (NDSO,4012) JJ,(IJKVFc(ix, JJ), ix=1,8) + WRITE (NDSO,*) ' ' + + !Li Boundary -9 to 0 cells for cell x-size 2**n + !Li Note the position indice for bounary cell are not used. + IJKCel(1, -9:0)=0 + !Li Use Equator Y index for boundary cells. JGLi04Apr2011 + !Li IJKCel(2, -9:0)=0 + IJKCel(2, -9:0)=JEQT + IJKCel(3, 0)=1 + IJKCel(4, 0)=1 + !Li Use minimum 10 m depth for boundary cells. + !Li Y-size is restricted below base-cell value. + !Li For refined boundary cells, its y-size is replaced with + !Li the inner cell y-size for flux gradient. + IJKCel(5, 0)=10 + DO ip=1,9 + IJKCel(3,-ip)=IJKCel(3,-ip+1)*2 + IK=MIN(ip, NRLv-1) + IJKCel(4,-ip)=2**IK + IJKCel(5,-ip)=10 + ENDDO + WRITE (NDSO,4029) + DO ip=0, -9, -1 + WRITE (NDSO,4030) IJKCel(:,ip) + ENDDO + + WRITE (NDSO,4031) NCel + !Li Multi-resolution SMC grid requires rounding of x, y indices + !Li by a factor MRFct. + MRFct = 2**(NRLv - 1) + WRITE (NDSO,4032) MRFct + + !Li Cosine for SMC uses refined latitude increment. + SYMR = SY*DERA/FLOAT( MRFct ) + !Li Reference y point for adjusted cell j=0 in radian. JGLi16Feb2016 + YJ0R = ( Y0 - 0.5*SY )*DERA + + DO ISEA=1, NCel + !Li There is no polar cell row so it is mapped to last row. + IF( ARCTC .AND. (ISEA .EQ. NCel) ) THEN + IX=1 + IY=NY + IK=1 + JS=1 + ELSE + IX=IJKCel(1,ISEA)/MRFct + 1 + IY=IJKCel(2,ISEA)/MRFct + 1 + IK=MAX(1, IJKCel(3,ISEA)/MRFct) + JS=MAX(1, IJKCel(4,ISEA)/MRFct) + ENDIF + + ! Check that IX, IY are in the bound of [1,NX] and [1,NY] respec. + IF ((IX+IK-1 .GT. NX) .OR. (IX .LE. 0)) THEN + WRITE (NDSE,1014) ISEA, IX, IX+IK-1, NX + CALL EXTCDE(65) + END IF + + IF ((IY+JS-1 .GT. NY) .OR. (IY .LE. 0)) THEN + WRITE (NDSE,1015) ISEA, IY, IY+JS-1, NY + CALL EXTCDE(65) + END IF + + !Li Minimum DMIN depth is used as well for SMC. + ZB(ISEA)= - MAX( DMIN, FLOAT( IJKCel(5, ISEA) ) ) + MAPFS(IY:IY+JS-1,IX:IX+IK-1) = ISEA + MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 1 + MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 + MAPSF(ISEA,1) = IX + MAPSF(ISEA,2) = IY + MAPSF(ISEA,3) = IY + (IX -1)*NY + + !Li New variable CLATS to hold cosine latitude at cell centre. + !Li Also added CLATIS and CTHG0S for version 4.08. + !Li Use adjusted j-index to calculate cell centre y from YJ0R. + Y = YJ0R + SYMR*( FLOAT(IJKCel(2,ISEA))+0.5*FLOAT(IJKCel(4,ISEA)) ) + !Li Arctic polar cell does not need COS(LAT), set 1 row down. + IF(Y .GE. HPI-0.1*SYMR) Y=HPI - SYMR*0.5*FLOAT( MRFct ) + + CLATS(ISEA) = COS( Y ) + CLATIS(ISEA)= 1. / CLATS(ISEA) + CTHG0S(ISEA)= - TAN( Y ) / RADIUS + !!Li Sub-grid obstruction is set zero beyond NCObst cells. + IF(ISEA .GT. NCObst) THEN + TRNMX=1.0 + TRNMY=1.0 + ELSE + !!Li Present obstruction is isotropic and in percentage. + TRNMX=1.0 - IJKObstr(1, ISEA)*0.01 + TRNMY=1.0 - IJKObstr(JObs, ISEA)*0.01 + ENDIF + CTRNX(ISEA) = MAX(0.11, TRNMX) + CTRNY(ISEA) = MAX(0.11, TRNMY) + END DO + !!Li Transparency for boundary cells are 1.0 JGLi16Jan2012 + CTRNX(-9:0) = 1.0 + CTRNY(-9:0) = 1.0 + !!Li Check range of MAPSF and MAPFS + WRITE (NDSO,4033) MINVAL( MAPSF(:,1) ), MAXVAL( MAPSF(:,1) ) + WRITE (NDSO,4034) MINVAL( MAPSF(:,2) ), MAXVAL( MAPSF(:,2) ) + WRITE (NDSO,4035) MINVAL( MAPSF(:,3) ), MAXVAL( MAPSF(:,3) ) + WRITE (NDSO,4036) MINVAL( MAPFS(:,:) ), MAXVAL( MAPFS(:,:) ) + + !Li New variable CLATF to hold cosine latitude at cell V face. + DO IP = 1, NVFC + ! CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP) - JEQT) ) + !Li Use adjusted j-index to calculate cell face Y from YJ0R. + CLATF(IP) = COS( SYMR*FLOAT(IJKVFc(2,IP)) + YJ0R ) + ENDDO + IF(NBISMC .GT. 0) THEN + !Li Save input boundary SMC list to ISMCBP(NBSMC) + ISMCBP(1:NBISMC) = NBICelin(1:NBISMC) + !Li Reset MAPSTA for boundary cells if any. + DO IP=1, NBISMC + ISEA = NBICelin(IP) + IX=IJKCel(1,ISEA)/MRFct + 1 + IY=IJKCel(2,ISEA)/MRFct + 1 + IK=MAX(1, IJKCel(3,ISEA)/MRFct) + JS=MAX(1, IJKCel(4,ISEA)/MRFct) + MAPSTA(IY:IY+JS-1,IX:IX+IK-1) = 2 + MAPST2(IY:IY+JS-1,IX:IX+IK-1) = 0 + ENDDO + ENDIF + +#endif +! +#ifdef W3_SMC + !Li Define rotation angle for Arctic cells. + IF( ARCTC ) THEN + + PoLonAC = 179.999 + PoLatAC = 0.001 + ALLOCATE( XLONAC(NARC),YLATAC(NARC),ELONAC(NARC),ELATAC(NARC) ) + DO ISEA=NGLO+1, NCel + !Li There is no polar cell row so it is mapped to last row. + IF(ISEA .EQ. NCel) THEN + IX=1 + IY=NY + IK=1 + JS=1 + ELSE + IX=IJKCel(1,ISEA)/MRFct + 1 + IY=IJKCel(2,ISEA)/MRFct + 1 + IK=MAX(1, IJKCel(3,ISEA)/MRFct) + JS=MAX(1, IJKCel(4,ISEA)/MRFct) + ENDIF + XLONAC(ISEA-NGLO)= X0 + REAL(IX-1+IK/2)*SX + YLATAC(ISEA-NGLO)= Y0 + REAL(IY-1+JS/2)*SY + ENDDO + + CALL W3LLTOEQ ( YLATAC, XLONAC, ELATAC, ELONAC, & + & ANGARC, PoLatAC, PoLonAC, NARC ) + + WRITE (NDSO,4037) NARC + WRITE (NDSO,4038) (ANGARC(ix), ix=1,NARC,NARC/8) + +#endif +! +#ifdef W3_SMC + !Li Mapping Arctic boundary cells with inner model cells + DO IP=1, NBAC + IX=IJKCel(1,IP+NGLO) + IY=IJKCel(2,IP+NGLO) + DO ISEA=1, NGLO + IF( (IX .EQ. IJKCel(1,ISEA)) .AND. & + & (IY .EQ. IJKCel(2,ISEA)) ) THEN + ICLBAC(IP) = ISEA + ENDIF + ENDDO + ENDDO + WRITE (NDSO,4039) NBAC + WRITE (NDSO,4040) (ICLBAC(ix), ix=1,NBAC,NBAC/8) + + !Li Redefine GCT term factor for Arctic part or the netative of + !Li tangient of rotated latitude divided by radius. JGLi14Sep2015 + DO ISEA=NGLO+1, NCel-1 + CTHG0S(ISEA)= - TAN( ELATAC(ISEA-NGLO)*DERA ) / RADIUS + ENDDO + CTHG0S(NCel)=0.0 + + ENDIF !! ARCTC section. +#endif +! +#ifdef W3_SMC + ENDIF !! (GTYPE .NE. SMCTYPE) ELSE SMCTYPE block. +#endif +! +#ifdef W3_RTD + !Li Assign rotated grid angle for all sea points. JGLi01Feb2016 + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + AnglD(ISEA) = AnglDin(IX,IY) + END DO +#endif +! +#ifdef W3_T + CALL PRTBLK (NDST, NX, NY, NX, ZBIN, MAPOUT, 0, 0., & + 1, NX, IX3, 1, NY, IY3, 'Sea points', 'm') + DEALLOCATE ( MAPOUT ) +#endif +! + DO ISP=1, NSPEC+NTH + MAPWN(ISP) = 1 + (ISP-1)/NTH + MAPTH(ISP) = 1 + MOD(ISP-1,NTH) + END DO +! +#ifdef W3_O2 + NMAP = 1 + (NX-1)/NCOL + WRITE (NDSO,1100) NMAP + DO IMAP=1, NMAP + IX0 = 1 + (IMAP-1)*NCOL + IXN = MIN ( NX , IMAP*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (TMPSTA(IY,IX),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1102) +#endif + +#ifdef W3_O2a + OPEN (NDSM,FILE=TRIM(FNMPRE)//'mask.ww3') + DO IY=1, NY + WRITE (NDSM,998) MIN(1,MAPSTA(IY,:)) + END DO + CLOSE (NDSM) +#endif +! +#ifdef W3_O2b + IF ( TRFLAG .GT. 0 ) THEN + NMAPB = 1 + (NX-1)/NCOL + WRITE (NDSO,1103) 'X', NMAPB + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(10.*OBSX(IX,IY)),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1104) + WRITE (NDSO,1103) 'Y', NMAPB + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(10.*OBSY(IX,IY)),IX=IX0,IXN) + END DO + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1104) + END IF +#endif +! +#ifdef W3_O2c + OPEN (NDSM,FILE=TRIM(FNMPRE)//'mapsta.ww3', RECL=2*NX*NY*50+1) + DO IY=NY,1, -1 + DO IX=1,NX + DO I=1,50 + WRITE (NDSM,1998,ADVANCE='NO') (TMPSTA(IY,IX)) + END DO + END DO + END DO + CLOSE (NDSM) +#endif +! + +#ifdef W3_IG1 + IGPARS(1)=IGMETHOD + IGPARS(2)=IGADDOUTP + IGPARS(3)=IGSOURCE + IGPARS(4)=0 + IF (IGBCOVERWRITE) IGPARS(4)=IGPARS(4)+1 + IF (IGSWELLMAX) IGPARS(4)=IGPARS(4)+2 + IGPARS(5)=1 + DO IK=1,NK + IF (SIG(IK)*TPIINV.LT.IGMAXFREQ) IGPARS(5)=IK + END DO + IGMINDEP=MINVAL(ZB*(-1.)-2) ! -2 / +2 is there for water level changes + IGMAXDEP=MAXVAL(ZB*(-1.)+2) + IF (IGSOURCEATBP.EQ.1) IGMINDEP=1. ! should use true minimum depth ... + IGPARS(6)=1+NINT(LOG(MAX(IGMAXDEP,1.0)/MAX(IGMINDEP,1.0))/LOG(1.1)) + IGPARS(7)=MAX(IGMINDEP,1.0) + IGPARS(8)=IGSOURCEATBP + IGPARS(9)=IGKDMIN + IGPARS(10)=IGFIXEDDEPTH + IGPARS(11)=IGEMPIRICAL**2 + IGPARS(12)=IGSTERMS +#endif +! +#ifdef W3_IC2 + IC2PARS(:)=0. + IF (IC2DISPER) IC2PARS(1)=1. + IC2PARS(2)=IC2TURB + IC2PARS(3)=IC2ROUGH + IC2PARS(4)=IC2REYNOLDS + IC2PARS(5)=IC2SMOOTH + IC2PARS(6)=IC2VISC + IC2PARS(7)=IC2TURBS + IC2PARS(8)=IC2DMAX +#endif +! +#ifdef W3_IC3 + IC3PARS(:)=0. + IC3PARS(1)=IC3MAXTHK + IC3PARS(2)=IC2TURB + IC3PARS(3)=IC2ROUGH + IC3PARS(4)=IC2REYNOLDS + IC3PARS(5)=IC2SMOOTH + IC3PARS(6)=IC2VISC + IC3PARS(7)=IC2TURBS + IC3PARS(8)=IC3MAXCNC + IF (IC3CHENG) IC3PARS(9)=1.0 + IC3PARS(10)=IC3HILIM + IC3PARS(11)=IC3KILIM + IF (USECGICE) IC3PARS(12)=1.0 + IC3PARS(13)=IC3HICE + IC3PARS(14)=IC3VISC + IC3PARS(15)=IC3DENS + IC3PARS(16)=IC3ELAS +#endif +! +#ifdef W3_IC4 + IC4PARS(1)=IC4METHOD + IC4_KI=IC4KI + IC4_FC=IC4FC +#endif +! +#ifdef W3_IC5 + IC5PARS(:)=0. + IC5PARS(1)=IC5MINIG + IC5PARS(2)=IC5MINWT + IC5PARS(3)=IC5MAXKRATIO + IC5PARS(4)=IC5MAXKI + IC5PARS(5)=IC5MINHW + IC5PARS(6)=IC5MAXITER + IC5PARS(7)=IC5RKICK + IC5PARS(8)=IC5KFILTER + IC5PARS(9)=IC5VEMOD +#endif +! +#ifdef W3_IS2 + IS2PARS(1) = ISC1 + IS2PARS(2) = IS2BACKSCAT + IS2PARS(3)=0. + IF (IS2BREAK) IS2PARS(3)=1. + IS2PARS(4)=IS2C2 + IS2PARS(5)=IS2C3 + IS2PARS(6)=0. + IF (IS2DISP) IS2PARS(6)=1. + IS2PARS(7)=IS2DAMP + IS2PARS(8)=IS2FRAGILITY + IS2PARS(9)=IS2DMIN + IS2PARS(10)=0. + IF (IS2DUPDATE) IS2PARS(10)=1. + IS2PARS(11)=IS2CONC + IS2PARS(12)=ABS(IS2CREEPB) + IS2PARS(13)=IS2CREEPC + IS2PARS(14)=IS2CREEPD + IS2PARS(15)=IS2CREEPN + IS2PARS(16)=IS2BREAKE + IS2PARS(17)=IS2BREAKF + IS2PARS(18)=IS2WIM1 + IS2PARS(19)=IS2FLEXSTR + IS2PARS(20)=0. + IF (IS2ISOSCAT) IS2PARS(20)=1. + IS2PARS(21)=IS2ANDISD + IS2PARS(22)=IS2ANDISN + IS2PARS(23)=0. + IF (IS2ANDISB) IS2PARS(23)=1. + IS2PARS(24)=IS2ANDISE +#endif +! +! 9.d Estimates shoreline direction for reflection +! and shoreline treatment in general for UNST grids. +! NB: this is updated with moving water levels in W3ULEV +! AR: this is not anymore needed and will be deleted ... +! + IF (GTYPE.EQ.UNGTYPE) THEN + CALL SETUGIOBP +#ifdef W3_REF1 + ELSE + CALL W3SETREF +#endif + END IF +#ifdef W3_REF1 +! +! 9.a Reads shoreline slope (whith REF1 switch only) +! + ALLOCATE ( REFD(NX,NY), REFD2(NX,NY), REFS(NX,NY) ) + IF (REFMAP.EQ.0) THEN + REFS(:,:)=1. + ELSE +! +! 9.b Info from input file +! + IF (FLGNML) THEN + NDSTR = NML_SLOPE%IDF + VSC = NML_SLOPE%SF + IDLA = NML_SLOPE%IDLA + IDFT = NML_SLOPE%IDFM + RFORM = TRIM(NML_SLOPE%FORMAT) + FROM = TRIM(NML_SLOPE%FROM) + TNAME = TRIM(NML_SLOPE%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF +! + IF ( ABS(VSC) .LT. 1.E-7 ) VSC = 1. + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 +! + WRITE (NDSO,1977) NDSTR, VSC, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME +! +! 9;c Open file and check if necessary +! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE IF ( NDSTR .EQ. NDSG ) THEN + IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & + ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN + WRITE (NDSE,1005) IDFM, IDFT + CALL EXTCDE (24) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & + IOSTAT=IERR) + ELSE + OPEN (NDSTR, FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF !end of (FROM.EQ.'NAME') + END IF !end of ( IDFT .EQ. 3 ) + END IF !end of ( NDSTR .EQ. NDSG ) +! +! 9.d Read the data +! +! CALL INA2R ( REFD, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & +! IDFM, RFORM, IDLA, VSC, 0.0) +! + IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) +! +! CALL INA2R ( REFD2, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & +! IDFM, RFORM, IDLA, VSC, 0.0) + CALL INA2R ( REFS, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, 0.0) + DO ISEA=1,NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + REFLC(3,ISEA) = REFS(IX,IY)*REFMAP + END DO +#endif +! +#ifdef W3_REF1 + NMAPB = 1 + (NX-1)/NCOL + WRITE (NDSO,1105) NMAPB +#endif +#ifdef W3_T +#ifdef W3_REF1 + WRITE(NDSO,*) 'Maximum slope for reflection:',MAXVAL(REFS*REFMAP) +#endif +#endif +! +#ifdef W3_REF1 + DO IMAPB=1, NMAPB + IX0 = 1 + (IMAPB-1)*NCOL + IXN = MIN ( NX , IMAPB*NCOL ) +#endif +#ifdef W3_T +#ifdef W3_REF1 + DO IY=NY,1,-1 + WRITE (NDSO,1101) (NINT(100.*REFS(IX,IY)*REFMAP),IX=IX0,IXN) + END DO +#endif +#endif +#ifdef W3_REF1 + WRITE (NDSO,*) ' ' + END DO + WRITE (NDSO,1106) +! + WRITE (NDSO,*) +! + END IF !end of (REFMAP.EQ.0) +#endif +! + DEALLOCATE ( ZBIN, TMPSTA, TMPMAP ) +#ifdef W3_RTD + DEALLOCATE ( AnglDin ) +#endif +! +! 9.e Reads bottom information from file +! +#ifdef W3_BT4 + ALLOCATE ( SED_D50FILE(NX,NY)) + IF ( SEDMAPD50 ) THEN + +! +! 9.e.1 Info from input file +! + IF (FLGNML) THEN + NDSTR = NML_SED%IDF + VSC = NML_SED%SF + IDLA = NML_SED%IDLA + IDFT = NML_SED%IDFM + RFORM = TRIM(NML_SED%FORMAT) + FROM = TRIM(NML_SED%FROM) + TNAME = TRIM(NML_SED%FILENAME) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=2001,ERR=2002) NDSTR, VSC, IDLA, IDFT, RFORM, & + FROM, TNAME + END IF +! + IF ( ABS(VSC) .LT. 1.E-7 ) THEN + VSC = 1. + ELSE +! WARNING TO BE ADDED ... + END IF + IF (IDLA.LT.1 .OR. IDLA.GT.4) IDLA = 1 + IF (IDFT.LT.1 .OR. IDFT.GT.3) IDFT = 1 +! + WRITE (NDSO,1978) NDSTR, VSC, IDLA, IDFT + IF (IDFT.EQ.2) WRITE (NDSO,973) RFORM + IF (FROM.EQ.'NAME' .AND. NDSG.NE.NDSTR) WRITE (NDSO,974) TNAME +! +! 9.e.2 Open file and check if necessary +! + IF ( NDSTR .EQ. NDSI ) THEN + IF ( IDFT .EQ. 3 ) THEN + WRITE (NDSE,1004) NDSTR + CALL EXTCDE (23) + ELSE + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + END IF + ELSE IF ( NDSTR .EQ. NDSG ) THEN + IF ( ( IDFM.EQ.3 .AND. IDFT.NE.3 ) .OR. & + ( IDFM.NE.3 .AND. IDFT.EQ.3 ) ) THEN + WRITE (NDSE,1005) IDFM, IDFT + CALL EXTCDE (24) + END IF + ELSE + IF ( IDFT .EQ. 3 ) THEN + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + FORM='UNFORMATTED',STATUS='OLD',ERR=2000, & + IOSTAT=IERR) + ELSE + OPEN (NDSTR, FORM='UNFORMATTED', & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + ELSE + IF (FROM.EQ.'NAME') THEN + OPEN (NDSTR,FILE=TRIM(FNMPRE)//TNAME, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + ELSE + OPEN (NDSTR, & + STATUS='OLD',ERR=2000,IOSTAT=IERR) + END IF + END IF + END IF +! +! 9.e.3 Read the data +! + CALL INA2R ( SED_D50FILE, NX, NY, 1, NX, 1, NY, NDSTR, NDST, NDSE, & + IDFM, RFORM, IDLA, VSC, VOF) +! + IF ( NDSTR .EQ. NDSI ) CALL NEXTLN ( COMSTR , NDSI , NDSE ) +! + WRITE (NDSO,*) 'Min and Max values of grain sizes:',MINVAL(SED_D50FILE), MAXVAL(SED_D50FILE) + WRITE (NDSO,*) +! + ELSE + SED_D50FILE(:,:)=SED_D50_UNIFORM + END IF +! + DO IY=1, NY + DO IX=1, NX + ISEA = MAPFS (IY,IX) + SED_D50(ISEA) = SED_D50FILE(IX,IY) + SED_D50(ISEA) = MAX(SED_D50(ISEA),1E-5) + ! Critical Shields number, Soulsby, R.L. and R J S W Whitehouse + ! Threshold of sed. motion in coastal environments, Proc. Pacific Coasts and + ! ports, 1997 conference, Christchurch, p149-154, University of Cantebury, NZ + SED_DSTAR=(GRAV*(SED_SG-1)/nu_water**2)**(0.333333)*SED_D50(ISEA) + SED_PSIC(ISEA)=0.3/(1+1.2*SED_DSTAR)+0.55*(1-exp(-0.02*SED_DSTAR)) +#endif + + +#ifdef W3_BT4 + END DO + END DO +#endif +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 10. Prepare output boundary points. +! ILOOP = 1 to count NFBPO and NBO +! ILOOP = 2 to fill data arrays +! + WRITE (NDSO,990) + IF ( .NOT. FLGNML ) & + OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_grid.scratch',FORM='FORMATTED') +! + DO ILOOP = 1, 2 +! + IF ( ILOOP.EQ.2 ) CALL W3DMO5 ( 1, NDST, NDSE, 2 ) +! + I = 1 + NBOTOT = 0 + NFBPO = 0 + NBO(0) = 0 + NBO2(0)= 0 + FIRST = .TRUE. + IF ( .NOT. FLGNML ) THEN + REWIND (NDSS) + IF ( ILOOP .EQ. 1 ) THEN + NDSI2 = NDSI + ELSE + NDSI2 = NDSS + END IF + END IF +! + DO + IF (FLGNML) THEN + ! outbound lines + IF (NML_OUTBND_COUNT%N_LINE.GT.0 .AND. I.LE.NML_OUTBND_COUNT%N_LINE) THEN + XO0 = NML_OUTBND_LINE(I)%X0 + YO0 = NML_OUTBND_LINE(I)%Y0 + DXO = NML_OUTBND_LINE(I)%DX + DYO = NML_OUTBND_LINE(I)%DY + NPO = NML_OUTBND_LINE(I)%NP + I=I+1 + ELSE + NPO=0 + END IF + ELSE + CALL NEXTLN ( COMSTR , NDSI2 , NDSE ) + READ (NDSI2,*,END=2001,ERR=2002) XO0, YO0, DXO, DYO, NPO + END IF +! + IF ( .NOT. FLGNML .AND. ILOOP .EQ. 1 ) THEN + BACKSPACE (NDSI) + READ (NDSI,'(A)') LINE + WRITE (NDSS,'(A)') LINE + END IF +! +! ... Check if new file to be used +! + FIRST = FIRST .OR. NPO.LE.0 + NPO = ABS(NPO) +! +! ... Preparations for new output file including end check +! and output for last output file +! + IF ( FIRST ) THEN +! + FIRST = .FALSE. +! +#ifdef W3_RTD + IF ( NPO.NE.0 ) THEN + ! Destination pole lat, lon from namelist + bPolat = BPLAT(NFBPO+1) + bPolon = BPLON(NFBPO+1) + END IF + ! +#endif + IF ( NFBPO.GE.1 .AND. ILOOP.EQ.2 ) THEN + WRITE (NDSO,991) NFBPO, NBO(NFBPO) - NBO(NFBPO-1), & + NBO2(NFBPO) - NBO2(NFBPO-1) +#ifdef W3_RTD + ! Print dest. Pole lat/lon if either the dest or present grid is rotated + IF ( BPLAT(NFBPO) < 90. .OR. Polat < 90. ) & + WRITE (NDSO,1991) BPLAT(NFBPO), BPLON(NFBPO) + ! +#endif +#ifdef W3_O1 + IF ( NBO(NFBPO) - NBO(NFBPO-1) .EQ. 1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO,992) + ELSE + WRITE (NDSO,2992) + END IF + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSO,1992) + ELSE + WRITE (NDSO,3992) + END IF + END IF + IP0 = NBO(NFBPO-1)+1 + IPN = NBO(NFBPO) + IPH = IP0 + (IPN-IP0-1)/2 + IPI = IPH -IP0 + 1 + MOD(IPN-IP0+1,2) + DO IP=IP0, IPH + IF ( FLAGLL ) THEN + WRITE (NDSO,1993) IP-NBO(NFBPO-1), & + FACTOR*XBPO(IP), & + FACTOR*YBPO(IP), & + IP+IPI-NBO(NFBPO-1), & + FACTOR*XBPO(IP+IPI), & + FACTOR*YBPO(IP+IPI) + ELSE + WRITE (NDSO,3993) IP-NBO(NFBPO-1), & + FACTOR*XBPO(IP), & + FACTOR*YBPO(IP), & + IP+IPI-NBO(NFBPO-1), & + FACTOR*XBPO(IP+IPI), & + FACTOR*YBPO(IP+IPI) + END IF + END DO + IF ( MOD(IPN-IP0+1,2) .EQ. 1 ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSO, 993) IPH+1-NBO(NFBPO-1), & + FACTOR*XBPO(IPH+1), & + FACTOR*YBPO(IPH+1) + ELSE + WRITE (NDSO,2993) IPH+1-NBO(NFBPO-1), & + FACTOR*XBPO(IPH+1), & + FACTOR*YBPO(IPH+1) + END IF + END IF + WRITE (NDSO,*) +#endif + END IF +! + IF ( NPO .EQ. 0 ) EXIT +! + NFBPO = NFBPO + 1 + IF ( NFBPO .GT. 9 ) THEN + WRITE (NDSE,1006) + CALL EXTCDE ( 50 ) + END IF + NBO2(NFBPO) = NBO2(NFBPO-1) + NBO(NFBPO) = NBOTOT +! + END IF +! +! ... Loop over line segment - - - - - - - - - - - - - - - - - - - - - +! +#ifdef W3_RTD + ! If either base or destination grid is rotated lat-lon + IF ( allocated(BDYLON) .eqv. .TRUE. ) THEN + deallocate( BDYLON, BDYLAT ) + IF ( bPolat < 90. .OR. Polat < 90. ) & + deallocate( ELatbdy, ELonbdy, Anglbdy ) + END IF + allocate( BDYLON(NPO), BDYLAT(NPO)) + IF ( bPolat < 90. .OR. Polat < 90. ) & + allocate( ELatbdy(NPO), ELonbdy(NPO), Anglbdy(NPO) ) + ! +#endif +#ifdef W3_T + WRITE (NDST,9090) +#endif +! + DO IP=1, NPO +! + XO = XO0 + REAL(IP-1)*DXO + YO = YO0 + REAL(IP-1)*DYO +#ifdef W3_RTD + ! + ! Boundary points are specified in coordinates of the destination grid + ! + ! Collect the line segment points into arrays + BDYLON(IP) = XO + BDYLAT(IP) = YO + ! Close the loop before calculating rotated lat-lon coordinates. + END DO + + ! Create one or two sets of the segment points: + ! 1. (BDYLAT, BDYLON) in standard lat-lon coordinates, + ! 2. Also (ELatbdy, ELonbdy) in case the base grid is rotated + + IF ( bPolat < 90. ) THEN + ! The destination grid is rotated (std->rot or rot->rot) + ! Change BDYLAT, BDYLON to their standard lat-lon positions + ! Let ELatbdy,ELonbdy contain the rotated lat-lon coordinates + ELatbdy(:) = BDYLAT(:) + ELonbdy(:) = BDYLON(:) + CALL W3EQTOLL ( ELatbdy, ELonbdy, BDYLAT, BDYLON, & + & Anglbdy, bPolat, bPolon, NPO ) + ! Let the standard longitudes BDYLON be within the range [-180.,180.[ + ! or [0., 360.[ depending on the grid pole + IF ( Polon < -90. .OR. Polon > 90. ) THEN + BDYLON(:) = MOD( BDYLON(:) + 180., 360. ) - 180. + ELSE + BDYLON(:) = MOD( BDYLON(:) + 360., 360. ) + END IF + END IF ! bPolat < 90. + ! From now, BDYLAT, BDYLON are defined in standard lat-lon coordinates + ! + IF ( Polat < 90. ) THEN + ! The base grid is rotated (rot->std or rot->rot) + ! Find lat-lon in coordinates of the rotated base grid + CALL W3LLTOEQ ( BDYLAT, BDYLON, ELatbdy, ELonbdy, & + & Anglbdy, Polat, Polon, NPO ) + END IF + ! + ! Take up again the loop over the line segment points + DO IP=1, NPO + IF ( Polat < 90. ) THEN + ! The base grid is rotated (rot->std, rot->rot) + ! (The std. lat-lon values BDYLAT, BDYLON go to YBPO, XBPO) + XO = ELonbdy(IP) + YO = ELatbdy(IP) + ELSE + ! The base grid is standard geographic (std->rot or std->std) + XO = BDYLON(IP) + YO = BDYLAT(IP) + END IF +#endif +! +! ... Compute bilinear remapping weights +! + INGRID = W3GRMP( GSU, XO, YO, IXR, IYR, RD ) +! +! Change cell-corners from counter-clockwise to column-major order + IX = IXR(3); IY = IYR(3); X = RD(3); + IXR(3) = IXR(4); IYR(3) = IYR(4); RD(3) = RD(4); + IXR(4) = IX ; IYR(4) = IY ; RD(4) = X ; +! +#ifdef W3_T + WRITE (NDST,9091) FACTOR*XO, FACTOR*YO, & + (IXR(J), IYR(J), RD(J), J=1,4) +#endif +! +! ... Check if point in grid +! + IF ( INGRID ) THEN +! +! ... Check if point not on land +! + IF ( ( MAPSTA(IYR(1),IXR(1)).GT.0 .AND. & + RD(1).GT.0.05 ) .OR. & + ( MAPSTA(IYR(2),IXR(2)).GT.0 .AND. & + RD(2).GT.0.05 ) .OR. & + ( MAPSTA(IYR(3),IXR(3)).GT.0 .AND. & + RD(3).GT.0.05 ) .OR. & + ( MAPSTA(IYR(4),IXR(4)).GT.0 .AND. & + RD(4).GT.0.05 ) ) THEN +! +! ... Check storage and store coordinates +! + NBOTOT = NBOTOT + 1 + IF ( ILOOP .EQ. 1 ) CYCLE +! +#ifdef W3_RTD + ! BDYLAT, BDYLON contain Y0, X0, which are remapped to standard lat/lon. + ! BDYLAT, BDYLON are stored in the mod_def file. + IF ( Polat < 90. ) THEN + XO = BDYLON(IP) + YO = BDYLAT(IP) + END IF +#endif + XBPO(NBOTOT) = XO + YBPO(NBOTOT) = YO +! +! ... Interpolation factors +! + RDTOT = 0. + DO J=1, 4 + IF ( MAPSTA(IYR(J),IXR(J)).GT.0 .AND. & + RD(J).GT.0.05 ) THEN + RDBPO(NBOTOT,J) = RD(J) + ELSE + RDBPO(NBOTOT,J) = 0. + END IF + RDTOT = RDTOT + RDBPO(NBOTOT,J) + END DO +! + DO J=1, 4 + RDBPO(NBOTOT,J) = RDBPO(NBOTOT,J) / RDTOT + END DO +! +#ifdef W3_T + WRITE (NDST,9092) RDTOT, (RDBPO(NBOTOT,J),J=1,4) +#endif +! +! ... Determine sea and interpolation point counters +! + DO J=1, 4 + ISEAI(J) = MAPFS(IYR(J),IXR(J)) + END DO +! + DO J=1, 4 + IF ( ISEAI(J).EQ.0 .OR. RDBPO(NBOTOT,J).EQ. 0. ) THEN + IPBPO(NBOTOT,J) = 0 + ELSE + FLNEW = .TRUE. + DO IST=NBO2(NFBPO-1)+1, NBO2(NFBPO) + IF ( ISEAI(J) .EQ. ISBPO(IST) ) THEN + FLNEW = .FALSE. + IPBPO(NBOTOT,J) = IST - NBO2(NFBPO-1) + END IF + END DO + IF ( FLNEW ) THEN + NBO2(NFBPO) = NBO2(NFBPO) + 1 + IPBPO(NBOTOT,J) = NBO2(NFBPO) - NBO2(NFBPO-1) + ISBPO(NBO2(NFBPO)) = ISEAI(J) + END IF + END IF + END DO +! +#ifdef W3_T + WRITE (NDST,9093) ISEAI, (IPBPO(NBOTOT,J),J=1,4) +#endif +! +! ... Error output +! + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSE,2995) FACTOR*XO, FACTOR*YO + ELSE + WRITE (NDSE,995) FACTOR*XO, FACTOR*YO + END IF + END IF + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSE,2994) FACTOR*XO, FACTOR*YO + ELSE + WRITE (NDSE,994) FACTOR*XO, FACTOR*YO + END IF + END IF +! + END DO +! + NBO(NFBPO) = NBOTOT +! +! ... Branch back to read. +! + END DO +! +! ... End of ILOOP loop +! + END DO +! + IF ( .NOT. FLGNML ) CLOSE ( NDSS, STATUS='DELETE' ) +! + FLBPO = NBOTOT .GT. 0 + IF ( .NOT. FLBPO ) THEN + WRITE (NDSO,996) + ELSE + WRITE (NDSO,997) NBOTOT, NBO2(NFBPO) + END IF +! +#ifdef W3_T0 + WRITE (NDST,9095) + DO IFILE=1, NFBPO + DO IP=NBO2(IFILE-1)+1, NBO2(IFILE) + WRITE (NDST,9096) IFILE, IP-NBO2(IFILE-1), ISBPO(IP) + END DO + END DO +#endif +! +!--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!10. Write model definition file. +! + WRITE (NDSO,999) + CALL W3IOGR ( 'WRITE', NDSM ) +! + CLOSE (NDSM) +! + GOTO 2222 +! +! Escape locations read errors : +! + 2000 CONTINUE + WRITE (NDSE,1000) IERR + CALL EXTCDE ( 60 ) +! + 2001 CONTINUE + WRITE (NDSE,1001) + CALL EXTCDE ( 61 ) +! + 2002 CONTINUE + WRITE (NDSE,1002) IERR + CALL EXTCDE ( 62 ) +! + 2003 CONTINUE + WRITE (NDSE,1003) + CALL EXTCDE ( 64 ) +! + 2222 CONTINUE + IF ( GTYPE .NE. UNGTYPE) THEN + IF ( NX*NY .NE. NSEA ) THEN + WRITE (NDSO,9997) NX, NY, NX*NY, NSEA, & + 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT + ELSE + WRITE (NDSO,9998) NX, NY, NX*NY, NSEA, NBI, NLAND, NBT + END IF + ELSE IF ( GTYPE .EQ. UNGTYPE ) THEN + IF ( NX*NY .NE. NSEA ) THEN + WRITE (NDSO,9997) 0, 0, NX*NY, NSEA, & + 100.*REAL(NSEA)/REAL(NX*NY), NBI, NLAND, NBT + ELSE + WRITE (NDSO,9998) 0, 0, NX*NY, NSEA, NBI, NLAND, NBT + END IF + ENDIF ! GTYPE .EQ. UNGTYPE + + WRITE (NDSO,9999) + +#ifdef W3_SCRIP + GRID1_UNITS='degrees' ! the other option is radians...we don't use this + GRID1_NAME='src' ! this is not used, except for netcdf output + CALL GET_SCRIP_INFO(1, & + & GRID1_CENTER_LON, GRID1_CENTER_LAT, & + & GRID1_CORNER_LON, GRID1_CORNER_LAT, GRID1_MASK, & + & GRID1_DIMS, GRID1_SIZE, GRID1_CORNERS, GRID1_RANK) + + +#endif + +#ifdef W3_SCRIP + IF (GTYPE .EQ. UNGTYPE) THEN + GRID1_RANK=1 + DEALLOCATE(GRID1_DIMS) + ALLOCATE(GRID1_DIMS(GRID1_RANK)) + GRID1_DIMS(1) = GRID1_SIZE + ENDIF +#endif + +#ifdef W3_SCRIP + DO I = 1,GRID1_SIZE + IF (GRID1_CENTER_LON(I) < 0.0) THEN + GRID1_CENTER_LON(I) = GRID1_CENTER_LON(I)+360.0 + ENDIF + DO J = 1,GRID1_CORNERS + IF (GRID1_CORNER_LON(J,I) < 0.0) THEN + GRID1_CORNER_LON(J,I) = GRID1_CORNER_LON(J,I)+360.0 + ENDIF + ENDDO + ENDDO +#endif + +#ifdef W3_SCRIPNC + IERR = NF90_CREATE(TRIM('scrip.nc'), NF90_NETCDF4, NCID) + IERR = NF90_DEF_DIM(NCID, 'grid_size', GRID1_SIZE, grid_size_dimid) + IERR = NF90_DEF_DIM(NCID, 'grid_corners', GRID1_CORNERS, grid_corners_dimid) + IERR = NF90_DEF_DIM(NCID, 'grid_rank', GRID1_RANK, grid_rank_dimid) +#endif + +#ifdef W3_SCRIPNC + IERR = NF90_DEF_VAR(NCID, 'grid_center_lat', NF90_DOUBLE, & + (/grid_size_dimid/),grid_center_lat_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_center_lon', NF90_DOUBLE, & + (/grid_size_dimid/),grid_center_lon_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_corner_lat', NF90_DOUBLE, & + (/grid_corners_dimid,grid_size_dimid/), & + grid_corner_lat_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_corner_lon', NF90_DOUBLE, & + (/grid_corners_dimid,grid_size_dimid/), & + grid_corner_lon_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_imask', NF90_INT, & + (/grid_size_dimid/),grid_imask_varid) + IERR = NF90_DEF_VAR(NCID, 'grid_dims', NF90_INT, & + (/grid_rank_dimid/),grid_dims_varid) + IERR = NF90_ENDDEF(NCID) +#endif + +#ifdef W3_SCRIP + ALLOCATE(GRID1_IMASK(GRID1_DIMS(1))) + GRID1_IMASK = 0 + DO I = 1,GRID1_DIMS(1) + IF (GRID1_MASK(I)) THEN + GRID1_IMASK(I) = 1 + ENDIF + ENDDO +#endif + +#ifdef W3_SCRIPNC + IERR = NF90_PUT_ATT(NCID,grid_center_lat_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_center_lon_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_corner_lat_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_corner_lon_varid,'units',GRID1_UNITS) + IERR = NF90_PUT_ATT(NCID,grid_imask_varid,'units','unitless') +#endif + +#ifdef W3_SCRIPNC + IERR = NF90_PUT_VAR(NCID,grid_center_lat_varid,GRID1_CENTER_LAT) + IERR = NF90_PUT_VAR(NCID,grid_center_lon_varid,GRID1_CENTER_LON) + IERR = NF90_PUT_VAR(NCID,grid_corner_lat_varid,GRID1_CORNER_LAT) + IERR = NF90_PUT_VAR(NCID,grid_corner_lon_varid,GRID1_CORNER_LON) + IERR = NF90_PUT_VAR(NCID,grid_imask_varid,GRID1_IMASK) + IERR = NF90_PUT_VAR(NCID,grid_dims_varid,GRID1_DIMS) + IERR = NF90_CLOSE(NCID) +#endif + + +! +! Formats +! + 900 FORMAT (/15X,' *** WAVEWATCH III Grid preprocessor *** '/ & + 15X,'==============================================='/) + 901 FORMAT ( ' Comment character is ''',A,''''/) + 902 FORMAT ( ' Grid name : ',A/) + 903 FORMAT (/' Spectral discretization : '/ & + ' --------------------------------------------------'/ & + ' Number of directions :',I4/ & + ' Directional increment (deg.):',F6.1) + 904 FORMAT ( ' First direction (deg.):',F6.1) + 905 FORMAT ( ' Number of frequencies :',I4/ & + ' Frequency range (Hz) :',F9.4,'-',F6.4/ & + ' Increment factor :',F8.3/) +! + 910 FORMAT (/' Model definition :'/ & + ' --------------------------------------------------') + 911 FORMAT ( ' Dry run (no calculations) : ',A/ & + ' Propagation in X-direction : ',A/ & + ' Propagation in Y-direction : ',A/ & + ' Refraction : ',A/ & + ' Current-induced k-shift : ',A/ & + ' Source term calc. and int. : ',A/) + 912 FORMAT (/' Time steps : '/ & + ' --------------------------------------------------'/ & + ' Maximum global time step (s) :',F8.2/ & + ' Maximum CFL time step X-Y (s) :',F8.2/ & + ' Maximum CFL time step k-theta (s) :',F8.2/ & + ' Minimum source term time step (s) :',F8.2/) + 913 FORMAT (/ ' WARNING, TIME STEP LESS THAN 1 s, NITER:',I8 /) + 915 FORMAT ( ' Preprocessing namelists ...') + 916 FORMAT ( ' Preprocessing namelists finished.'/) + 917 FORMAT (/' Equivalent namelists ...'/) + 918 FORMAT (/' Equivalent namelists finished.'/) +! +#ifdef W3_FLX1 + 810 FORMAT (/' Stresses (Wu 1980)'/ & + ' --------------------------------------------------'/) +#endif +#ifdef W3_FLX2 + 810 FORMAT (/' Stresses (T&C 96)'/ & + ' --------------------------------------------------'/) +#endif +#ifdef W3_FLX3 + 810 FORMAT (/' Stresses (T&C 96 capped) ',A/ & + ' --------------------------------------------------') +#endif +#ifdef W3_FLX4 + 810 FORMAT (/' Stresses (Hwang 2011) ',A/ & + ' --------------------------------------------------') + 811 FORMAT ( ' drag coefficient scaling :',F8.2 /) + 2810 FORMAT ( ' &FLX4 CDFAC =',F6.3,' /') +#endif +#ifdef W3_FLX5 + 810 FORMAT (/' Direct use of stress from input'/ & + ' --------------------------------------------------'/) +#endif +#ifdef W3_FLX3 + 811 FORMAT ( ' Max Cd * 10^3 :',F8.2/ & + ' Cap type : ',A/) + 2810 FORMAT ( ' &FLX3 CDMAX =',F6.2,'E-3 , CTYPE = ',I1,' /') +#endif +! +#ifdef W3_LN0 + 820 FORMAT (/' Linear input not defined.'/) +#endif +#ifdef W3_SEED + 820 FORMAT (/' Seeding as proxi for linear input.'/) +#endif +! +#ifdef W3_LN1 + 820 FORMAT (/' Linear input (C&M-R 82) ',A/ & + ' --------------------------------------------------') + 821 FORMAT ( ' CLIN :',f8.2/ & + ' Factor for fPM in filter :',F8.2/ & + ' Factor for fh in filter :',F8.2/) + 2820 FORMAT ( ' &SLN1 CLIN =',F6.1,', RFPM =',F6.2, & + ', RFHF =',F6.2,' /') +#endif +! +#ifdef W3_ST0 + 920 FORMAT (/' Wind input not defined.'/) +#endif +! +#ifdef W3_ST1 + 920 FORMAT (/' Wind input (WAM-3) ',A/ & + ' --------------------------------------------------') + 921 FORMAT ( ' Cinp :',E10.3/) + 2920 FORMAT ( ' &SIN1 CINP =',F7.3,' /') +#endif +! +#ifdef W3_ST2 + 920 FORMAT (/' Wind input (T&C 1996) ',A/ & + ' --------------------------------------------------') + 921 FORMAT ( ' Height of input wind (m) :',F8.2/ & + ' Factor negative swell :',F9.3/) +#endif +#ifdef W3_STAB2 + 1921 FORMAT ( ' Effective wind mean factor :',F8.2/ & + ' Stability par. offset :',F9.3/ & + ' Stab. correction :',F9.3,F8.3/& + ' Stab. correction stab. fac. :',F7.1,F9.1/) +#endif +#ifdef W3_ST2 + 2920 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,' /') +#endif +#ifdef W3_STAB2 + 2921 FORMAT ( ' &SIN2 ZWND =',F5.1,', SWELLF =',F6.3,', STABSH =', & + F6.3,', STABOF = ',E10.3,','/ & + ' CNEG =',F7.3,', CPOS =',F7.3,', FNEG =',F7.1,' /') +#endif +! +#ifdef W3_ST3 + 920 FORMAT (/' Wind input (WAM 4+) ',A/ & + ' --------------------------------------------------') + 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & + ' betamax :',F9.3/ & + ' power of cos. in wind input :',F9.3/ & + ' z0max :',F9.3/ & + ' zalp :',F9.3/ & + ' Height of input wind (m) :',F8.2/ & + ' swell attenuation factor :',F9.3/ ) + 2920 FORMAT ( ' &SIN3 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & + F8.5,','/ & + ' SINTHP =',F8.5,', ZALP =',F8.5,','/ & + ' SWELLF =',F8.5,'R /'/) +#endif +! +#ifdef W3_ST4 + 920 FORMAT (/' Wind input (WAM 4+) ',A/ & + ' --------------------------------------------------') + 921 FORMAT ( ' minimum Charnock coeff. :',F10.4/ & + ' betamax :',F9.3/ & + ' power of cos. in wind input :',F9.3/ & + ' z0max :',F9.3/ & + ' zalp :',F9.3/ & + ' Height of input wind (m) :',F8.2/ & + ' wind stress sheltering :',F9.3/ & + ' swell attenuation param. :',I5/ & + ' swell attenuation factor :',F9.3/ & + ' swell attenuation factor2 :',F9.3/ & + ' swell attenuation factor3 :',F9.3/ & + ' critical Reynolds number :',F9.1/ & + ' swell attenuation factor5 :',F9.3/ & + ' swell attenuation factor6 :',F9.3/ & + ' swell attenuation factor7 :',F14.3/ & + ' ratio of z0 for orb. & mean :',F9.3/) + 2920 FORMAT ( ' &SIN4 ZWND =',F5.1,', ALPHA0 =',F8.5,', Z0MAX =',F8.5,', BETAMAX =', & + F8.5,','/ & + ' SINTHP =',F8.5,', ZALP =',F8.5,', TAUWSHELTER =',F8.5, & + ', SWELLFPAR =',I2,','/ & + ' SWELLF =',F8.5,', SWELLF2 =',F8.5, & + ', SWELLF3 =',F8.5,', SWELLF4 =',F9.1,','/ & + ' SWELLF5 =',F8.5,', SWELLF6 =',F8.5, & + ', SWELLF7 =',F12.2,', Z0RAT =',F8.5,', SINBR =',F8.5,' /') +#endif +! +#ifdef W3_ST6 + 920 FORMAT (/' Wind input (Donelan et al, 2006) ',A/ & + ' --------------------------------------------------') + 921 FORMAT ( ' negative wind input active : ',A/ & + ' attenuation factor : ',F6.2/ & + ' wind speed scaling factor : ',F6.2/ & + ' frequency cut-off factor : ',F6.2/) + 2920 FORMAT ( ' &SIN6 SINA0 =', F6.3, ', SINWS =', F6.2, ', SINFC =', F6.2, ' /') +#endif +! +#ifdef W3_NL0 + 922 FORMAT (/' Nonlinear interactions not defined.'/) +#endif +! +#ifdef W3_NL1 + 922 FORMAT (/' Nonlinear interactions (DIA) ',A/ & + ' --------------------------------------------------') + 923 FORMAT ( ' Lambda :',F8.2/ & + ' Prop. constant :',E10.3/ & + ' kd conversion factor :',F8.2/ & + ' minimum kd :',F8.2/ & + ' shallow water constants :',F8.2,2F6.2/) + 2922 FORMAT ( ' &SNL1 LAMBDA =',F7.3,', NLPROP =',E10.3, & + ', KDCONV =',F7.3,', KDMIN =',F7.3,','/ & + ' SNLCS1 =',F7.3,', SNLCS2 =',F7.3, & + ', SNLCS3 = ',F7.3,' /') +#endif +! +#ifdef W3_NL2 + 922 FORMAT (/' Nonlinear interactions (WRT) ',A/ & + ' --------------------------------------------------') + 923 FORMAT ( ' Deep/shallow options : ',A/ & + ' Power of h-f tail : ',F6.1) + 1923 FORMAT ( ' Number of depths used : ',I4/ & + ' Depths (m) :',5F7.1) + 2923 FORMAT ( ' ',5F7.1) + 2922 FORMAT ( ' &SNL2 IQTYPE =',I2,', TAILNL =',F5.1,',', & + ' NDEPTH =',I3,' /') + 3923 FORMAT ( ' &SNL2 DEPTHS =',F9.2,' /') + 4923 FORMAT ( ' &ANL2 DEPTHS =',F9.2,' ,') + 5923 FORMAT ( ' ',F9.2,' ,') + 6923 FORMAT ( ' ',F9.2,' /') +#endif +! +#ifdef W3_NL3 + 922 FORMAT (/' Nonlinear interactions (GMD) ',A/ & + ' --------------------------------------------------') + 923 FORMAT ( ' Powers in scaling functions : ',2F7.2/ & + ' Nondimension filter depths : ',2F7.2) + 1923 FORMAT ( ' Number of quad. definitions : ',I4) + 2923 FORMAT ( ' ',2F8.3,F6.1,2E12.4) + 2922 FORMAT ( ' &SNL3 NQDEF =',I3,', MSC =',F6.2,', NSC =', & + F6.2,', KDFD =',F6.2,', KDFS =',F6.2,' /') + 3923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' /') + 4923 FORMAT ( ' &ANL3 QPARMS = ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' ,') + 5923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' ,') + 6923 FORMAT ( ' ',2(F5.3,', '),F5.1,', ',E10.4, & + ', ',E10.4,' /') +#endif +! +#ifdef W3_NL4 + 922 FORMAT (/' Nonlinear interactions (TSA) ',A/ & + ' --------------------------------------------------') + 923 FORMAT ( ' Source term computation (1=TSA,0=FBI) : ',I2/ & + ' Alternate loops (1=no,2=yes) : ',I2/ & + ' (To speed up computation) ') + 2922 FORMAT ( ' &SNL4 ITSA =',I2,', IALT =',I2 ) +#endif +! +#ifdef W3_NL5 + 922 FORMAT(/' Nonlinear interactions (GKE) ',A/ & + ' --------------------------------------------------') + 923 FORMAT ( ' Constant water depth (in meter) : ', F7.1/ & + ' Quasi-resonant quartets cut-off : ', F8.2/ & + ' Discretiz. of GKE (0:Con., 1:GS): ', I5/ & + ' GKE (0: GS13-JFM, 1: J03-JPO) : ', I5/ & + ' Interp (0: nearest, 1: bilinear): ', I5/ & + ' Mixing (0: no, N: N Tm, -1: b_T): ', I5/) + 2922 FORMAT ( ' &SNL5 NL5DPT =', F7.1, ', NL5OML =', F5.2, & + ', NL5DIS =', I2.1, ', NL5KEV =', I2.1, & + ', NL5IPL =', I2.1, ', NL5PMX =', I5.1, ' /') +#endif +! +#ifdef W3_NLS + 9922 FORMAT (/' HF filter based on Snl ',A/ & + ' --------------------------------------------------') + 9923 FORMAT ( ' a34 (lambda) :',F9.3,F9.4/ & + ' Prop. constant :',E10.3/ & + ' maximum relative change :',F9.3/ & + ' filter constants :',F8.2,2F6.2/) + 8922 FORMAT ( ' &SNLS A34 =',F6.3,', FHFC =',E11.4, & + ', DNM =',F6.3,','/' FC1 =',F6.3, & + ', FC2 =',F6.3,', FC3 =',F6.3,' /') +#endif +! +#ifdef W3_ST0 + 924 FORMAT (/' Dissipation not defined.'/) +#endif +! +#ifdef W3_ST1 + 924 FORMAT (/' Dissipation (WAM-3) ',A/ & + ' --------------------------------------------------') + 925 FORMAT ( ' Cdis :',E10.3/ & + ' Apm :',E10.3/) + 2924 FORMAT ( ' &SDS1 CDIS =',E12.4,', APM =',E11.4,' /') +#endif +! +#ifdef W3_ST2 + 924 FORMAT (/' Dissipation (T&C 1996) ',A/ & + ' --------------------------------------------------') + 925 FORMAT ( ' High-frequency constants :',F8.2,E11.3,F6.2/ & + ' Low-frequency constants :',E11.3,F6.2/& + ' ',E11.3,F6.2/& + ' Minimum input peak freq. (-):',F10.4/ & + ' Minimum PHI :',F10.4/) + 2924 FORMAT ( ' &SDS2 SDSA0 =',E10.3,', SDSA1 =',E10.3,', SDSA2 =', & + E10.3,', '/ & + ' SDSB0 =',E10.3,', SDSB1 =',E10.3,', ', & + 'PHIMIN =',E10.3,' /') +#endif +! +#ifdef W3_ST3 + 924 FORMAT (/' Dissipation (WAM Cycle 4+) ',A/ & + ' --------------------------------------------------') + 925 FORMAT ( ' SDSC1 :',1E11.3/ & + ' Power of k in mean k :',F8.2/ & + ' weights of k and k^2 :',F9.3,F6.3/) + 2924 FORMAT ( ' &SDS3 SDSC1 =',E12.4,', WNMEANP =',F4.2, & + ', FXPM3 =', F4.2,',FXFM3 =',F4.2,', '/ & + ' SDSDELTA1 =', F5.2,', SDSDELTA2 =',F5.2, & + ' /') +#endif +! +#ifdef W3_ST4 + 924 FORMAT (/' Dissipation (Ardhuin / Filipot / Romero ) ',A/ & + ' --------------------------------------------------') + 925 FORMAT ( ' SDSC2, SDSBCK, SDSCUM :',3E11.3/ & + ' Power of k in mean k :',F8.2/) +#endif + + +#ifdef W3_ST4 + 2924 FORMAT ( ' &SDS4 SDSBCHOICE = ',F3.1, & + ', SDSC2 =',E12.4,', SDSCUM =',F6.2,', '/ & + ' SDSC4 =',F6.2,', SDSC5 =',E12.4, & + ', SDSC6 =',E12.4,','/ & + ' WNMEANP =',F4.2,', FXPM3 =', F4.2, & + ', FXFM3 =',F4.1,', FXFMAGE =',F6.3, ', '/ & + ' SDSBINT =',E12.4,', SDSBCK =',E12.4, & + ', SDSABK =',F6.3,', SDSPBK =',F6.3,', '/ & + ' SDSHCK =',F5.2,', SDSBR = ',E12.4, & + ', SDSSTRAIN =',F5.1,', SDSSTRAINA =',F4.1, & + ', SDSSTRAIN2 =',F5.1,', '/ & + ' SDSBT =',F5.2,', SDSP =',F5.2, & + ', SDSISO =',I2, & + ', SDSCOS =',F3.1,', SDSDTH =',F5.1,', '/ & + ' SDSBRF1 = ',F5.2,', SDSBRFDF =',I2,', '/ & + ' SDSBM0 = ',F5.2, ', SDSBM1 =',F5.2, & + ', SDSBM2 =',F5.2,', SDSBM3 =',F5.2,', SDSBM4 =', & + F5.2,', '/, & + ' SPMSS = ',F5.2, ', SDKOF =',F5.2, & + ', SDSMWD =',F5.2,', SDSFACMTF =',F5.1,', '/ & + ' SDSMWPOW =',F3.1,', SDSNMTF =', F5.2, & + ', SDSCUMP =', F3.1,', SDSNUW =', E8.3,', '/, & + ' WHITECAPWIDTH =',F5.2, ' WHITECAPDUR =',F5.2,' /') +#endif +! +#ifdef W3_ST6 + 924 FORMAT (/' Dissipation (Rogers et al. 2012) ',A/ & + ' --------------------------------------------------') + 925 FORMAT ( ' normalise by threshold spectral density : ',A/& + ' normalise by spectral density : ',A/& + ' coefficient and exponent for '/ & + ' inherent breaking term a1, L as in (21) : ',E9.3,I3/ & + ' cumulative breaking term a2, M as in (22) : ',E9.3,I3/ & + ' ') + 2924 FORMAT ( ' &SDS6 SDSET = ',L,', SDSA1 = ',E9.3, & + ', SDSA2 = ',E9.3,', SDSP1 = ',I2,', SDSP1 = ', & + I2,' /' ) + + 937 FORMAT (/' Swell dissipation ',A/ & + ' --------------------------------------------------') + 940 FORMAT ( ' subroutine W3SWL6 activated : ',A/ & + ' coefficient b1 ',A, ' : ',E9.3/ ) + 2937 FORMAT ( ' &SWL6 SWLB1 = ',E9.3,', CSTB1 = ',L,' /') +#endif +! +#ifdef W3_BT0 + 926 FORMAT (/' Bottom friction not defined.'/) +#endif +! +#ifdef W3_BT1 + 926 FORMAT (/' Bottom friction (JONSWAP) ',A/ & + ' --------------------------------------------------') + 927 FORMAT ( ' gamma :',F8.4/) + 2926 FORMAT ( ' &SBT1 GAMMA =',E12.4,' /') +#endif +! +#ifdef W3_BT4 + 926 FORMAT (/' Bottom friction (SHOWEX) ',A/ & + ' --------------------------------------------------') + 927 FORMAT ( ' SEDMAPD50, SED_D50_UNIFORM :',L3,1X,F8.6/ & + ' RIPFAC1,RIPFAC2,RIPFAC3,RIPFAC4 :',4F8.4/ & + ' SIGDEPTH, BOTROUGHMIN, BOTROUGHFAC:',3F8.4/) + 2926 FORMAT ( ' &SBT4 SEDMAPD50 =',L3,', SED_D50_UNIFORM =',F8.6,','/ & + ' RIPFAC1 =',F8.4,', RIPFAC2 =',F8.4, & + ', RIPFAC3 =',F8.4,', RIPFAC4 =',F8.4,','/ & + ' SIGDEPTH =',F8.4,', BOTROUGHMIN =',F8.4, & + ', BOTROUGHFAC =',F4.1,' /') +#endif +! +#ifdef W3_DB0 + 928 FORMAT (/' Surf breaking not defined.'/) +#endif +! +#ifdef W3_DB1 + 928 FORMAT (/' Surf breaking (B&J 1978) ',A/ & + ' --------------------------------------------------') + 929 FORMAT ( ' alpha :',F8.3/ & + ' gamma :',F8.3) + 2928 FORMAT ( ' &SDB1 BJALFA =',F7.3,', BJGAM =',F7.3, & + ', BJFLAG = ',A,' /') +#endif +! +#ifdef W3_TR0 + 930 FORMAT (/' Triad interactions not defined.'/) +#endif +! +#ifdef W3_BS0 + 932 FORMAT (/' Bottom scattering not defined.'/) +#endif +#ifdef W3_BS1 + 932 FORMAT (/' Experimental bottom scattering (F. Ardhuin).'/) +#endif +! +#ifdef W3_IC1 + 935 FORMAT (/' Dissipation via ice parameters (SIC1).'& + ,/' --------------------------------------------------') +#endif +! +#ifdef W3_IC2 + 935 FORMAT (/' Dissipation via ice parameters (SIC2).'& + ,/' --------------------------------------------------') +#endif +! +#ifdef W3_IC3 + 935 FORMAT (/' Dissipation via ice parameters (SIC3).'& + ,/' --------------------------------------------------') +#endif +! +#ifdef W3_IC4 + 935 FORMAT (/' Dissipation via ice parameters (SIC4).'& + ,/' --------------------------------------------------') +#endif +! +#ifdef W3_IC5 + 935 FORMAT (/' Dissipation via ice parameters (SIC5).'& + ,/' --------------------------------------------------') +#endif +! +#ifdef W3_IS0 + 944 FORMAT (/' Ice scattering not defined.'/) +#endif +#ifdef W3_IS1 + 945 FORMAT (/' Ice scattering ',A,/ & + ' --------------------------------------------------') + 946 FORMAT (' Isotropic (linear function of ice concentration)'/& + ' slope : ',E10.3/ & + ' offset : ',E10.3) + 2946 FORMAT ( ' &SIS1 ISC1 =',E9.3,', ISC2 =',E9.3) +#endif +#ifdef W3_IS2 + 947 FORMAT (/' Ice scattering ',A,/ & + ' --------------------------------------------------') + 948 FORMAT (' IS2 Scattering ... '/& + ' scattering coefficient : ',E9.3/ & + ' 0: no back-scattering : ',E9.3/ & + ' TRUE: istropic back-scattering : ',L3/ & + ' TRUE: update of ICEDMAX : ',L3/ & + ' TRUE: keeps updated ICEDMAX : ',L3/ & + ' flexural strength : ',E9.3/ & + ' TRUE: uses Robinson-Palmer disp.: ',L3/ & + ' attenuation : ',F5.2/ & + ' fragility : ',F5.2/ & + ' minimum floe size in meters : ',F5.2/ & + ' pack scattering coef 1 : ',F5.2/ & + ' pack scattering coef 2 : ',F5.2/ & + ' scaling by concentration : ',F5.2/ & + ' creep B coefficient : ',E9.3/ & + ' creep C coefficient : ',F5.2/ & + ' creep D coefficient : ',F5.2/ & + ' creep N power : ',F5.2/ & + ' elastic energy factor : ',F5.2/ & + ' factor for ice breakup : ',F5.2/ & + ' IS2WIM1 : ',F5.2/ & + ' anelastic dissipation : ',L3/ & + ' energy of activation : ',F5.2/ & + ' anelastic coefficient : ',E11.3/ & + ' anelastic exponent : ',F5.2) + 2948 FORMAT ( ' &SIS2 ISC1 =',E9.3,', IS2BACKSCAT =',E9.3, & + ', IS2ISOSCAT =',L3,', IS2BREAK =',L3, & + ', IS2DUPDATE =',L3,','/ & + ' IS2FLEXSTR =',E11.3,', IS2DISP =',L3, & + ', IS2DAMP =',F3.1, & + ', IS2FRAGILITY =',F4.2,', IS2DMIN =',F5.2,','/ & + ' IS2C2 =',F12.8,', IS2C3 =',F8.4, & + ', IS2CONC =',F5.1,', IS2CREEPB =',E11.3,','/ & + ' IS2CREEPC =',F5.2,', IS2CREEPD =',F5.2, & + ', IS2CREEPN =',F5.2,','/ & + ' IS2BREAKE =',F5.2, & + ', IS2BREAKF =',F5.2,', IS2WIM1 =',F5.2,','/ & + ', IS2ANDISB =',L3,', IS2ANDISE =',F5.2, & + ', IS2ANDISD =',E11.3,', IS2ANDISN=',F5.2, ' /') +#endif +#ifdef W3_UOST + 4500 FORMAT (/' Unresolved Obstacles Source Term (UOST) ',A,/ & + ' --------------------------------------------------') + 4501 FORMAT (' local alpha-beta file: ',A, & + ' shadow alpha-beta file: ',A,/ & + ' local calibration factor: ',F5.2, & + ' shadow calibration factor: ',F5.2) + 4502 FORMAT (' &UOST UOSTFILELOCAL = ',A,', UOSTFILESHADOW = ',A,/ & + ' UOSTFACTORLOCAL = ',F5.2', UOSTFACTORSHADOW = ',F5.2,' /') +#endif +! + 950 FORMAT (/' Propagation scheme : '/ & + ' --------------------------------------------------') + 951 FORMAT ( ' Type of scheme (structured) :',1X,A) + 2951 FORMAT ( ' Type of scheme(unstructured):',1X,A) + 2952 FORMAT ( ' wave setup computation:',1X,A) + 952 FORMAT ( ' ',1X,A) +#ifdef W3_PR1 + 953 FORMAT ( ' CFLmax depth refraction :',F9.3/) + 2953 FORMAT ( ' &PRO1 CFLTM =',F5.2,' /') +#endif +! +#ifdef W3_PR2 + 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Effective swell age (h) : switched off'/ & + ' Cut-off latitude (degr.) :',F7.1/) + 954 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Effective swell age (h) :',F8.2/ & + ' Cut-off latitude (degr.) :',F7.1/) + 2953 FORMAT ( ' &PRO2 CFLTM =',F5.2,', DTIME =',F8.0, & + ', LATMIN =',F5.1,' /') +#endif +! +#ifdef W3_SMC + 1950 FORMAT (/' SMC grid parameters : '/ & + ' --------------------------------------------------') + 1951 FORMAT ( ' Type of scheme (structured) :',1X,A) + 1953 FORMAT ( ' Max propagation CFL number :',F9.3/ & + ' Effective swell age (h) :',F8.2/ & + ' Maximum refraction (degr.) :',F8.2/) + 2954 FORMAT ( ' &PSMC CFLSM =',F5.2,', DTIMS =', F9.1/ & + ' Arctic =',L5, ', RFMAXD =', F9.2/ & + ' UNO3 =',L5, ', AVERG =',L5/ & + ' LvSMC =',i5, ', NBISMC =',i9/ & + ' ISHFT =',i5, ', JEQT =',i9/ & + ' SEAWND =',L5, '/') +#endif +! +#ifdef W3_PR3 + 953 FORMAT ( ' CFLmax depth refraction :',F9.3/ & + ' Averaging area factor Cg :',F8.2) + 954 FORMAT ( ' Averaging area factor theta :',F8.2) + 955 FORMAT ( ' **** Internal maximum .GE.',F6.2,' ****') + 2953 FORMAT ( ' &PRO3 CFLTM =',F5.2, & + ', WDTHCG = ',F4.2,', WDTHTH = ',F4.2,' /') +#endif +! + 2956 FORMAT ( ' &UNST UGBCCFL =',L3,', UGOBCAUTO =',L3, & + ', UGOBCDEPTH =', F8.3,', UGOBCFILE=',A,','/ & + ', EXPFSN =',L3,',EXPFSPSI =',L3, & + ', EXPFSFCT =', L3,',IMPFSN =',L3,',EXPTOTAL=',L3, & + ', IMPTOTAL=',L3,',IMPREFRACTION=', L3, & + ', IMPFREQSHIFT=', L3,', IMPSOURCE=', L3, & + ', SETUP_APPLY_WLV=', L3, & + ', JGS_TERMINATE_MAXITER=', L3, & + ', JGS_TERMINATE_DIFFERENCE=', L3, & + ', JGS_TERMINATE_NORM=', L3, & + ', JGS_LIMITER=', L3, & + ', JGS_USE_JACOBI=', L3, & + ', JGS_BLOCK_GAUSS_SEIDEL=', L3, & + ', JGS_MAXITER=', I5, & + ', JGS_PMIN=', F8.3, & + ', JGS_DIFF_THR=', F8.3, & + ', JGS_NORM_THR=', F8.3, & + ', JGS_NLEVEL=', I3, & + ', JGS_SOURCE_NONLINEAR=', L3 / ) +! + 960 FORMAT (/' Miscellaneous ',A/ & + ' --------------------------------------------------') + 2961 FORMAT ( ' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' CICE0.NE.CICEN requires FLAGTR>2'/ & + ' Parameters corrected: CICE0 = CICEN'/) + 2962 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID : User requests', & + 'CICE0=CICEN corresponding to discontinuous treatment of ', & + 'ice, so we will change FLAGTR') + 2963 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' Ice physics used, so we will change FLAGTR.') + 961 FORMAT ( ' Ice concentration cut-offs :',F8.2,F6.2) +#ifdef W3_MGG + 962 FORMAT ( ' Moving grid GSE cor. power :',F8.2) +#endif +#ifdef W3_SCRIP + 963 FORMAT( ' Grid offset for multi-grid w/SCRIP : ',E11.3) +#endif + 1972 FORMAT ( ' Compression of track output : ',L3) +#ifdef W3_SEED + 964 FORMAT ( ' Xseed in seeding algorithm :',F8.2) +#endif + 965 FORMAT (/' Dynamic source term integration scheme :'/ & + ' Xp (-) :',F9.3/ & + ' Xr (-) :',F9.3/ & + ' Xfilt (-) :',F9.3) + 966 FORMAT (/' Wave field partitioning :'/ & + ' Levels (-) :',I5/ & + ' Minimum wave height (m) :',F9.3/ & + ' Wind area multiplier (-) :',F9.3/ & + ' Cut-off wind sea fract. (-) :',F9.3/ & + ' Combine wind seas : ',A/ & + ' Number of swells in fld out :',I5) + 967 FORMAT (/' Miche-style limiting wave height :'/ & + ' Hs,max/d factor (-) :',F9.3/ & + ' Hrms,max/d factor (-) :',F9.3/ & + ' Limiter activated : ',A) + 968 FORMAT ( ' *** FACTOR DANGEROUSLY LOW ***') + 1973 FORMAT (/' Calendar type : ',A) +! +#ifdef W3_REF1 + 969 FORMAT (/' Shoreline reflection ',A/ & + ' --------------------------------------------------') +#endif +! +#ifdef W3_IG1 + 970 FORMAT (/' Second order and infragravity waves ',A/ & + ' --------------------------------------------------') +#endif +! + 5971 FORMAT (' Partitioning method : ',A) + 5972 FORMAT (' Namelist options overridden : ',A) +! +#ifdef W3_IC2 + 971 FORMAT (/' Boundary layer below ice ',A/ & + ' --------------------------------------------------') +#endif +#ifdef W3_IC3 + 971 FORMAT (/' Visco-elastic ice layer ',A/ & + ' --------------------------------------------------') +#endif +#ifdef W3_IC4 + 971 FORMAT (/' Empirical wave-ice physics ',A/ & + ' --------------------------------------------------') +#endif +#ifdef W3_IC5 + 971 FORMAT (/' Effective medium ice model (SIC5) ',A/ & + ' --------------------------------------------------') + 2971 FORMAT ( ' Min. Ice shear modulus G : ', E10.1/, & + ' Min. Wave period T : ', F7.2/, & + ' Max. Wavenumber Ratio (Ko/Kr): ', E10.1/, & + ' Max. Attenu. Rate (Ki) : ', E10.1/, & + ' Min. Water depth (d) : ', F5.0/, & + ' Max. # of Newton Iter. : ', F5.0/, & + ' Use Rand. Kick : ', F5.0/, & + ' Excluded Imag. Corridor : ', F9.4/, & + ' Selected ice model : ', A/) +#endif +! + 8972 FORMAT ( ' Wind input reduction factor in presence of ', & + /' ice :',F6.2, & + /' (0.0==> no reduction and 1.0==> no wind', & + /' input with 100% ice cover)') +! +! + 4970 FORMAT (/' Spectral output on full grid ',A/ & + ' --------------------------------------------------') + 4971 FORMAT ( ' Second order pressure at K=0:',3I4) + 4972 FORMAT ( ' Spectrum of Uss :',3I4) + 4973 FORMAT ( ' Frequency spectrum :',3I4) + 4974 FORMAT ( ' Partions of Uss :',2I4) + 4975 FORMAT ( ' Partition wavenumber #',I2,' : ',1F6.3) + +! + 4980 FORMAT (/' Coastal / iceberg reflection ',A/ & + ' --------------------------------------------------') + 4981 FORMAT ( ' Coefficient for shorelines :',F6.4) + 4989 FORMAT ( ' *** CURVLINEAR GRID: REFLECTION NOT IMPLEMENTED YET ***') + 2977 FORMAT ( ' &SIG1 IGMETHOD =',I2,', IGADDOUTP =',I2,', IGSOURCE =',I2, & + ', IGSTERMS = ',I2,', IGBCOVERWRITE =', L3,','/ & + ' IGSWELLMAX =', L3,', IGMAXFREQ =',F6.4, & + ', IGSOURCEATBP = ',I2,', IGKDMIN = ',F6.4,','/ & + ' IGFIXEDDEPTH = ',F6.2,', IGEMPIRICAL = ',F8.6,' /') +! + 2978 FORMAT ( ' &SIC2 IC2DISPER =',L3,', IC2TURB =',F6.2, & + ', IC2ROUGH =',F10.6,','/ & + ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & + ', IC2VISC =',F6.3,','/ & + ', IC2TURBS =',F8.2,', IC2DMAX =',F5.3,' /') +! + 2979 FORMAT ( ' &SIC3 IC3MAXTHK =',F6.2, ', IC3MAXCNC =',F6.2,','/ & + ' IC2TURB =',F8.2, & + ', IC2ROUGH =',F7.3,','/ & + ' IC2REYNOLDS = ',F10.1,', IC2SMOOTH = ',F10.1, & + ', IC2VISC =',F10.3,','/ & + ' IC2TURBS =',F8.2,', IC3CHENG =',L3, & + ', USECGICE =',L3,', IC3HILIM = ',F6.2,','/ & + ' IC3KILIM = ',E9.2,', IC3HICE = ',E9.2, & + ', IC3VISC = ',E9.2,','/ & + ' IC3DENS = ',E9.2,', IC3ELAS = ',E9.2,' /') +! + 2981 FORMAT ( ' &SIC5 IC5MINIG = ', E9.2, ', IC5MINWT = ', F5.2, & + ', IC5MAXKRATIO = ', E9.2, ','/ & + ' IC5MAXKI = ', E9.2, ', IC5MINHW = ', F4.0, & + ', IC5MAXITER = ', F4.0, ','/ & + ' IC5RKICK = ', F2.0, ', IC5KFILTER = ', F7.4, & + ', IC5VEMOD = ', F4.0, ' /') +! + 2966 FORMAT ( ' &MISC CICE0 =',F6.3,', CICEN =',F6.3, & + ', LICE = ',F8.1,', PMOVE =',F6.3,','/ & + ' XSEED =',F6.3,', FLAGTR = ', I1, & + ', XP =',F6.3,', XR =',F6.3,', XFILT =', F6.3 / & + ' IHM =',I5,', HSPM =',F6.3,', WSM =',F6.3, & + ', WSC =',F6.3,', FLC = ',A/ & + ' NOSW =',I3,', FMICHE =',F6.3,', RWNDC =' , & + F6.3,', WCOR1 =',F6.2,', WCOR2 =',F6.2,','/ & + ' FACBERG =',F4.1,', GSHIFT = ',E11.3, & + ', STDX = ' ,F7.2,', STDY =',F7.2,','/ & + ' STDT =', F8.2, & + ', ICEHMIN =',F5.2,', ICEHFAC =',F5.2,','/ & + ' ICEHINIT =',F5.2,', ICEDISP =',L3, & + ', ICEHDISP =',F5.2,','/ & + ' ICESLN = ',F6.2,', ICEWIND = ',F6.2, & + ', ICESNL = ',F6.2,', ICESDS = ',F5.2,','/ & + ' ICEDDISP = ',F5.2,', ICEFDISP = ',F5.2, & + ', CALTYPE = ',A8,' , TRCKCMPR = ', L3,','/ & + ' BTBET = ', F6.2, ' /') +! + 2976 FORMAT ( ' &OUTS P2SF =',I2,', I1P2SF =',I2,', I2P2SF =',I3,','/& + ' US3D =',I2,', I1US3D =',I3,', I2US3D =',I3,','/& + ' USSP =',I2,', IUSSP =',I3,','/& + ' E3D =',I2,', I1E3D =',I3,', I2E3D =',I3,','/& + ' TH1MF =',I2,', I1TH1M =',I3,', I2TH1M =',I3,','/& + ' STH1MF=',I2,', I1STH1M=',I3,', I2STH1M=',I3,','/& + ' TH2MF =',I2,', I1TH2M =',I3,', I2TH2M =',I3,','/& + ' STH2MF=',I2,', I1STH2M=',I3,', I2STH2M=',I3,' /') +! + 2986 FORMAT ( ' &REF1 REFCOAST =',F5.2,', REFFREQ =',F5.2,', REFSLOPE =',F5.3, & + ', REFMAP =',F4.1, ', REFMAPD =',F4.1, ', REFSUBGRID =',F5.2,','/ & + ' REFRMAX=',F5.2,', REFFREQPOW =',F5.2, & + ', REFICEBERG =',F5.2,', REFCOSP_STRAIGHT =',F4.1,' /') +! + 2987 FORMAT ( ' &FLD TAIL_ID =',I1,' TAIL_LEV =',F5.4,' TAILT1 =',F5.3,& + ' TAILT2 =',F5.3,' /') +#ifdef W3_RTD + + 4991 FORMAT ( ' &ROTD PLAT =', F6.2,', PLON =', F7.2,', UNROT =',L3,' /') + 4992 FORMAT ( ' &ROTB BPLAT =',9(F6.1,",")/ & + ' BPLON =',9(F6.1,","),' /') +#endif + + 3000 FORMAT (/' The spatial grid: '/ & + ' --------------------------------------------------'/ & + /' Grid type : ',A) + 3001 FORMAT ( ' Coordinate system : ',A) + 3002 FORMAT ( ' Index closure type : ',A) + 3003 FORMAT ( ' Dimensions : ',I6,I8) + 3004 FORMAT (/' Increments (deg.) :',2F10.4/ & + ' Longitude range (deg.) :',2F10.4/ & + ' Latitude range (deg.) :',2F10.4) + 3005 FORMAT ( ' Increments (km) :',2F8.2/ & + ' X range (km) :',2F8.2/ & + ' Y range (km) :',2F8.2) + 3006 FORMAT (/' X-coordinate unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Add offset :',E12.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 3007 FORMAT (/' Y-coordinate unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Add offset :',E12.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 3008 FORMAT ( ' Format : ',A) + 3009 FORMAT ( ' File name : ',A) +#ifdef W3_SMC + 4001 FORMAT ( ' SMC refined levels NRLv = ',I8) + 4002 FORMAT ( ' SMC Equator j shift no. = ',I8) + 4302 FORMAT ( ' SMC I-index shift number = ',I8) + 4003 FORMAT ( ' SMC input boundary no. = ',I8) + 4004 FORMAT ( ' SMC NCel = ',6I9) + 4005 FORMAT ( ' IJKCel(5,NCel) read from ', A) + 4006 FORMAT (6I8) + 4007 FORMAT ( ' SMC NUFc = ',6I9) + 4008 FORMAT ( ' IJKUFc(7,NCel) read from ', A) + 4009 FORMAT (8I8) + 4010 FORMAT ( ' SMC NVFc = ',6I9) + 4011 FORMAT ( ' IJKVFc(8,NCel) read from ', A) + 4110 FORMAT ( ' SMC NCObsr = ',6I9) + 4111 FORMAT ( ' IJKObstr(1,NCel) read from ', A) + 4012 FORMAT (9I8) + 4013 FORMAT ( ' NBICelin(NBISMC) read from ', A) + 4014 FORMAT (2I8) + 4015 FORMAT ( ' ARC NARC = ',6I9) + 4016 FORMAT ( ' IJKCel(5,NARC) read from ', A) + 4017 FORMAT ( ' ARC NAUI = ',6I9) + 4018 FORMAT ( ' IJKUFc(7,NAUI) read from ', A) + 4019 FORMAT ( ' ARC NAVJ = ',6I9) + 4020 FORMAT ( ' IJKVFc(8,NAVJ) read from ', A) + 4021 FORMAT ( ' Varables by W3DIMX NCel = ',I9) + 4022 FORMAT ( ' Defined NLvCel ',6I9) + 4023 FORMAT ( ' Defined NLvUFc ',6I9) + 4024 FORMAT ( ' Defined NLvVFc ',6I9) + 4025 FORMAT ( ' Define IJKCel from -9 to ',I9) + 4026 FORMAT ( ' IJKCel(5,NCel) defined : ') + 4027 FORMAT ( ' IJKUFc(7,NUFc) defined : ') + 4028 FORMAT ( ' IJKVFc(8,NVFc) defined : ') + 4029 FORMAT ( ' Boundary cells IJKCel(:,-9:0) : ') + 4030 FORMAT (5I8) + 4031 FORMAT ( ' Define MAPSF ... 1 to ',I9) + 4032 FORMAT ( ' Multi-Resolution factor = ',I6) + 4033 FORMAT ( ' Range of MAPSF(:,1) : ',2I9) + 4034 FORMAT ( ' Range of MAPSF(:,2) : ',2I9) + 4035 FORMAT ( ' Range of MAPSF(:,3) : ',2I9) + 4036 FORMAT ( ' Range of MAPFS(:,:) : ',2I9) + 4037 FORMAT ( ' Arctic AngArc defined as ',I6) + 4038 FORMAT (9F8.2) + 4039 FORMAT ( ' Arctic ICLBAC defined as ',I6) + 4040 FORMAT (9I8) +#endif +#ifdef W3_RTD + 4200 FORMAT ( ' AnglDin(NX,NY) defn checks : ') + 4201 FORMAT ( ' JY/IX',4I8) + 4202 FORMAT (I12,4F8.2) + 4203 FORMAT ( ' Rotated pole lat/lon (deg.) : ',2F9.3) + 4204 FORMAT ( ' Output dirns and x-y vectors will be set to True North') +#endif + 972 FORMAT (/' Bottom level unit :',I6/ & + ' Limiting depth (m) :',F8.2/ & + ' Minimum depth (m) :',F8.2/ & + ' Scale factor :',F8.2/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 973 FORMAT ( ' Format : ',A) + 974 FORMAT ( ' File name : ',A) + 976 FORMAT (/' Sub-grid information : ',A) + 977 FORMAT ( ' Obstructions unit :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 978 FORMAT (/' Mask information : From file.'/ & + ' Mask unit :',I6/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 1977 FORMAT ( ' Shoreline slope :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) + 1978 FORMAT ( ' Grain sizes :',I6/ & + ' Scale factor :',F10.4/ & + ' Layout indicator :',I6/ & + ' Format indicator :',I6) +! + 979 FORMAT ( ' Processing ',A) + 980 FORMAT (/' Input boundary points : '/ & + ' --------------------------------------------------') + 1980 FORMAT (/' Excluded points : '/ & + ' --------------------------------------------------') + 981 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED), IX, IY =') + 1981 FORMAT ( ' *** POINT ALREADY EXCLUDED (SKIPPED), IX, IY =') + 982 FORMAT ( ' *** CANNOT CONNECT POINTS, IX, IY =') + 985 FORMAT ( ' No boundary points.'/) + 986 FORMAT ( ' Number of boundary points :',I6/) + 1985 FORMAT ( ' No excluded points.'/) + 1986 FORMAT ( ' Number of excluded points :',I6/) + 987 FORMAT ( ' Nr.| IX | IY | Long. | Lat. '/ & + ' -----|-------|-------|---------|---------') + 1987 FORMAT ( ' Nr.| IX | IY | X | Y '/ & + ' -----|-------|-------|-----------|-----------') + 988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.2)) + 1988 FORMAT ( ' ',I4,2(' |',I6),2(' |',F8.1,'E3')) + 989 FORMAT ( ' ') +! + 990 FORMAT (/' Output boundary points : '/ & + ' --------------------------------------------------') + 991 FORMAT ( ' File nest',I1,'.ww3 Number of points :',I6/ & + ' Number of spectra :',I6) + 1991 FORMAT ( ' Dest. grid Polat:',F6.2,', Polon:',F8.2) + 992 FORMAT (/' Nr.| Long. | Lat. '/ & + ' -----|---------|---------') + 1992 FORMAT (/' Nr.| Long. | Lat. ', & + ' Nr.| Long. | Lat. '/ & + ' -----|---------|---------', & + ' -----|---------|---------') + 993 FORMAT ( ' ',I4,2(' |',F8.2)) + 1993 FORMAT ( ' ',I4,2(' |',F8.2), & + ' ',I4,2(' |',F8.2)) + 994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2F10.5) + 995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2F10.5) + 2992 FORMAT (/' Nr.| X | Y '/ & + ' -----|-----------|-----------') + 3992 FORMAT (/' Nr.| X | Y ', & + ' Nr.| X | Y '/ & + ' -----|-----------|-----------', & + ' -----|-----------|-----------') + 2993 FORMAT ( ' ',I4,2(' |',F8.1,'E3')) + 3993 FORMAT ( ' ',I4,2(' |',F8.1,'E3'), & + ' ',I4,2(' |',F8.1,'E3')) + 2994 FORMAT ( ' *** POINT OUTSIDE GRID (SKIPPED) : X,Y =',2(F8.1,'E3')) + 2995 FORMAT ( ' *** POINT ON LAND (SKIPPED) : X,Y =',2(F8.1,'E3')) + 996 FORMAT ( ' No boundary points.'/) + 997 FORMAT ( ' Number of boundary points :',I6/ & + ' Number of spectra :',I6/) +! +#ifdef W3_O2a + 998 FORMAT (50I2) +#endif +#ifdef W3_O2c + 1998 FORMAT (50I2) +#endif +! + 999 FORMAT (/' Writing model definition file ...'/) +! + 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' ERROR IN OPENING INPUT FILE'/ & + ' IOSTAT =',I5/) +! + 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' PREMATURE END OF INPUT FILE'/) +! + 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) +! + 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' INVALID CALENDAR TYPE: SELECT ONE OF:', & + ' standard, 360_day, or 365_day '/) +! + 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' CANNOT READ UNFORMATTED (IDFM = 3) FROM UNIT', & + I4,' (ww3_grid.inp)'/) +! + 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID : '/ & + ' BOTTOM AND OBSTRUCTION DATA FROM SAME FILE '/ & + ' BUT WITH INCOMPATIBLE FORMATS (',I1,',',I1,')'/) +! + 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' TOO MANY NESTING OUTPUT FILES '/) +! + 1007 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' ILLEGAL GRID TYPE:',A4) +! + 1008 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' A CARTESIAN WITH CLOSURE IS NOT ALLOWED') +! + 1009 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' A RECTILINEAR TRIPOLE GRID IS NOT ALLOWED') +! + 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'// & + ' NO PROPAGATION + NO SOURCE TERMS = NO WAVE MODEL'// & + ' ( USE DRY RUN FLAG TO TEMPORARILY SWITCH OFF ', & + 'CALCULATIONS )'/) +! + 1011 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' LEFT-HANDED GRID -- POSSIBLE CAUSE IS WRONG '/ & + ' IDLA:',I4,' . THIS MAY PRODUCE ERRORS '/ & + ' (COMMENT THIS EXTCDE AT YOUR OWN RISK).') +! + 1012 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' ILLEGAL GRID CLOSURE TYPE:',A4) +! + 1013 FORMAT (/' *** WAVEWATCH-III WARNING IN W3GRID :'/ & + ' THE GLOBAL (LOGICAL) INPUT FLAG IS DEPRECATED'/ & + ' AND REPLACED WITH A STRING INDICATING THE TYPE'/ & + ' OF GRID INDEX CLOSURE (NONE, SMPL or TRPL).'/ & + ' *** PLEASE UPDATE YOUR GRID INPUT FILE ACCORDINGLY ***'/) +! +#ifdef W3_SMC + 1014 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SMC CELL LONGITUDE RANGE OUTSIDE BASE GRID RANGE:'/& + ' ISEA =', I6, '; IX =', I4, ':', I4,'; NX =', I4/) +#endif +! +#ifdef W3_SMC + 1015 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SMC CELL LATITUDE RANGE OUTSIDE BASE GRID RANGE: '/& + ' ISEA =', I6, '; IY =', I4, ':', I4,'; NY =', I4/) +#endif +! + 1020 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRID :'/ & + ' SOURCE TERMS REQUESTED BUT NOT SELECTED'/) + 1021 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' SOURCE TERMS SELECTED BUT NOT REQUESTED'/) + 1022 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/LNn OR SEED SWITCHES :',I3) + 1023 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/STn SWITCHES :',I3) + 1024 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/NLn SWITCHES :',I3) + 1025 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/BTn SWITCHES :',I3) + 1026 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/DBn SWITCHES :',I3) + 1027 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/TRn SWITCHES :',I3) + 1028 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/BSn SWITCHES :',I3) +! + 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' PROPAGATION REQUESTED BUT NO SCHEME SELECTED '/) + 1031 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' NO PROPAGATION REQUESTED BUT SCHEME SELECTED '/) + 1032 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' NO PROPAGATION SCHEME SELECTED ( use !/PR0 ) '/) + 1033 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' MULTIPLE PROPAGATION SCHEMES SELECTED :',I3/ & + ' CHECK !/PRn SWITCHES'/) + 1034 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/ICn SWITCHES :',I3) + 1035 FORMAT (/' *** WAVEWATCH III WARNING IN W3GRID :'/ & + ' ONLY FIRST PROPAGATION SCHEME WILL BE USED: ') + 1036 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' ILLEGAL NUMBER OF !/ISn SWITCHES :',I3) +#ifdef W3_RTD + 1052 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' WITH NAMELIST VALUE PLAT == 90, PLON MUST BE -180'/ & + ' AND UNROT MUST BE .FALSE.' ) +#endif +! +#ifdef W3_RTD + 1053 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRID :'/ & + ' WITH NAMELIST VALUE BPLAT == 90, BPLON MUST BE -180') +#endif +! + 1040 FORMAT ( ' Space-time extremes DX :',F10.2) + 1041 FORMAT ( ' Space-time extremes DX :',F10.2) + 1042 FORMAT ( ' Space-time extremes DX-Y set to default 1000 m') + 1043 FORMAT ( ' Space-time extremes Dt :',F8.2) + 1044 FORMAT ( ' Space-time extremes Dt set to default 1200 s') +! + 1100 FORMAT (/' Status map, printed in',I6,' part(s) '/ & + ' -----------------------------------'/) + 1101 FORMAT (2X,180I2) + 1102 FORMAT ( ' Legend : '/ & + ' -----------------------------'/ & + ' 0 : Land point '/ & + ' 1 : Sea point '/ & + ' 2 : Active boundary point '/ & + ' 3 : Excluded point '/) + 1103 FORMAT (/' Obstruction map ',A1,', printed in',I6,' part(s) '/ & + ' ---------------------------------------------'/) + 1104 FORMAT ( ' Legend : '/ & + ' --------------------------------'/ & + ' fraction of obstruction * 10 '/) + + 1105 FORMAT (/' Shoreline slope, printed in',I6,' part(s) '/ & + ' ---------------------------------------------'/) + 1106 FORMAT ( ' Legend : '/ & + ' --------------------------------'/ & + ' Slope * 100'/) + + + 1150 FORMAT (/' Reading unstructured grid definition files ...'/) +! + 9997 FORMAT (/' Summary grid statistics : '/ & + ' --------------------------------------------------'/ & + ' Number of longitudes :',I10/ & + ' Number of latitudes :',I10/ & + ' Number of grid points :',I10/ & + ' Number of sea points :',I10,' (',F4.1,'%)'/& + ' Number of input b. points :',I10/ & + ' Number of land points :',I10/ & + ' Number of excluded points :',I10/) + 9998 FORMAT (/' Summary grid statistics : '/ & + ' --------------------------------------------------'/ & + ' Number of longitudes :',I10/ & + ' Number of latitudes :',I10/ & + ' Number of grid points :',I10/ & + ' Number of sea points :',I10,' (100%)'/ & + ' Number of input b. points :',I10/ & + ' Number of land points :',I10/ & + ' Number of excluded points :',I10/) + 9999 FORMAT (/' End of program '/ & + ' ========================================'/ & + ' WAVEWATCH III Grid preprocessor '/) +! +#ifdef W3_T + 9090 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT DATA LINE SEG.') + 9091 FORMAT ( ' ',2F8.2,4(2I4,F7.2)) + 9092 FORMAT ( ' ',F7.2,2X,4F7.2) + 9093 FORMAT ( ' ',4I7/ & + ' ',4I7) +#endif +! +#ifdef W3_T0 + 9095 FORMAT ( ' TEST W3GRID : OUTPUT BOUND. POINT SPEC DATA ') + 9096 FORMAT ( ' ',I3,2I8) +#endif + + END SUBROUTINE +!/ +!/ Internal function READNL ------------------------------------------ / +!/ +!/ ------------------------------------------------------------------- / + SUBROUTINE READNL ( NDS, NAME, STATUS ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 01-Jun-2013 | +!/ +-----------------------------------+ +!/ +! 1. Purpose : +! +! Read namelist info from file if namelist is found in file. +! +! 2. Method : +! +! Look for namelist with name NAME in unit NDS and read if found. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! NDS Int. I Data set number used for search. +! NAME C*4 I Name of namelist. +! STATUS C*20 O Status at end of routine, +! '(default values) ' if no namelist found. +! '(user def. values)' if namelist read. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! EXTCDE Subr. W3SERVMD Abort program as graceful as possible. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Program in which it is contained. +! +! 6. Error messages : +! +! 7. Remarks : +! +! 8. Structure : +! +! 9. Switches : +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: NDS + CHARACTER, INTENT(IN) :: NAME*4 + CHARACTER, INTENT(OUT) :: STATUS*20 +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + INTEGER :: IERR, I, J + CHARACTER :: LINE*80 +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'READNL') +#endif +! + REWIND (NDS) + STATUS = '(default values) : ' +! + DO + READ (NDS,'(A)',END=800,ERR=800,IOSTAT=IERR) LINE + DO I=1, 70 + IF ( LINE(I:I) .NE. ' ' ) THEN + IF ( LINE(I:I) .EQ. '&' ) THEN + IF ( LINE(I+1:I+4) .EQ. NAME ) THEN + BACKSPACE (NDS) + SELECT CASE(NAME) +#ifdef W3_FLD1 + CASE('FLD1') + READ (NDS,NML=FLD1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_FLD2 + CASE('FLD2') + READ (NDS,NML=FLD2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_FLX3 + CASE('FLX3') + READ (NDS,NML=FLX3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_FLX4 + CASE('FLX4') + READ (NDS,NML=FLX4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_LN1 + CASE('SLN1') + READ (NDS,NML=SLN1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST1 + CASE('SIN1') + READ (NDS,NML=SIN1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST2 + CASE('SIN2') + READ (NDS,NML=SIN2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST3 + CASE('SIN3') + READ (NDS,NML=SIN3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST4 + CASE('SIN4') + READ (NDS,NML=SIN4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST6 + CASE('SIN6') + READ (NDS,NML=SIN6,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_NL1 + CASE('SNL1') + READ (NDS,NML=SNL1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_NL2 + CASE('SNL2') + READ (NDS,NML=SNL2,END=801,ERR=802,IOSTAT=J) + CASE('ANL2') + IF ( NDEPTH .GT. 100 ) GOTO 804 + DEPTHS(1:NDEPTH) = DPTHNL + READ (NDS,NML=ANL2,END=801,ERR=802,IOSTAT=J) + DPTHNL = DEPTHS(1:NDEPTH) +#endif +#ifdef W3_NL3 + CASE('SNL3') + READ (NDS,NML=SNL3,END=801,ERR=802,IOSTAT=J) + CASE('ANL3') + IF ( NQDEF .GT. 100 ) GOTO 804 + READ (NDS,NML=ANL3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_NL4 + CASE('SNL4') + READ (NDS,NML=SNL4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_NL5 + CASE('SNL5') + READ (NDS,NML=SNL5,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_NLS + CASE('SNLS') + READ (NDS,NML=SNLS,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST1 + CASE('SDS1') + READ (NDS,NML=SDS1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST2 + CASE('SDS2') + READ (NDS,NML=SDS2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST3 + CASE('SDS3') + READ (NDS,NML=SDS3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST4 + CASE('SDS4') + READ (NDS,NML=SDS4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_ST6 + CASE('SDS6') + READ (NDS,NML=SDS6,END=801,ERR=802,IOSTAT=J) + CASE('SWL6') + READ (NDS,NML=SWL6,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_BT1 + CASE('SBT1') + READ (NDS,NML=SBT1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_BT4 + CASE('SBT4') + READ (NDS,NML=SBT4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IS1 + CASE('SIS1') + READ (NDS,NML=SIS1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IS2 + CASE('SIS2') + READ (NDS,NML=SIS2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_DB1 + CASE('SDB1') + READ (NDS,NML=SDB1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_UOST + CASE('UOST') + READ (NDS,NML=UOST,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_PR1 + CASE('PRO1') + READ (NDS,NML=PRO1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_PR2 + CASE('PRO2') + READ (NDS,NML=PRO2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_SMC + CASE('PSMC') + READ (NDS,NML=PSMC,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_PR3 + CASE('PRO3') + READ (NDS,NML=PRO3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_RTD + CASE('ROTD') + READ (NDS,NML=ROTD,END=801,ERR=802,IOSTAT=J) + CASE('ROTB') + READ (NDS,NML=ROTB,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_REF1 + CASE('REF1') + READ (NDS,NML=REF1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IG1 + CASE('SIG1') + READ (NDS,NML=SIG1,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IC2 + CASE('SIC2') + READ (NDS,NML=SIC2,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IC3 + CASE('SIC3') + READ (NDS,NML=SIC3,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IC4 + CASE('SIC4 ') + READ (NDS,NML=SIC4,END=801,ERR=802,IOSTAT=J) +#endif +#ifdef W3_IC5 + CASE('SIC5 ') + READ (NDS,NML=SIC5,END=801,ERR=802,IOSTAT=J) +#endif + CASE('UNST') + READ (NDS,NML=UNST,END=801,ERR=802,IOSTAT=J) + CASE('OUTS') + READ (NDS,NML=OUTS,END=801,ERR=802,IOSTAT=J) + CASE('MISC') + READ (NDS,NML=MISC,END=801,ERR=802,IOSTAT=J) + CASE DEFAULT + GOTO 803 + END SELECT + STATUS = '(user def. values) :' + RETURN + END IF + ELSE + EXIT + END IF + ENDIF + END DO + END DO +! + 800 CONTINUE + RETURN +! + 801 CONTINUE + WRITE (NDSE,1001) NAME + CALL EXTCDE(1) + RETURN +! + 802 CONTINUE + WRITE (NDSE,1002) NAME, J + CALL EXTCDE(2) + RETURN +! + 803 CONTINUE + WRITE (NDSE,1003) NAME + CALL EXTCDE(3) + RETURN +! +#ifdef W3_NL2 + 804 CONTINUE + WRITE (NDSE,1004) NDEPTH + CALL EXTCDE(4) + RETURN +#endif +! +#ifdef W3_NL3 + 804 CONTINUE + WRITE (NDSE,1004) NQDEF + CALL EXTCDE(4) + RETURN +#endif +! +! Formats +! + 1001 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' PREMATURE END OF FILE IN READING ',A/) + 1002 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' ERROR IN READING ',A,' IOSTAT =',I8/) + 1003 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' NAMELIST NAME ',A,' NOT RECOGNIZED'/) +#ifdef W3_NL2 + 1004 FORMAT (/' *** WAVEWATCH III ERROR IN READNL : '/ & + ' TEMP DEPTH ARRAY TOO SMALL, .LE. ',I8/) +#endif +#ifdef W3_NL3 + 1004 FORMAT (/' *** WAVEWATCH-III ERROR IN READNL : '/ & + ' TEMP QPARMS ARRAY TOO SMALL, .LE. ',I8/) +#endif +!/ +!/ End of READNL ----------------------------------------------------- / +!/ + END SUBROUTINE +!/ +!/ End of W3GRID ----------------------------------------------------- / +!/ + END MODULE W3GRIDMD diff --git a/model/ftn/w3gsrumd.ftn b/model/src/w3gsrumd.F90 similarity index 97% rename from model/ftn/w3gsrumd.ftn rename to model/src/w3gsrumd.F90 index dd662ff54..3bc86215f 100644 --- a/model/ftn/w3gsrumd.ftn +++ b/model/src/w3gsrumd.F90 @@ -234,7 +234,9 @@ MODULE W3GSRUMD #ifdef ENABLE_WW3 USE W3SERVMD, ONLY: EXTCDE #endif -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ Specify default data typing !/ @@ -635,8 +637,10 @@ FUNCTION W3GSUC_PTR_R4( IJG, LLG, ICLO, XG, YG, & ! Local parameters INTEGER :: LB(2), UB(2) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUC_PTR_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_PTR_R4') +#endif ! LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) @@ -662,8 +666,10 @@ FUNCTION W3GSUC_PTR_R8( IJG, LLG, ICLO, XG, YG, & ! Local parameters INTEGER :: LB(2), UB(2) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUC_PTR_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_PTR_R4') +#endif ! LB(1) = LBOUND(XG,1); LB(2) = LBOUND(XG,2) UB(1) = UBOUND(XG,1); UB(2) = UBOUND(XG,2) @@ -690,8 +696,10 @@ FUNCTION W3GSUC_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & LOGICAL, INTENT(IN), OPTIONAL :: DEBUG ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUC_TGT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_TGT_R4') +#endif ! GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4=XG, YG4=YG, & NCB=NCB, NNP=NNP, DEBUG=DEBUG) @@ -716,8 +724,10 @@ FUNCTION W3GSUC_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & LOGICAL, INTENT(IN), OPTIONAL :: DEBUG ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUC_TGT_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC_TGT_R8') +#endif ! GSU = GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG8=XG, YG8=YG, & NCB=NCB, NNP=NNP, DEBUG=DEBUG) @@ -781,8 +791,10 @@ SUBROUTINE W3GSUD( GSU ) ! Local parameters INTEGER :: IB, JB -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUD') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUD') +#endif ! IF ( ASSOCIATED(GSU%PTR) ) THEN ! @@ -879,8 +891,10 @@ SUBROUTINE W3GSUP( GSU, IUNIT, LFULL ) INTEGER, PARAMETER :: NBYTE_INT=4 TYPE(CLASS_GSU), POINTER :: PTR INTEGER :: NDST, K, IB, JB, NBYTE -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUP') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUP') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -1070,8 +1084,10 @@ SUBROUTINE W3BBOX_GSU( GSU, XMIN, YMIN, XMAX, YMAX ) REAL(8), INTENT(OUT) :: XMIN, YMIN, XMAX, YMAX ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3BBOX_GSU') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GSU') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -1106,8 +1122,10 @@ SUBROUTINE W3BBOX_GRD_PTR_R4( IJG, LLG, ICLO, XG, YG, & ! Local parameters TYPE(T_GSU) :: GSU INTEGER :: LB(2), UB(2) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R4') +#endif ! ! -------------------------------------------------------------------- / ! 1. Set bounding box @@ -1137,8 +1155,10 @@ SUBROUTINE W3BBOX_GRD_PTR_R8( IJG, LLG, ICLO, XG, YG, & ! Local parameters TYPE(T_GSU) :: GSU INTEGER :: LB(2), UB(2) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_PTR_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Set bounding box @@ -1168,8 +1188,10 @@ SUBROUTINE W3BBOX_GRD_TGT_R4( IJG, LLG, ICLO, LB, UB, XG, YG, & ! Local parameters TYPE(T_GSU) :: GSU -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R4') +#endif ! ! -------------------------------------------------------------------- / ! 1. Set bounding box @@ -1197,8 +1219,10 @@ SUBROUTINE W3BBOX_GRD_TGT_R8( IJG, LLG, ICLO, LB, UB, XG, YG, & ! Local parameters TYPE(T_GSU) :: GSU -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3BBOX_GRD_TGT_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Set bounding box @@ -1317,8 +1341,10 @@ FUNCTION W3GFCL_R4( GSU, XT, YT, IS, JS, XS, YS, & ! Local parameters REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFCL_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCL_R4') +#endif ! !-----set inputs XT8 = XT; YT8 = YT; @@ -1371,8 +1397,10 @@ FUNCTION W3GFCL_R8( GSU, XT, YT, IS, JS, XS, YS, & INTEGER :: NLEVEL, LVL, LVL1, N1, IB0, JB0, IB1, JB1, K1 INTEGER :: IS1(4), JS1(4) REAL(8) :: XS1(4), YS1(4), XSM, YSM, DD, DD1 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFCL_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCL_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -1739,8 +1767,10 @@ FUNCTION W3GFCD_R4( GSU, XT, YT, IS, JS, XS, YS, & ! Local parameters REAL(8) :: XT8, YT8, XS8(4), YS8(4), EPS8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFCD_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCD_R4') +#endif ! !-----set inputs XT8 = XT; YT8 = YT; @@ -1785,8 +1815,10 @@ FUNCTION W3GFCD_R8( GSU, XT, YT, IS, JS, XS, YS, & INTEGER :: LXC, LYC, UXC, UYC REAL(4), POINTER :: XG4(:,:), YG4(:,:) REAL(8), POINTER :: XG8(:,:), YG8(:,:) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFCD_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFCD_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -2017,8 +2049,10 @@ FUNCTION W3GFPT_R4( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & ! Local parameters REAL(8) :: XT8, YT8, EPS8, DCIN8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFPT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFPT_R4') +#endif ! !-----set inputs XT8 = XTIN; YT8 = YTIN; @@ -2063,8 +2097,10 @@ FUNCTION W3GFPT_R8( GSU, XTIN, YTIN, IX, IY, EPS, DCIN, DEBUG ) & REAL(8) :: XTC, YTC, XSC(4), YSC(4) REAL(8) :: IXR, JXR, DD, LON0, LAT0, DMIN LOGICAL :: IJG, LLG -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFPT_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFPT_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -2252,8 +2288,10 @@ FUNCTION W3GFIJ_R4( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & ! Local parameters REAL(8) :: XT8, YT8, IX8, JX8, EPS8, DCIN8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFIJ_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFIJ_R4') +#endif ! !-----set inputs XT8 = XTIN; YT8 = YTIN; @@ -2300,8 +2338,10 @@ FUNCTION W3GFIJ_R8( GSU, XTIN, YTIN, IX, JX, EPS, DCIN, DEBUG ) & REAL(8) :: XT, YT, XS(4), YS(4) REAL(8) :: XTC, YTC, XSC(4), YSC(4) REAL(8) :: IXR, JXR, DD, LON0, LAT0 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GFIJ_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GFIJ_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -2497,8 +2537,10 @@ FUNCTION W3GRMP_R4( GSU, XTIN, YTIN, IS, JS, RW, EPS, & ! Local parameters REAL(8) :: XT8, YT8, RW8(4), EPS8, DCIN8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRMP_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMP_R4') +#endif ! !-----set inputs XT8 = XTIN; YT8 = YTIN; @@ -2559,8 +2601,10 @@ FUNCTION W3GRMP_R8( GSU, XTIN, YTIN, IS, JS, RW, EPS, & REAL(4), POINTER :: XG4(:,:), YG4(:,:) REAL(8), POINTER :: XG8(:,:), YG8(:,:) TYPE(T_NNS), POINTER :: NNP -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRMP_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMP_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -2969,8 +3013,10 @@ FUNCTION W3GRMC_R4( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & REAL(8) :: LEPS, LDCIN, LWDTH=ZERO REAL(8) :: XT, YT REAL(8), POINTER :: CS8(:) => NULL() -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRMC_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMC_R4') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -3076,8 +3122,10 @@ FUNCTION W3GRMC_R8( GSU, XTIN, YTIN, RTYP, NS, IS, JS, CS, EPS, & LOGICAL :: IJG, LLG, LCLO INTEGER :: ICLO, GKIND INTEGER :: LBX, LBY, UBX, UBY, NX, NY -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRMC_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRMC_R8') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -3539,8 +3587,10 @@ FUNCTION W3CKCL_R4( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & ! Local parameters REAL(8) :: XT8, YT8, XS8(NS), YS8(NS), EPS8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3CKCL_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CKCL_R4') +#endif ! !-----set inputs XT8 = XT; XS8 = XS; @@ -3583,8 +3633,10 @@ FUNCTION W3CKCL_R8( LLG, XT, YT, NS, XS, YS, POLE, EPS, DEBUG ) & REAL(8) :: V1X, V1Y, V2X, V2Y, S90 REAL(8) :: CROSS REAL(8) :: SIGN1 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3CKCL_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CKCL_R8') +#endif INCELL = .TRUE. ! @@ -4019,8 +4071,10 @@ SUBROUTINE W3CGDM_R4( IJG, LLG, ICLO, PTILED, QTILED, & REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3CGDM_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CGDM_R4') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -4370,8 +4424,10 @@ SUBROUTINE W3CGDM_R8( IJG, LLG, ICLO, PTILED, QTILED, & REAL(8) :: DXDPL, DYDPL, DXDQL, DYDQL REAL(8) :: DPDXL, DPDYL, DQDXL, DQDYL REAL(8) :: COSAL, SINAL, COSTP, SINTP, COSCL, SINCL, ANGLL -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3CGDM_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3CGDM_R8') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -4778,8 +4834,10 @@ SUBROUTINE W3GRD0_R4( NFD, IJG, ICLO, PTILED, QTILED, & INTEGER :: K(0:NFD,0:NFD,1:NFD) REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DFDP, DFDQ -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRD0_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRD0_R4') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -4897,8 +4955,10 @@ SUBROUTINE W3GRD0_R8( NFD, IJG, ICLO, PTILED, QTILED, & INTEGER :: K(0:NFD,0:NFD,1:NFD) REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DFDP, DFDQ -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GRD0_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GRD0_R8') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -5106,8 +5166,10 @@ SUBROUTINE W3DIV1_R4( NFD, IJG, ICLO, PTILED, QTILED, & REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ REAL(8) :: DVXDX, DVYDY -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIV1_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV1_R4') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -5228,8 +5290,10 @@ SUBROUTINE W3DIV1_R8( NFD, IJG, ICLO, PTILED, QTILED, & REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DVXDP, DVXDQ, DVYDP, DVYDQ REAL(8) :: DVXDX, DVYDY -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIV1_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV1_R8') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -5444,8 +5508,10 @@ SUBROUTINE W3DIV2_R4( NFD, IJG, ICLO, PTILED, QTILED, & REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIV2_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV2_R4') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -5572,8 +5638,10 @@ SUBROUTINE W3DIV2_R8( NFD, IJG, ICLO, PTILED, QTILED, & REAL(8) :: C(0:NFD,0:NFD,1:NFD) REAL(8) :: DXXDP, DXXDQ, DYYDP, DYYDQ, DXYDP, DXYDQ REAL(8) :: DXXDX, DYYDY, DXYDX, DXYDY -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIV2_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIV2_R8') +#endif ! -------------------------------------------------------------------- / ! 1. Check and setup inputs ! @@ -5740,8 +5808,10 @@ FUNCTION W3DIST_R4( LLG, XT, YT, XS, YS ) RESULT(DIST) ! Local parameters REAL(8) :: XT8, YT8, XS8, YS8 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIST_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIST_R4') +#endif ! !-----set inputs XT8 = XT; YT8 = YT; @@ -5765,8 +5835,10 @@ FUNCTION W3DIST_R8( LLG, XT, YT, XS, YS ) RESULT(DIST) ! Local parameters REAL(8) :: DX, DY, SLAM, SPHI, ARGD -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3DIST_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3DIST_R8') +#endif ! !-----compute displacements DX = XT - XS @@ -5876,8 +5948,10 @@ SUBROUTINE W3SPLX_0D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_0D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_0D_R4') +#endif CLAM = COS((LAM-LAM0)*D2R) SLAM = SIN((LAM-LAM0)*D2R) @@ -5902,8 +5976,10 @@ SUBROUTINE W3SPLX_0D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters REAL(8) :: K, K0, CLAM, SLAM, CPHI0, CPHI, SPHI0, SPHI -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_0D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_0D_R8') +#endif CLAM = COS((LAM-LAM0)*D2R) SLAM = SIN((LAM-LAM0)*D2R) @@ -5928,8 +6004,10 @@ SUBROUTINE W3SPLX_1D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_1D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_1D_R4') +#endif DO I = LBOUND(LAM,1),UBOUND(LAM,1) CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) @@ -5947,8 +6025,10 @@ SUBROUTINE W3SPLX_1D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_1D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_1D_R8') +#endif DO I = LBOUND(LAM,1),UBOUND(LAM,1) CALL W3SPLX( LAM0, PHI0, C0, LAM(I), PHI(I), X(I), Y(I) ) @@ -5966,8 +6046,10 @@ SUBROUTINE W3SPLX_2D_R4( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_2D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_2D_R4') +#endif DO J = LBOUND(LAM,2),UBOUND(LAM,2) DO I = LBOUND(LAM,1),UBOUND(LAM,1) @@ -5987,8 +6069,10 @@ SUBROUTINE W3SPLX_2D_R8( LAM0, PHI0, C0, LAM, PHI, X, Y ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPLX_2D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPLX_2D_R8') +#endif DO J = LBOUND(LAM,2),UBOUND(LAM,2) DO I = LBOUND(LAM,1),UBOUND(LAM,1) @@ -6070,8 +6154,10 @@ SUBROUTINE W3SPXL_0D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_0D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_0D_R4') +#endif K0 = COS(HALF*C0*D2R)**2 RHO = SQRT(X*X+Y*Y) @@ -6095,8 +6181,10 @@ SUBROUTINE W3SPXL_0D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters REAL(8) :: K0, RHO, C, COSC, SINC, CPHI0, SPHI0 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_0D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_0D_R8') +#endif K0 = COS(HALF*C0*D2R)**2 RHO = SQRT(X*X+Y*Y) @@ -6120,8 +6208,10 @@ SUBROUTINE W3SPXL_1D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_1D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_1D_R4') +#endif DO I = LBOUND(X,1),UBOUND(X,1) CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) @@ -6139,8 +6229,10 @@ SUBROUTINE W3SPXL_1D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_1D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_1D_R8') +#endif DO I = LBOUND(X,1),UBOUND(X,1) CALL W3SPXL( LAM0, PHI0, C0, X(I), Y(I), LAM(I), PHI(I) ) @@ -6158,8 +6250,10 @@ SUBROUTINE W3SPXL_2D_R4( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_2D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_2D_R4') +#endif DO J = LBOUND(X,2),UBOUND(X,2) DO I = LBOUND(X,1),UBOUND(X,1) @@ -6179,8 +6273,10 @@ SUBROUTINE W3SPXL_2D_R8( LAM0, PHI0, C0, X, Y, LAM, PHI ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SPXL_2D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SPXL_2D_R8') +#endif DO J = LBOUND(X,2),UBOUND(X,2) DO I = LBOUND(X,1),UBOUND(X,1) @@ -6259,8 +6355,10 @@ SUBROUTINE W3TRLL_0D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_0D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_0D_R4') +#endif CLAM = COS((LAM1-LAM0)*D2R) SLAM = SIN((LAM1-LAM0)*D2R) @@ -6283,8 +6381,10 @@ SUBROUTINE W3TRLL_0D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters REAL(8) :: CLAM, SLAM, CALP, SALP, CPHI, SPHI -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_0D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_0D_R8') +#endif CLAM = COS((LAM1-LAM0)*D2R) SLAM = SIN((LAM1-LAM0)*D2R) @@ -6307,8 +6407,10 @@ SUBROUTINE W3TRLL_1D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_1D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_1D_R4') +#endif DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) @@ -6326,8 +6428,10 @@ SUBROUTINE W3TRLL_1D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_1D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_1D_R8') +#endif DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) CALL W3TRLL( LAM0, PHI0, LAM1(I), PHI1(I), LAM(I), PHI(I) ) @@ -6345,8 +6449,10 @@ SUBROUTINE W3TRLL_2D_R4( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_2D_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_2D_R4') +#endif DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) @@ -6366,8 +6472,10 @@ SUBROUTINE W3TRLL_2D_R8( LAM0, PHI0, LAM1, PHI1, LAM, PHI ) ! Local parameters INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3TRLL_2D_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3TRLL_2D_R8') +#endif DO J = LBOUND(LAM1,2),UBOUND(LAM1,2) DO I = LBOUND(LAM1,1),UBOUND(LAM1,1) @@ -6448,8 +6556,10 @@ FUNCTION W3LLAZ_R4( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) ! Local parameters REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3LLAZ_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3LLAZ_R4') +#endif CLAM = COS((LAM2-LAM1)*D2R) SLAM = SIN((LAM2-LAM1)*D2R) @@ -6471,8 +6581,10 @@ FUNCTION W3LLAZ_R8( LAM1, PHI1, LAM2, PHI2 ) RESULT(AZ) ! Local parameters REAL(8) :: CLAM, SLAM, CPH1, SPH1, CPH2, SPH2 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3LLAZ_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3LLAZ_R8') +#endif CLAM = COS((LAM2-LAM1)*D2R) SLAM = SIN((LAM2-LAM1)*D2R) @@ -6556,8 +6668,10 @@ SUBROUTINE W3FDWT_R4 ( N, ND, M, Z, X, C ) ! Local parameters INTEGER :: I, J, K, MN REAL(8) :: C1, C2, C3, C4, C5 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3FDWT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3FDWT_R4') +#endif C1 = ONE C4 = X(0)-Z @@ -6599,8 +6713,10 @@ SUBROUTINE W3FDWT_R8 ( N, ND, M, Z, X, C ) ! Local parameters INTEGER :: I, J, K, MN REAL(8) :: C1, C2, C3, C4, C5 -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3FDWT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3FDWT_R4') +#endif C1 = ONE C4 = X(0)-Z @@ -6706,8 +6822,10 @@ FUNCTION W3NNSC( NLVL ) RESULT(NNS) ! Local parameters INTEGER :: I, J, L, N -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3NNSC') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSC') +#endif ! !-----allocate object ALLOCATE(NNS) @@ -6813,8 +6931,10 @@ SUBROUTINE W3NNSD( NNS ) TYPE(T_NNS), POINTER :: NNS ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3NNSD') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSD') +#endif ! IF ( ASSOCIATED(NNS) ) THEN NNS%NLVL = 0 @@ -6894,8 +7014,10 @@ SUBROUTINE W3NNSP(NNS, IUNIT) ! Local parameters INTEGER :: NDST, L, N -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3NNSP') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3NNSP') +#endif ! IF ( PRESENT(IUNIT) ) THEN NDST = IUNIT @@ -6971,8 +7093,10 @@ SUBROUTINE W3SORT_R4( N, I, J, D ) ! Local parameters INTEGER :: K, L, IM, JM REAL(4) :: DM -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SORT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SORT_R4') +#endif DO K=1, N-1 DO L=K+1, N @@ -6998,8 +7122,10 @@ SUBROUTINE W3SORT_R8( N, I, J, D ) ! Local parameters INTEGER :: K, L, IM, JM REAL(8) :: DM -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SORT_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3SORT_R8') +#endif DO K=1, N-1 DO L=K+1, N @@ -7074,8 +7200,10 @@ SUBROUTINE W3ISRT_R4( II, JJ, DD, N, I, J, D ) ! Local parameters INTEGER :: K, L -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3ISRT_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3ISRT_R4') +#endif K_LOOP: DO K=1,N IF ( DD .LT. D(K) ) THEN @@ -7105,8 +7233,10 @@ SUBROUTINE W3ISRT_R8( II, JJ, DD, N, I, J, D ) ! Local parameters INTEGER :: K, L -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3ISRT_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3ISRT_R8') +#endif K_LOOP: DO K=1,N IF ( DD .LT. D(K) ) THEN @@ -7177,8 +7307,10 @@ FUNCTION W3INAN_R4( X ) RESULT(INAN) REAL(4), INTENT(IN) :: X ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3INAN_R4') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3INAN_R4') +#endif !-----return true if X is NaN or +Inf or -Inf INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) @@ -7193,8 +7325,10 @@ FUNCTION W3INAN_R8( X ) RESULT(INAN) REAL(8), INTENT(IN) :: X ! Local parameters -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3INAN_R8') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3INAN_R8') +#endif !-----return true if X is NaN or +Inf or -Inf INAN = .NOT. ( X .GE. -HUGE(X) .AND. X .LE. HUGE(X) ) @@ -7245,8 +7379,10 @@ FUNCTION GSU_CREATE( IJG, LLG, ICLO, LB, UB, XG4, YG4, XG8, YG8, & INTEGER :: NS, IB1(2), IB2(2), JB1(2), JB2(2), IBC(4), JBC(4) INTEGER :: ISTEP, ISTAT REAL(8) :: XC(4), YC(4) -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'W3GSUC') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'W3GSUC') +#endif ! -------------------------------------------------------------------- / ! 1. Test input ! @@ -7734,8 +7870,10 @@ SUBROUTINE GETPQR( XT, YT, XS, YS, PR, QR, EPS, DEBUG ) INTEGER :: K, ITER REAL(8) :: DXT, DX1, DX2, DX3, DXP, DYT, DY1, DY2, DY3, DYP REAL(8) :: MAT1, MAT2, MAT3, MAT4, DELP, DELQ, DET -!/S INTEGER, SAVE :: IENT = 0 -!/S CALL STRACE (IENT, 'GETPQR') +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 + CALL STRACE (IENT, 'GETPQR') +#endif IF ( PRESENT(EPS) ) THEN IF ( EPS .LT. ZERO ) THEN diff --git a/model/ftn/w3idatmd.ftn b/model/src/w3idatmd.F90 similarity index 83% rename from model/ftn/w3idatmd.ftn rename to model/src/w3idatmd.F90 index 72bcfbd6b..e5d80edb9 100644 --- a/model/ftn/w3idatmd.ftn +++ b/model/src/w3idatmd.F90 @@ -148,8 +148,10 @@ MODULE W3IDATMD INTEGER :: JFIRST = 1 -!/TIDE INTEGER :: NTIDE ! number of tidal constituents -!/TIDE REAL, ALLOCATABLE :: TIDEFREQ(:) +#ifdef W3_TIDE + INTEGER :: NTIDE ! number of tidal constituents + REAL, ALLOCATABLE :: TIDEFREQ(:) +#endif !/ !/ Data structure INPUT !/ @@ -157,7 +159,9 @@ MODULE W3IDATMD INTEGER :: TFN(2,-7:10), TC0(2), TW0(2), & TU0(2), TR0(2), TDN(2), TG0(2) REAL :: GA0, GD0, GAN, GDN -!/WRST REAL, POINTER :: WXNwrst(:,:),WYNwrst(:,:) +#ifdef W3_WRST + REAL, POINTER :: WXNwrst(:,:),WYNwrst(:,:) +#endif REAL, POINTER :: WX0(:,:), WY0(:,:), DT0(:,:), & WXN(:,:), WYN(:,:), DTN(:,:), & CX0(:,:), CY0(:,:), CXN(:,:), & @@ -167,10 +171,14 @@ MODULE W3IDATMD BERGI(:,:), MUDT(:,:), MUDV(:,:), & MUDD(:,:), ICEP1(:,:), ICEP2(:,:), & ICEP3(:,:), ICEP4(:,:), ICEP5(:,:) -!/TIDE REAL, POINTER :: CXTIDE(:,:,:,:), CYTIDE(:,:,:,:), & -!/TIDE WLTIDE(:,:,:,:) +#ifdef W3_TIDE + REAL, POINTER :: CXTIDE(:,:,:,:), CYTIDE(:,:,:,:), & + WLTIDE(:,:,:,:) +#endif LOGICAL :: IINIT -!/WRST LOGICAL :: WRSTIINIT=.FALSE. +#ifdef W3_WRST + LOGICAL :: WRSTIINIT=.FALSE. +#endif ! note that if size of INFLAGS1 is changed, then TFLAGS in wminitmd.ftn ! also must be resized. LOGICAL :: INFLAGS1(-7:14), FLAGSC(-7:14), & @@ -192,7 +200,9 @@ MODULE W3IDATMD REAL, POINTER :: GA0, GD0, GAN, GDN REAL, POINTER :: WX0(:,:), WY0(:,:), DT0(:,:), & WXN(:,:), WYN(:,:), DTN(:,:), & -!/WRST WXNwrst(:,:),WYNwrst(:,:), & +#ifdef W3_WRST + WXNwrst(:,:),WYNwrst(:,:), & +#endif CX0(:,:), CY0(:,:), CXN(:,:), & CYN(:,:), WLEV(:,:), ICEI(:,:), & UX0(:,:), UY0(:,:), UXN(:,:), & @@ -200,16 +210,20 @@ MODULE W3IDATMD BERGI(:,:), MUDT(:,:), MUDV(:,:), & MUDD(:,:), ICEP1(:,:), ICEP2(:,:), & ICEP3(:,:), ICEP4(:,:), ICEP5(:,:) -!/TIDE REAL, POINTER :: CXTIDE(:,:,:,:), & -!/TIDE CYTIDE(:,:,:,:), WLTIDE(:,:,:,:) +#ifdef W3_TIDE + REAL, POINTER :: CXTIDE(:,:,:,:), & + CYTIDE(:,:,:,:), WLTIDE(:,:,:,:) +#endif LOGICAL, POINTER :: IINIT LOGICAL, POINTER :: INFLAGS1(:), INFLAGS2(:), FLAGSC(:) LOGICAL, POINTER :: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, & FLRHOA LOGICAL, POINTER :: FLMTH, FLMVS, FLMDN LOGICAL, POINTER :: FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 -!/TIDE LOGICAL, POINTER :: FLLEVTIDE, FLCURTIDE, & -!/TIDE FLLEVRESI, FLCURRESI +#ifdef W3_TIDE + LOGICAL, POINTER :: FLLEVTIDE, FLCURTIDE, & + FLLEVRESI, FLCURRESI +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -269,7 +283,9 @@ SUBROUTINE W3NINP ( NDSE, NDST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NGRIDS, NAUXGR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -282,9 +298,13 @@ SUBROUTINE W3NINP ( NDSE, NDST ) !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3NINP') +#ifdef W3_S + CALL STRACE (IENT, 'W3NINP') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -329,7 +349,9 @@ SUBROUTINE W3NINP ( NDSE, NDST ) INPUTS(I)%FLAGSC = .FALSE. END DO ! -!/T WRITE (NDST,9000) -NAUXGR, NGRIDS +#ifdef W3_T + WRITE (NDST,9000) -NAUXGR, NGRIDS +#endif ! RETURN ! @@ -339,7 +361,9 @@ SUBROUTINE W3NINP ( NDSE, NDST ) ' NGRIDS = ',I10/ & ' RUN W3NMOD FIRST'/) ! -!/T 9000 FORMAT (' TEST W3NINP : SETTING UP FOR ',I2,' -',I3,' GRIDS') +#ifdef W3_T + 9000 FORMAT (' TEST W3NINP : SETTING UP FOR ',I2,' -',I3,' GRIDS') +#endif !/ !/ End of W3NINP ----------------------------------------------------- / !/ @@ -410,9 +434,13 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NGRIDS, NAUXGR, IGRID, W3SETG, NX, NY -!/SMC USE W3GDATMD, ONLY: FSWND, NSEA +#ifdef W3_SMC + USE W3GDATMD, ONLY: FSWND, NSEA +#endif USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -427,9 +455,13 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) !/ INTEGER :: JGRID LOGICAL :: FLAGSTIDE(4)=.FALSE. -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DIMI') +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMI') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -449,7 +481,9 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -457,9 +491,11 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! -------------------------------------------------------------------- / ! 2. Allocate arrays ! -!/TIDE IF ( PRESENT(FLAGSTIDEIN) ) THEN -!/TIDE FLAGSTIDE(:) = FLAGSTIDEIN(:) -!/TIDE END IF +#ifdef W3_TIDE + IF ( PRESENT(FLAGSTIDEIN) ) THEN + FLAGSTIDE(:) = FLAGSTIDEIN(:) + END IF +#endif FLIC1 => INPUTS(IMOD)%INFLAGS1(-7) FLIC2 => INPUTS(IMOD)%INFLAGS1(-6) @@ -473,15 +509,17 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! FLLEV => INPUTS(IMOD)%INFLAGS1(1) FLCUR => INPUTS(IMOD)%INFLAGS1(2) -!/TIDE FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) -!/TIDE FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) -!/TIDE FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) -!/TIDE FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) -!/TIDE! -!/TIDE FLLEVTIDE = FLAGSTIDE(1) -!/TIDE FLCURTIDE = FLAGSTIDE(2) -!/TIDE FLLEVRESI = FLAGSTIDE(3) -!/TIDE FLCURRESI = FLAGSTIDE(4) +#ifdef W3_TIDE + FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) + FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) + FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) + FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) +! + FLLEVTIDE = FLAGSTIDE(1) + FLCURTIDE = FLAGSTIDE(2) + FLLEVRESI = FLAGSTIDE(3) + FLCURRESI = FLAGSTIDE(4) +#endif FLWIND => INPUTS(IMOD)%INFLAGS1(3) FLICE => INPUTS(IMOD)%INFLAGS1(4) @@ -531,54 +569,66 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) END IF ! IF ( FLCUR ) THEN -!/SMC IF( FSWND ) THEN -!/SMC ALLOCATE ( INPUTS(IMOD)%CX0(NSEA,1) , & -!/SMC INPUTS(IMOD)%CY0(NSEA,1) , & -!/SMC INPUTS(IMOD)%CXN(NSEA,1) , & -!/SMC INPUTS(IMOD)%CYN(NSEA,1) , STAT=ISTAT ) -!/SMC ELSE +#ifdef W3_SMC + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%CX0(NSEA,1) , & + INPUTS(IMOD)%CY0(NSEA,1) , & + INPUTS(IMOD)%CXN(NSEA,1) , & + INPUTS(IMOD)%CYN(NSEA,1) , STAT=ISTAT ) + ELSE +#endif ALLOCATE ( INPUTS(IMOD)%CX0(NX,NY) , & INPUTS(IMOD)%CY0(NX,NY) , & INPUTS(IMOD)%CXN(NX,NY) , & INPUTS(IMOD)%CYN(NX,NY) , STAT=ISTAT ) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif CHECK_ALLOC_STATUS ( ISTAT ) END IF ! -!/TIDE IF ( FLLEVTIDE ) THEN -!/TIDE ALLOCATE ( INPUTS(IMOD)%WLTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) -!/TIDE CHECK_ALLOC_STATUS ( ISTAT ) -!/TIDE END IF -!/TIDE! -!/TIDE IF ( FLCURTIDE ) THEN -!/TIDE ALLOCATE ( INPUTS(IMOD)%CXTIDE(NX,NY,NTIDE,2), & -!/TIDE INPUTS(IMOD)%CYTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) -!/TIDE CHECK_ALLOC_STATUS ( ISTAT ) -!/TIDE END IF +#ifdef W3_TIDE + IF ( FLLEVTIDE ) THEN + ALLOCATE ( INPUTS(IMOD)%WLTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF +! + IF ( FLCURTIDE ) THEN + ALLOCATE ( INPUTS(IMOD)%CXTIDE(NX,NY,NTIDE,2), & + INPUTS(IMOD)%CYTIDE(NX,NY,NTIDE,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF +#endif ! -!/WRST IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN -!/WRST ALLOCATE ( INPUTS(IMOD)%WXNwrst(NX,NY) , & -!/WRST INPUTS(IMOD)%WYNwrst(NX,NY) , STAT=ISTAT ) -!/WRST INPUTS(IMOD)%WRSTIINIT=.TRUE. -!/WRST ENDIF +#ifdef W3_WRST + IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN + ALLOCATE ( INPUTS(IMOD)%WXNwrst(NX,NY) , & + INPUTS(IMOD)%WYNwrst(NX,NY) , STAT=ISTAT ) + INPUTS(IMOD)%WRSTIINIT=.TRUE. + ENDIF +#endif IF ( FLWIND ) THEN -!/SMC IF( FSWND ) THEN -!/SMC ALLOCATE ( INPUTS(IMOD)%WX0(NSEA,1) , & -!/SMC INPUTS(IMOD)%WY0(NSEA,1) , & -!/SMC INPUTS(IMOD)%DT0(NSEA,1) , & -!/SMC INPUTS(IMOD)%WXN(NSEA,1) , & -!/SMC INPUTS(IMOD)%WYN(NSEA,1) , & -!/SMC INPUTS(IMOD)%DTN(NSEA,1) , STAT=ISTAT ) -!/SMC ELSE +#ifdef W3_SMC + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%WX0(NSEA,1) , & + INPUTS(IMOD)%WY0(NSEA,1) , & + INPUTS(IMOD)%DT0(NSEA,1) , & + INPUTS(IMOD)%WXN(NSEA,1) , & + INPUTS(IMOD)%WYN(NSEA,1) , & + INPUTS(IMOD)%DTN(NSEA,1) , STAT=ISTAT ) + ELSE +#endif ALLOCATE ( INPUTS(IMOD)%WX0(NX,NY) , & INPUTS(IMOD)%WY0(NX,NY) , & INPUTS(IMOD)%DT0(NX,NY) , & INPUTS(IMOD)%WXN(NX,NY) , & INPUTS(IMOD)%WYN(NX,NY) , & INPUTS(IMOD)%DTN(NX,NY) , STAT=ISTAT ) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif CHECK_ALLOC_STATUS ( ISTAT ) INPUTS(IMOD)%DT0 = 0. INPUTS(IMOD)%DTN = 0. @@ -592,46 +642,60 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) END IF ! IF ( FLTAUA ) THEN -!/SMC IF( FSWND ) THEN -!/SMC ALLOCATE ( INPUTS(IMOD)%UX0(NSEA,1) , & -!/SMC INPUTS(IMOD)%UY0(NSEA,1) , & -!/SMC INPUTS(IMOD)%UXN(NSEA,1) , & -!/SMC INPUTS(IMOD)%UYN(NSEA,1) , STAT=ISTAT ) -!/SMC ELSE +#ifdef W3_SMC + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%UX0(NSEA,1) , & + INPUTS(IMOD)%UY0(NSEA,1) , & + INPUTS(IMOD)%UXN(NSEA,1) , & + INPUTS(IMOD)%UYN(NSEA,1) , STAT=ISTAT ) + ELSE +#endif ALLOCATE ( INPUTS(IMOD)%UX0(NX,NY) , & INPUTS(IMOD)%UY0(NX,NY) , & INPUTS(IMOD)%UXN(NX,NY) , & INPUTS(IMOD)%UYN(NX,NY) , STAT=ISTAT ) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif CHECK_ALLOC_STATUS ( ISTAT ) END IF ! IF ( FLRHOA ) THEN -!/SMC IF( FSWND ) THEN -!/SMC ALLOCATE ( INPUTS(IMOD)%RH0(NSEA,1) , & -!/SMC INPUTS(IMOD)%RHN(NSEA,1) , STAT=ISTAT ) -!/SMC ELSE +#ifdef W3_SMC + IF( FSWND ) THEN + ALLOCATE ( INPUTS(IMOD)%RH0(NSEA,1) , & + INPUTS(IMOD)%RHN(NSEA,1) , STAT=ISTAT ) + ELSE +#endif ALLOCATE ( INPUTS(IMOD)%RH0(NX,NY) , & INPUTS(IMOD)%RHN(NX,NY) , STAT=ISTAT ) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif CHECK_ALLOC_STATUS ( ISTAT ) END IF ! INPUTS(IMOD)%IINIT = .TRUE. ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETI ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary @@ -642,11 +706,21 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! ! Check inputs for stresses IF(FLTAUA) THEN -!/FLX0 WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " -!/FLX1 WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " -!/FLX2 WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " -!/FLX3 WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " -!/FLX4 WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#ifdef W3_FLX0 + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#endif +#ifdef W3_FLX1 + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#endif +#ifdef W3_FLX2 + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#endif +#ifdef W3_FLX3 + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#endif +#ifdef W3_FLX4 + WRITE (NDSE,*) " *** WARNING W3DIMI : TAUA NOT USED *** " +#endif END IF ! ! Formats @@ -659,10 +733,12 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ' NIDATA = ',I10/) 1003 FORMAT (/' *** ERROR W3DIMI : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3DIMI : MODEL ',I4,' DIM. AT ',2I5,I7) -!/T 9001 FORMAT (' TEST W3DIMI : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DIMI : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DIMI : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DIMI : MODEL ',I4,' DIM. AT ',2I5,I7) + 9001 FORMAT (' TEST W3DIMI : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DIMI : POINTERS RESET') + 9003 FORMAT (' TEST W3DIMI : DIMENSIONS STORED') +#endif !/ !/ End of W3DIMI ----------------------------------------------------- / !/ @@ -727,7 +803,9 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) USE W3GDATMD, ONLY: NAUXGR ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -739,9 +817,13 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3SETI') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETI') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -756,7 +838,9 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model numbers @@ -817,10 +901,12 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) ! FLLEV => INPUTS(IMOD)%INFLAGS1(1) FLCUR => INPUTS(IMOD)%INFLAGS1(2) -!/TIDE FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) -!/TIDE FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) -!/TIDE FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) -!/TIDE FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) +#ifdef W3_TIDE + FLLEVTIDE => INPUTS(IMOD)%INFLAGS1(11) + FLCURTIDE => INPUTS(IMOD)%INFLAGS1(12) + FLLEVRESI => INPUTS(IMOD)%INFLAGS1(13) + FLCURRESI => INPUTS(IMOD)%INFLAGS1(14) +#endif FLWIND => INPUTS(IMOD)%INFLAGS1(3) FLICE => INPUTS(IMOD)%INFLAGS1(4) @@ -865,16 +951,20 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) CXN => INPUTS(IMOD)%CXN CYN => INPUTS(IMOD)%CYN END IF -!/TIDE IF ( FLLEVTIDE ) THEN -!/TIDE WLTIDE => INPUTS(IMOD)%WLTIDE -!/TIDE END IF -!/TIDE IF ( FLCURTIDE ) THEN -!/TIDE CXTIDE => INPUTS(IMOD)%CXTIDE -!/TIDE CYTIDE => INPUTS(IMOD)%CYTIDE -!/TIDE END IF -! -!/WRST WXNwrst => INPUTS(IMOD)%WXNwrst -!/WRST WYNwrst => INPUTS(IMOD)%WYNwrst +#ifdef W3_TIDE + IF ( FLLEVTIDE ) THEN + WLTIDE => INPUTS(IMOD)%WLTIDE + END IF + IF ( FLCURTIDE ) THEN + CXTIDE => INPUTS(IMOD)%CXTIDE + CYTIDE => INPUTS(IMOD)%CYTIDE + END IF +#endif +! +#ifdef W3_WRST + WXNwrst => INPUTS(IMOD)%WXNwrst + WYNwrst => INPUTS(IMOD)%WYNwrst +#endif IF ( FLWIND ) THEN WX0 => INPUTS(IMOD)%WX0 @@ -915,7 +1005,9 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) ' NAUXGR = ',I10/ & ' NIDATA = ',I10/) ! -!/T 9000 FORMAT (' TEST W3SETI : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST W3SETI : MODEL ',I4,' SELECTED') +#endif !/ !/ End of W3SETI ----------------------------------------------------- / !/ diff --git a/model/ftn/w3igcmmd.ftn b/model/src/w3igcmmd.F90 similarity index 100% rename from model/ftn/w3igcmmd.ftn rename to model/src/w3igcmmd.F90 diff --git a/model/src/w3initmd.F90 b/model/src/w3initmd.F90 new file mode 100644 index 000000000..c2b3d8a5f --- /dev/null +++ b/model/src/w3initmd.F90 @@ -0,0 +1,7047 @@ +#include "w3macros.h" +!/ ------------------------------------------------------------------- / + MODULE W3INITMD +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 22-Mar-2021 | +!/ +-----------------------------------+ +!/ +!/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) +!/ Multiple grid version. +!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) +!/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) +!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) +!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) +!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) +!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) +!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) +!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) +!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) +!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) +!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) +!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) +!/ Add user-defined field data. +!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) +!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) +!/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) +!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) +!/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) +!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to +!/ specify index closure for a grid. ( version 3.14 ) +!/ (T. J. Campbell, NRL) +!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) +!/ Reset UST initialization. +!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) +!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) +!/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) +!/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) +!/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) +!/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) +!/ structure and smaller memory footprint. +!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) +!/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) +!/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) +!/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) +!/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) +!/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) +!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) +!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) +!/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) +!/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) +!/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) +!/ +!/ Copyright 2009-2013 National Weather Service (NWS), +!/ National Oceanic and Atmospheric Administration. All rights +!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ No unauthorized use without permission. +!/ +!/ Note: Changes in version numbers not logged above. +!/ +! 1. Purpose : +! +! 2. Variables and types : +! +! Name Type Scope Description +! ---------------------------------------------------------------- +! CRITOS R.P. Public Critical percentage of resources used +! for output to trigger warning. +! WWVER C*10 Public Model version number. +! SWITCHES C*256 Public switches taken from bin/switch +! ---------------------------------------------------------------- +! +! 3. Subroutines and functions : +! +! Name Type Scope Description +! ---------------------------------------------------------------- +! W3INIT Subr. Public Wave model initialization. +! W3MPII Subr. Public Initialize MPI data transpose. +! W3MPIO Subr. Public Initialize MPI output gathering. +! W3MPIP Subr. Public Initialize MPI point output gathering. +! ---------------------------------------------------------------- +! +! 4. Subroutines and functions used : +! +! See subroutine documentation. +! +! 5. Remarks : +! +! 6. Switches : +! +! !/SHRD Switch for shared / distributed memory architecture. +! !/DIST Id. +! !/MPI Id. +! +! !/S Enable subroutine tracing. +! !/Tn Enable test output. +! !/MPIT Enable test output (MPI). +! +! 7. Source code : +! +!/ ------------------------------------------------------------------- / + PUBLIC +!/ + REAL, PARAMETER :: CRITOS = 15. + CHARACTER(LEN=10), PARAMETER :: WWVER = '7.13 ' + CHARACTER(LEN=512), PARAMETER :: SWITCHES = & + __WW3_SWITCHES__ +!/ + CONTAINS +!/ ------------------------------------------------------------------- / + SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & + , FLGRD, & + FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & + IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) + +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 03-Sep-2012 | +!/ +-----------------------------------+ +!/ +!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Major changes to logistics. +!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) +!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) +!/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) +!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) +!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) +!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) +!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ Taken out of W3WAVE. +!/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) +!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) +!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) +!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) +!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) +!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) +!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) +!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) +!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 +!/ 13-Sep-2009 : Add coupling option ( version 3.14 ) +!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) +!/ (A. Roland and F. Ardhuin) +!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to +!/ specify index closure for a grid. ( version 3.14 ) +!/ (T. J. Campbell, NRL) +!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) +!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) +!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) +!/ +! 1. Purpose : +! +! Initialize WAVEWATCH III. +! +! 2. Method : +! +! Initialize data structure and wave fields from data files. +! Initialize grid from local and instantaneous data. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! IMOD Int. I Model number. +! FEXT Char I Extension of data files. +! MDS I.A. I Array with dataset numbers (see below), +! saved as NDS in W3ODATMD. +! 1: General output unit number ("log file"). +! 2: Error output unit number. +! 3: Test output unit number. +! 4: "screen", i.e., direct output location, +! can be the screen or the output file of +! the shell. +! 5: Model definition file unit number. +! 6: Restart file unit number. +! 7: Grid output file unit number. +! 8: Point output file unit number. +! 9: Input boundary data file unit number. +! 10: Output boundary data file unit number +! (first). +! 11: Track information file unit number. +! 12: Track output file unit number. +! MTRACE I.A. I Array with subroutine tracing information. +! 1: Output unit number for trace. +! 2: Maximum number of trace prints. +! ODAT I.A. I Output data, five parameters per output type +! 1-5 Data for OTYPE = 1; gridded fields. +! 1 YYYMMDD for first output. +! 2 HHMMSS for first output. +! 3 Output interval in seconds. +! 4 YYYMMDD for last output. +! 5 HHMMSS for last output. +! 6-10 Id. for OTYPE = 2; point output. +! 11-15 Id. for OTYPE = 3; track point output. +! 16-20 Id. for OTYPE = 4; restart files. +! 21-25 Id. for OTYPE = 5; boundary data. +! 31-35 Id. for OTYPE = 7; coupling data. +! 36-40 Id. for OTYPE = 8; second restart file +! FLGRD L.A. I Flags for gridded output. +! FLGR2 L.A. I Flags for coupling output. +! NPT Int. I Number of output points +! X/YPT R.A. I Coordinates of output points. +! PNAMES C.A. I Output point names. +! IPRT I.A. I Partitioning grid info. +! PRTFRM I.A. I Partitioning format flag. +! MPI_COMM Int. I MPI communicator to be used for model. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3SETG Subr. W3GDATMD Point to data structure. +! W3SETW Subr. W3WDATMD Point to data structure. +! W3DIMW Subr. Id. Set array sizes in data structure. +! W3SETA Subr. W3ADATMD Point to data structure. +! W3DIMA Subr. Id. Set array sizes in data structure. +! W3SETI Subr. W3IDATMD Point to data structure. +! W3DIMI Subr. Id. Set array sizes in data structure. +! W3SETO Subr. W3ODATMD Point to data structure. +! W3DMO5 Subr. Id. Set array sizes in data structure. +! ITRACE Subr. W3SERVMD Subroutine tracing initialization. +! STRACE Subr. Id. Subroutine tracing. +! EXTCDE Subr. Id. Program abort. +! WWDATE Subr. Id. System date. +! WWTIME Subr. Id. System time. +! DSEC21 Func. W3TIMEMD Compute time difference. +! TICK21 Func. Id. Advance the clock. +! STME21 Func. Id. Print the time readable. +! PRTBLK Func. W3ARRYMD Print plot of array. +! W3IOGR Subr. W3IOGRMD Read/write model definition file. +! W3IORS Subr. W3IORSMD Read/write restart file. +! W3IOPP Subr. W3IOPOMD Preprocess point output. +! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK +! Subr. mpif.h Standard MPI routines. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Any program shell or integrated model which uses WAVEWATCH III. +! +! 6. Error messages : +! +! On opening of log file only. Other error messages are generated +! by W3IOGR and W3IORS. +! +! 7. Remarks : +! +! - The log file is called 'log.FEXT', where FEXT is passed to +! the routine. +! - The test output file is called 'test.FEXT' in shared memory +! version or testNNN.FEXT in distributed memory version. +! - A water level and ice coverage are transferred with the +! restart file. To assure consistency within the model, the +! water level and ice coverage are re-evaluated at the 0th +! time step in the actual wave model routine. +! - When running regtests in cases where disk is non-local +! (i.e. NFS used), there can be a huge improvment in compute +! time by using /var/tmp/ for log files. +! See commented line at "OPEN (MDS(1),FILE=..." +! +! 8. Structure : +! +! ---------------------------------------------------- +! 1. Set-up of idata structures and I/O. +! a Point to proper data structures. +! b Number of processors and processor number. +! c Open files. +! d Dataset unit numbers +! e Subroutine tracing +! f Initial and test outputs +! 2. Model definition. +! a Read model definition file ( W3IOGR ) +! b Save MAPSTA. +! c MPP preparation +! 3. Model initialization. +! a Read restart file. ( W3IORS ) +! b Compare grid and restart MAPSTA. +! c Initialize with winds if requested (set flag). +! d Initialize calm conditions if requested. +! e Preparations for prop. scheme. +! 4. Set-up output times. +! a Unpack ODAT. +! b Check if output available. +! c Get first time per output and overall. +! d Prepare point output ( W3IOPP ) +! 5. Define wavenumber grid. +! a Calculate depth. +! b Fill wavenumber and group velocity arrays. +! 6. Initialize arrays. +! 7. Write info to log file. +! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) +! ---------------------------------------------------- +! +! 9. Switches : +! +! !/SHRD Switch for shared / distributed memory architecture. +! !/DIST Id. +! !/MPI Id. +! +! !/S Enable subroutine tracing. +! !/Tn Enable test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / + USE CONSTANTS +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +!/ + USE W3GDATMD, ONLY: W3SETG, RSTYPE + USE W3WDATMD, ONLY: W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3DIMA +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif + USE W3IDATMD, ONLY: W3SETI, W3DIMI + USE W3ODATMD, ONLY: W3SETO, W3DMO5 + USE W3IOGOMD, ONLY: W3FLGRDUPDT + USE W3IOGRMD, ONLY: W3IOGR + USE W3IORSMD, ONLY: W3IORS + USE W3IOPOMD, ONLY: W3IOPP + USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 + USE W3ARRYMD, ONLY: PRTBLK +!/ + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS, & + MAPSF, FLAGLL, & + ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX, & + FLCK, NK, NTH, NSPEC, SIG, GNAME +#ifdef W3_PDLIB + USE W3GDATMD, ONLY : FLCTH +#endif + USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA + USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC, & + NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR, & + NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, & + NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST, & + FLOUT, FLOGRD, FLBPO, NOPTS, PTNME, & + PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI, & + OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN, & + IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE,& + FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 +#ifdef W3_NL5 + USE W3ODATMD, ONLY: TOSNL5 +#endif + USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, & + UA, UD, U10, U10D, AS +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP +#endif + USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& + FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & + FLIC4, FLIC5 + USE W3DISPMD, ONLY: WAVNU1, WAVNU3 + USE W3PARALL, ONLY : AC_tot + USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM +#ifdef W3_PDLIB + USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA + use yowNodepool, only: npa + use yowRankModule, only : rank +#endif + USE W3GDATMD, ONLY: GTYPE, UNGTYPE +#ifdef W3_PDLIB + USE PDLIB_W3PROFSMD, ONLY : PDLIB_MAPSTA_INIT, VA_SETUP_IOBPD + USE PDLIB_W3PROFSMD, ONLY : BLOCK_SOLVER_INIT, PDLIB_STYLE_INIT + use yowDatapool, only: istatus +#endif +#ifdef W3_SETUP + USE W3WAVSET, ONLY : PREPARATION_FD_SCHEME + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3GDATMD, ONLY : DO_CHANGE_WLV +#endif + USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP + USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA +#ifdef W3_TIMINGS + USE W3PARALL, ONLY: PRINT_MY_TIME +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS +#endif +#ifdef W3_DEBUGINIT + USE PDLIB_W3PROFSMD, ONLY: PRINT_WN_STATISTIC +#endif +#endif +#ifdef W3_UOST + USE W3UOSTMD, ONLY: UOST_SETGRID +#endif +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: IMOD, MDS(13), MTRACE(2), & + ODAT(40),NPT, IPRT(6),& + MPI_COMM + LOGICAL, INTENT(IN) :: IsMulti + REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) + LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP),& + FLGR2(NOGRP,NGRPP), FLG2(NOGRP),& + PRTFRM + CHARACTER, INTENT(IN) :: FEXT*(*) + CHARACTER(LEN=40), INTENT(IN) :: PNAMES(NPT) + LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) + INTEGER :: NSEALout, NSEALMout +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + integer :: IRANK, I, ISTAT + INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC, & + NTTARG, IK, IP, ITH, IX, IY, & + J, J0, TOUT(2), TLST(2), ISEA, IS, & + K, I1, I2, JSEA, NTTMAX +#ifdef W3_DIST + INTEGER :: ISTEP, ISP, IW +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI, BGROUP, LGROUP +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: NX0, NXN + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif +#ifdef W3_MPI + INTEGER, ALLOCATABLE :: TMPRNK(:) +#endif + INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) +#ifdef W3_T + INTEGER, SAVE :: NXS = 49 +#endif + REAL :: DTTST, DEPTH, FRACOS + REAL :: FACTOR + REAL :: WLVeff +#ifdef W3_T + REAL, ALLOCATABLE :: XOUT(:,:) +#endif + LOGICAL :: OPENED + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=10) :: STDATE + INTEGER :: ISPROC +#ifdef W3_DIST + CHARACTER(LEN=12) :: FORMAT +#endif + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: LFILE, TFILE +#ifdef W3_PDLIB + INTEGER :: IScal(1), IPROC +#endif +!/ +!/ ------------------------------------------------------------------- / +! +! 1. Set-up of data structures and I/O ----------------------------- / +! 1.a Point to proper data structures. +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 1") + + CALL W3SETO ( IMOD, MDS(2), MDS(3) ) + CALL W3SETG ( IMOD, MDS(2), MDS(3) ) + CALL W3SETW ( IMOD, MDS(2), MDS(3) ) + CALL W3SETA ( IMOD, MDS(2), MDS(3) ) + CALL W3SETI ( IMOD, MDS(2), MDS(3) ) +#ifdef W3_UOST + CALL UOST_SETGRID(IMOD) +#endif +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 2") +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Beginning of W3INIT' + WRITE(740+IAPROC,*) ' FLGR2(10,1)=', FLGR2(10,1) + WRITE(740+IAPROC,*) ' FLGR2(10,2)=', FLGR2(10,2) + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Case 2") +#endif + + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! +! 1.b Number of processors and processor number. +! Overwrite some initializations from W3ODATMD. +! +! ******************************************************* +! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** +! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** +! ******************************************************* +! +#ifdef W3_SHRD + NTPROC = 1 + NAPROC = 1 + IAPROC = 1 + IOSTYP = 1 +#endif +! +#ifdef W3_MPI + MPI_COMM_WAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) + NAPROC = NTPROC + CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 +#endif +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 3") + IF ( IOSTYP .LE. 1 ) THEN +! + NAPFLD = MAX(1,NAPROC-1) + NAPPNT = MAX(1,NAPROC-2) + NAPTRK = MAX(1,NAPROC-5) + NAPRST = NAPROC + NAPBPT = MAX(1,NAPROC-3) + NAPPRT = MAX(1,NAPROC-4) +! + ELSE +! + NAPPNT = NAPROC + IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) + NAPFLD = NAPROC + NAPRST = NAPROC + NAPBPT = NAPROC + NAPTRK = NAPROC + NAPPRT = NAPROC +! + IF ( IOSTYP .EQ. 2 ) THEN + NAPROC = MAX(1,NAPROC-1) + ELSE IF ( IOSTYP .EQ. 3 ) THEN +! +! For field or coupling output +! + IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN + NAPFLD = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT(13).GT.0 ) THEN + NAPTRK = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT(28).GT.0 ) THEN + NAPPRT = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC + IF ( ODAT(18).GT.0 ) NAPRST = NAPROC + IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC + IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & + ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) + END IF + END IF +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 4") + FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) + IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) & + WRITE (NDSE,8002) FRACOS +! +#ifdef W3_MPI + IF ( NAPROC .EQ. NTPROC ) THEN + MPI_COMM_WCMP = MPI_COMM_WAVE + ELSE + CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) + ALLOCATE ( TMPRNK(NAPROC) ) + DO J=1, NAPROC + TMPRNK(J) = J - 1 + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & + MPI_COMM_WCMP, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) + DEALLOCATE ( TMPRNK ) + END IF +#endif +!!!/PDLIB CALL W3SETG(IMOD, NDSE, NDST) +! + LPDLIB = .FALSE. +#ifdef W3_PDLIB + LPDLIB = .TRUE. +#endif + IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'IMPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'EXPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + END IF +! +! 1.c Open files without unpacking MDS ,,, +! + IE = LEN_TRIM(FEXT) + LFILE = 'log.' // FEXT(:IE) + IFL = LEN_TRIM(LFILE) +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 5") +#ifdef W3_SHRD + TFILE = 'test.' // FEXT(:IE) +#endif +#ifdef W3_DIST + IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) + WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & + '(A4,I', IW, '.', IW, ',2A)' + WRITE (TFILE,FORMAT) 'test', & + OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) +#endif + IFT = LEN_TRIM(TFILE) + J = LEN_TRIM(FNMPRE) +! + IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & +#ifdef W3_DEBUGINIT + WRITE(*,*) '1: w3initmd f=', TRIM(FNMPRE(:J)//LFILE(:IFL)) +#endif + OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) +! + IF ( MDS(3).NE.MDS(1) .AND. MDS(3).NE.MDS(4) .AND. TSTOUT ) THEN + INQUIRE (MDS(3),OPENED=OPENED) +#ifdef W3_DEBUGINIT + WRITE(*,*) '2: w3initmd f=', TRIM(FNMPRE(:J)//TFILE(:IFT)) +#endif + IF ( .NOT. OPENED ) OPEN & + (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) + END IF +! +! 1.d Dataset unit numbers +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 6") + NDS = MDS + NDSO = NDS(1) + NDSE = NDS(2) + NDST = NDS(3) + SCREEN = NDS(4) +! +! 1.e Subroutine tracing +! + CALL ITRACE ( MTRACE(1), MTRACE(2) ) +! +! 1.f Initial and test outputs +! +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 7") + + IF ( IAPROC .EQ. NAPLOG ) THEN + CALL WWDATE ( STDATE ) + CALL WWTIME ( STTIME ) + WRITE (NDSO,900) WWVER, STDATE, STTIME + END IF + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_S + CALL STRACE (IENT, 'W3INIT') +#endif +#ifdef W3_T + WRITE(NDST,9000) IMOD, FEXT(:IE) + WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & + NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT + WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN + WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) +#endif +! +! 2. Model defintition ---------------------------------------------- / +! 2.a Read model defintition file +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 8") + CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) +#ifdef W3_PDLIB + IF (GTYPE .ne. UNGTYPE) THEN +#endif +#ifdef W3_SETUP + CALL PREPARATION_FD_SCHEME(IMOD) +#endif +#ifdef W3_PDLIB + ELSE +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Before PDLIB_STYLE_INIT, IMOD=', IMOD +#endif + CALL PDLIB_STYLE_INIT(IMOD) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM + WRITE(740+IAPROC,*) 'After PDLIB_STYLE_INIT' + WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + FLUSH(740+IAPROC) +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After PDLIB_STYLE_INIT") +#endif + +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + WRITE(*,*) 'After PDLIB_STYLE_INIT, IMOD=', IMOD +#endif + CALL SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) + END IF +#endif +! Update of output parameter flags based on mod_def parameters (for 3D arrays) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before W3FLGRDUPDT' + FLUSH(740+IAPROC) +#endif + CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 9") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After W3FLGRDUPDT") +#endif + + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) +! +! 2.b Save MAPSTA +! + ALLOCATE ( MAPTST(NY,NX) ) + MAPTST = MAPSTA + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! +! 2.c MPP preparation +! 2.c.1 Set simple counters and variables +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 10") + CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) + NSEAL=NSEALout + NSEALM=NSEALMout + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2c' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM + WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSPEC=', NSPEC + FLUSH(740+IAPROC) +#endif +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 11") + +#ifdef W3_DIST + IF ( NSEA .LT. NAPROC ) GOTO 820 + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN + IF ( NSPEC .LT. NAPROC ) GOTO 821 + END IF +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before PDLIB related allocations' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After test 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + IF (FSNIMP .or. FSTOTALIMP) THEN +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before BLOCK_SOLVER_INIT' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + CALL BLOCK_SOLVER_INIT() +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After BLOCK_SOLVER_INIT' + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After BLOCK_SOLVER_INIT") +#endif +#ifdef W3_PDLIB + ELSE IF (FSTOTALEXP) THEN +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before AC_tot allocation' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + allocate(AC_tot(NSPEC, npa), stat=istat) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After AC_tot allocation' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ENDIF + END IF +#endif +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2d' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 12") +! +! +! 2.c.2 Allocate arrays +! + IF ( IAPROC .LE. NAPROC ) THEN +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 1' + FLUSH(740+IAPROC) +#endif + CALL W3DIMW ( IMOD, NDSE, NDST ) + ELSE +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 2' + FLUSH(740+IAPROC) +#endif + CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL + WRITE(740+IAPROC,*) ' maxval(UST)=', maxval(UST) + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After W3DIMW") +#endif + CALL W3DIMA ( IMOD, NDSE, NDST ) + CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 13") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After W3DIMI") +#endif + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! 2.c.3 Calculated expected number of prop. calls per processor +! + NTTOT = 0 + DO IK=1, NK + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + NTTOT = NTTOT + NTLOC*NTH + END DO + NTTARG = 1 + (NTTOT-1)/NAPROC + NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) + NTTMAX = NTTARG + 5 +! +! 2.c.4 Initialize IAPPRO +! + IAPPRO = 1 + ALLOCATE ( NT(NSPEC) ) + NT = NTTOT +#ifdef W3_DIST + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN +#endif +! +#ifdef W3_DIST + DO +#endif +! +! 2.c.5 First sweep filling IAPPRO +! +#ifdef W3_DIST + DO IP=1, NAPROC + ISTEP = IP + ISP = 0 + NT(IP) = 0 + DO J=1, 1+NSPEC/NAPROC + ISP = ISP + ISTEP + IF ( MOD(J,2) .EQ. 1 ) THEN + ISTEP = 2*(NAPROC-IP) + 1 + ELSE + ISTEP = 2*IP - 1 + END IF + IF ( ISP .LE. NSPEC ) THEN + IK = 1 + (ISP-1)/NTH + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC + ELSE + IAPPRO(ISP) = -1 + END IF + END IF + END DO + END DO +#endif +! +! 2.c.6 Second sweep filling IAPPRO +! +#ifdef W3_DIST + DO IP=1, NAPROC + IF ( NT(IP) .LT. NTTARG ) THEN + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. -1 ) THEN + IK = 1 + (ISP-1)/NTH + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC + END IF + END IF + END DO + END IF + END DO +#endif +! +! 2.c.7 Check if all served +! +#ifdef W3_DIST + IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN + EXIT + ELSE + NTTARG = NTTARG + 1 + IF ( NTTARG .GE. NTTMAX ) EXIT + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) + END IF +#endif +! +#ifdef W3_DIST + END DO + END IF +#endif +! +!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 14") +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After Case 14") +#endif +! 2.c.8 Test output +! +#ifdef W3_T + WRITE (NDST,9020) + DO IP=1, NAPROC + WRITE (NDST,9021) IP, NT(IP), NTTARG + END DO +#endif +! +#ifdef W3_T + WRITE (NDST,9025) + DO IK=NK, 1, -1 + WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) + IF ( NTH .GT. 24 ) WRITE (NDST,9027) & + (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) + END DO +#endif +! +! 2.c.9 Test if any spectral points are left out +! +#ifdef W3_DIST + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. -1. ) GOTO 829 + END DO + END IF +#endif +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4' + FLUSH(740+IAPROC) +#endif + DEALLOCATE ( NT ) +! +! 3. Model initialization ------------------------------------------- / +! 3.a Read restart file +! + VA(:,:) = 0. +#ifdef W3_DEBUGMPI + CALL TEST_MPI_STATUS("Case 15") +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.0' + WRITE(740+IAPROC,*) ' 1: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call") +#endif +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' After ALL_VA_INTEGRAL_PRINT' + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before W3IORS") +#endif + CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After W3IORS") +#endif +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' 2: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + WRITE(740+IAPROC,*) ' 2: NSEAL=', NSEAL + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call") +#endif +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.1' + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA) + FLUSH(740+IAPROC) +#endif + FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 + IF ( IAPROC .EQ. NAPLOG ) THEN + IF (RSTYPE.EQ.0) THEN + WRITE (NDSO,930) 'cold start (idealized).' + ELSE IF ( RSTYPE .EQ. 1 ) THEN + WRITE (NDSO,930) 'cold start (wind).' + ELSE IF ( RSTYPE .EQ. 4 ) THEN + WRITE (NDSO,930) 'cold start (calm).' + ELSE + WRITE (NDSO,930) 'full restart.' + END IF + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.2' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After restart inits") +#endif + +! +! 3.b Compare MAPSTA from grid and restart +! + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)).EQ.2 .OR. & + ABS(MAPTST(IY,IX)).EQ.2 ) THEN + MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) + END IF + END DO + END DO + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.3' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3") +#endif +#endif +! +! 3.b2 Set MAPSTA associated to PDLIB +! +#ifdef W3_PDLIB + IF (GTYPE .eq. UNGTYPE) THEN + CALL PDLIB_MAPSTA_INIT(IMOD) + END IF +#endif +! +! 3.c Initialization from wind fields +! + FLIWND = RSTYPE.EQ.1 +#ifdef W3_T + IF ( FLIWND ) WRITE (NDST,9030) +#endif +! +! 3.d Initialization with calm conditions +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 5' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5") +#endif +#endif + IF ( RSTYPE .EQ. 4 ) THEN + VA(:,:) = 0. +#ifdef W3_T + WRITE (NDST,9031) +#endif + END IF + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! 3.e Prepare propagation scheme +! + IF ( .NOT. FLCUR ) FLCK = .FALSE. +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT definition of FSREFR and FRFREQ' + WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'Before FLCTH=', FLCTH, 'FLCK=', FLCK +#endif + IF (FSTOTALIMP .and. FSREFRACTION) THEN + FLCTH = .FALSE. + END IF + IF (FSTOTALIMP .and. FSFREQSHIFT) THEN + FLCK = .FALSE. + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' After FLCTH=', FLCTH, 'FLCK=', FLCK +#endif +#endif +! +! 4. Set-up output times -------------------------------------------- * +! 4.a Unpack ODAT +! + DO J=1, NOTYPE + J0 = (J-1)*5 + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + END DO +! +! J=8, second stream of restart files + J=8 + J0 = (J-1)*5 + IF(ODAT(J0+1) .NE. 0) THEN + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + FLOUT(8) = .TRUE. + ELSE + FLOUT(8) = .FALSE. + END IF +! +! 4.b Check if output available +! + FLOUT(1) = .FALSE. + FLOGRD = FLGRD + FLOGD = FLGD + DO J=1, NOGRP + DO K=1, NGRPP + FLOUT(1) = FLOUT(1) .OR. FLOGRD(J,K) + END DO + END DO +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 6' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6") +#endif +#endif +! + FLOUT(7) = .FALSE. + FLOGR2 = FLGR2 + FLOG2 = FLG2 + DO J=1, NOGRP + DO K=1, NGRPP + FLOUT(7) = FLOUT(7) .OR. FLOGR2(J,K) + END DO + END DO +! + FLOUT(2) = NPT .GT. 0 +! + FLOUT(3) = .TRUE. +! + FLOUT(4) = .TRUE. +! + FLOUT(5) = FLBPO + IF ( FLBPO ) THEN + CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) + ELSE + DTOUT(5) = 0. + END IF +! + IX0 = MAX ( 1, IPRT(1) ) + IXN = MIN ( NX, IPRT(2) ) + IXS = MAX ( 1, IPRT(3) ) + IY0 = MAX ( 1, IPRT(4) ) + IYN = MIN ( NY, IPRT(5) ) + IYS = MAX ( 1, IPRT(6) ) + FLFORM = PRTFRM + FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN +! +! 4.c Get first time per output and overall. +! + TOFRST(1) = -1 + TOFRST(2) = 0 +! +! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' +! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 7' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7") +#endif +#endif +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Starting the NOTYPE loop, takes time' +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before NOTYPE loop") +#endif + DO J=1, NOTYPE +! +! ... check time step +! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) +! +! ... get first time +! + IF ( FLOUT(J) ) THEN +#ifdef W3_NL5 + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) +#endif + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) +! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT + END IF + END DO +! +! ... reset first time +! + TONEXT(:,J) = TOUT +! +! ... check last time +! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. +! +! ... check overall first time +! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF +! + END IF +! + END DO +! +! J=8, second stream of restart files +! + J=8 +! +! ... check time step +! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) +! +! ... get first time +! + IF ( FLOUT(J) ) THEN + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) +! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT + END IF + END DO +! +! ... reset first time +! + TONEXT(:,J) = TOUT +! +! ... check last time +! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. +! +! ... check overall first time +! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF +! + END IF +! END J=8 +! +! +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Ending the NOTYPE loop, takes time' +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After NOTYPE loop") +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 8' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1") +#endif +#endif +! +! 4.d Preprocessing for point output. +! + IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) +! +#ifdef W3_T + WRITE (NDST,9040) + DO J=1, 5 + WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) + END DO + WRITE (NDST,9042) + WRITE (NDST,9043) TOFRST +#endif +! +! 5. Define wavenumber grid ----------------------------------------- * +! 5.a Calculate depth +! +#ifdef W3_T + ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) + XOUT = -1. +#endif +! + MAPTST = MOD(MAPST2/2,2) + MAPST2 = MAPST2 - 2*MAPTST +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before INIT_GET_JSEA_ISPROC call' + WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + FLUSH(740+IAPROC) +#endif +#endif + +! +!Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops +!Li may miss the refined cells as they are not 1-1 corresponding to +!Li the (Nx,NY) regular grid. The loop is now modified to run over +!Li full NSEA points. JGLi24Jan2012 +!Li DO IY=1, NY +!Li DO IX=1, NX +!Li ISEA = MAPFS(IY,IX) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Debugging the SETUP / WLV' +#endif + DO ISEA=1, NSEA +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'ISEA/WLV/ZB=', ISEA, WLV(ISEA), ZB(ISEA) +#endif + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) +#ifdef W3_T + MAPOUT(IX,IY) = MAPSTA(IY,IX) +#endif +!Li IF ( ISEA .NE. 0) THEN + WLVeff=WLV(ISEA) +#ifdef W3_SETUP + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF +#endif + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) +#ifdef W3_T + XOUT(IX,IY) = DW(ISEA) +#endif + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN + MAPTST(IY,IX) = 1 + MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) +!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA +!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL +!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC +!!/DEBUGINIT FLUSH(740+IAPROC) + END IF +!Li END IF + END DO +!Li END DO + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + WLVeff=WLV(ISEA) +#ifdef W3_SETUP + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF +#endif + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN +!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA +!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL +!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC +!!/DEBUGINIT FLUSH(740+IAPROC) + VA(:,JSEA) = 0. + END IF + END DO +#ifdef W3_DEBUGSTP + FLUSH(740+IAPROC) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2") +#endif +#endif + +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.1' + WRITE(740+IAPROC,*) ' allocated(MAPTST)=', allocated(MAPTST) + WRITE(740+IAPROC,*) 'NY=', NY, ' NX=', NX + FLUSH(740+IAPROC) +#endif + MAPST2 = MAPST2 + 2*MAPTST +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.2' + FLUSH(740+IAPROC) +#endif +! + DEALLOCATE ( MAPTST ) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.3' + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_T + WRITE (NDST,9050) + NX0 = 1 + DO + NXN = MIN ( NX0+NXS-1 , NX ) + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') + IF ( NXN .NE. NX ) THEN + NX0 = NX0 + NXS + ELSE + EXIT + END IF + END DO + DEALLOCATE ( MAPOUT, XOUT ) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before section 5.b") +#endif +! +! 5.b Fill wavenumber and group velocity arrays. +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.5' + FLUSH(740+IAPROC) +#endif + DO IS=0, NSEA +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'IS=', IS + FLUSH(740+IAPROC) +#endif + IF (IS.GT.0) THEN + DEPTH = MAX ( DMIN , DW(IS) ) + ELSE + DEPTH = DMIN + END IF +! +#ifdef W3_T1 + WRITE (NDST,9051) IS, DEPTH +#endif +! + DO IK=0, NK+1 +! +! Calculate wavenumbers and group velocities. + CALL WAVNU1(SIG(IK),DEPTH,WN(IK,IS),CG(IK,IS)) +! +#ifdef W3_T1 + WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) +#endif +! + END DO + END DO +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.6' + FLUSH(740+IAPROC) +#endif +! +! Commented by FA with version 4.12 +! DO IK=1, NK +! CG(IK,0) = CG(IK,1) +! WN(IK,0) = WN(IK,1) +! END DO +! +! 6. Initialize arrays ---------------------------------------------- / +! Some initialized in W3IORS +! + UA = 0. + UD = 0. + U10 = 0. + U10D = 0. +! + AS = UNDEF +! + AS (0) = 0. + DW (0) = 0. +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.7' + FLUSH(740+IAPROC) +#endif +! +! 7. Write info to log file ----------------------------------------- / +! + IF ( IAPROC .EQ. NAPLOG ) THEN +! + WRITE (NDSO,970) GNAME + IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' + IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' + IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' + IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' + IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' + IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' + IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' + IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' + IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' + IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' + IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' + IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' +! + IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' + IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' + IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' + IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' + IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' + IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' + + IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' + IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' + IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' + IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' + IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' + IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' + IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' + IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' + IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' + IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' + + IF ( FLOUT(1) ) THEN + WRITE (NDSO,975) + DO J=1,NOGRP + DO K=1,NGRPP + IF ( FLOGRD(J,K) ) WRITE (NDSO,976) IDOUT(J,K) + END DO + END DO + END IF +! + IF ( FLOUT(7) ) THEN + WRITE (NDSO,987) + DO J=1,NOGRP + DO K=1,NGRPP + IF ( FLOGR2(J,K) ) WRITE (NDSO,976) IDOUT(J,K) + END DO + END DO + END IF +! + IF ( FLOUT(2) ) THEN + WRITE (NDSO,977) NOPTS + IF ( NOPTS .EQ. 0 ) THEN + WRITE (NDSO,978) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSO,979) + ELSE + WRITE (NDSO,985) + END IF + DO IP=1, NOPTS + IF ( FLAGLL ) THEN + WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) + ELSE + WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) + END IF + END DO + END IF + END IF +! + CALL STME21 ( TIME , DTME21 ) + WRITE (NDSO,981) DTME21 + IF (FLLEV) THEN + CALL STME21 ( TLEV , DTME21 ) + WRITE (NDSO,982) DTME21 + END IF + IF (FLICE) THEN + CALL STME21 ( TICE , DTME21 ) + WRITE (NDSO,983) DTME21 + END IF + IF (FLRHOA) THEN + CALL STME21 ( TRHO , DTME21 ) + WRITE (NDSO,990) DTME21 + END IF +! + WRITE (NDSO,984) +! + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.8' + FLUSH(740+IAPROC) +#endif +! + IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. + +#ifdef W3_MEMCHECK + WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.9' + FLUSH(740+IAPROC) +#endif +! +! Boundary set up for the directions +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3") +#endif +#endif +!!/PDLIB CALL VA_SETUP_IOBPD +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.4") +#endif +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.10' + FLUSH(740+IAPROC) +#endif +! +! 8. Final MPI set up ----------------------------------------------- / +! +#ifdef W3_MPI + CALL W3MPII ( IMOD ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After W3MPII' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL W3MPIO ( IMOD ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After W3MPIO' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After W3MPIP' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + CALL PRINT_WN_STATISTIC("W3INIT leaving") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Leaving W3INIT") +#endif + RETURN +! +! Escape locations read errors : +! +#ifdef W3_DIST + 820 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC + CALL EXTCDE ( 820 ) +#endif +! +#ifdef W3_DIST + 821 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC + CALL EXTCDE ( 821 ) +#endif +! +#ifdef W3_DIST + 829 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) + CALL EXTCDE ( 829 ) +#endif + +! + 888 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR + CALL EXTCDE ( 1 ) +! + 889 CONTINUE +! === no process number filtering for test file !!! === + WRITE (NDSE,8001) IERR + CALL EXTCDE ( 2 ) +! +! Formats +! + 900 FORMAT ( ' WAVEWATCH III log file ', & + ' version ',A/ & + ' ==================================', & + '==================================='/ & + 50X,'date : ',A10/50X,'time : ',A8) + 920 FORMAT (/' Model definition file read.') + 930 FORMAT ( ' Restart file read; ',A) +! + 970 FORMAT (/' Grid name : ',A) + 971 FORMAT (/' ',A,' water levels.') + 972 FORMAT ( ' ',A,' curents.') + 973 FORMAT ( ' ',A,' winds.') + 974 FORMAT ( ' ',A,' ice fields.') + 988 FORMAT ( ' ',A,' momentum') + 989 FORMAT ( ' ',A,' air density') + 9972 FORMAT( ' ',A,' mud density.') + 9971 FORMAT( ' ',A,' mud thickness.') + 9970 FORMAT( ' ',A,' mud viscosity.') + 9973 FORMAT( ' ',A,' ice parameter 1') + 9974 FORMAT( ' ',A,' ice parameter 2') + 9975 FORMAT( ' ',A,' ice parameter 3') + 9976 FORMAT( ' ',A,' ice parameter 4') + 9977 FORMAT( ' ',A,' ice parameter 5') + +! + 975 FORMAT (/' Gridded output fields : '/ & + '--------------------------------------------------') + 976 FORMAT ( ' ',A) +! + 977 FORMAT (/' Point output requested for',I6,' points : '/ & + '------------------------------------------') + 978 FORMAT (/' Point output disabled') + 979 FORMAT & + (/' point | longitude | latitude | name '/ & + ' --------|-------------|-------------|----------------') + 985 FORMAT & + (/' point | X | Y | name '/ & + ' --------|-------------|-------------|----------------') + 980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) + 986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) +! + 981 FORMAT (/' Initial time : ',A) + 982 FORMAT ( ' Water level time : ',A) + 983 FORMAT ( ' Ice field time : ',A) + 990 FORMAT ( ' Air density time : ',A) +! + 984 FORMAT (// & + 37X,' | input | output |'/ & + 37X,' |-----------------------|---------------|'/ & + 2X,' step | pass | date time |', & + ' b w l c t r i i1 i5 d | g p t r b f c |'/ & + 2X,'--------|------|---------------------|', & + '-------------------|---------------|'/ & + 2X,'--------+------+---------------------+', & + '-------------------+---------------+') + 987 FORMAT (/' Coupling output fields : '/ & + '--------------------------------------------------') +! + 8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING LOG FILE'/ & + ' IOSTAT =',I5/) + 8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING TEST FILE'/ & + ' IOSTAT =',I5/) + 8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & + ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & + ' OUTPUT :',F6.1,'%'/) +#ifdef W3_DIST + 8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSEA, NAPROC =',2I8/) + 8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSPEC, NAPROC =',2I8/) + 8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & + ' INCREASING TARGET IN MPP PROPAGATION MAP.'/ & + ' IMBALANCE BETWEEN OVERALL AND CFL TIME STEPS'/) + 8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' SOMETHING WRONG WITH MPP PROPAGATION MAP.'/ & + ' CALL HENDRIK !!!'/) +#endif +! +#ifdef W3_T + 9000 FORMAT ( 'TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') + 9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & + ' ASSIGNED PROCESSORS ',9I4) + 9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) + 9003 FORMAT ( ' LOG FILE : [',A,']'/ & + ' TEST FILE : [',A,']') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3INIT : IP, NTTOT, NTTARG :') + 9021 FORMAT ( ' ',3I8) + 9025 FORMAT (' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') + 9026 FORMAT (4X,I4,2X,24I4) + 9027 FORMAT (10X,24I4) +#endif +! +#ifdef W3_T + 9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & + 'PERFORMED IN W3WAVE') + 9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') + 9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) + 9042 FORMAT (' TEST W3INIT : FIRST TIME :') + 9043 FORMAT (' ',I9.8,I7.6) +#endif +! +#ifdef W3_T + 9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') +#endif +#ifdef W3_T1 + 9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & + ' IK, T, K, CG :') + 9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif +!/ +!/ End of W3INIT ----------------------------------------------------- / +!/ + END SUBROUTINE W3INIT +!/ ------------------------------------------------------------------- / + SUBROUTINE W3MPII ( IMOD ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 11-May-2007 | +!/ +-----------------------------------+ +!/ +!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ Taken out of W3WAVE. +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) +!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ +! 1. Purpose : +! +! Perform initializations for MPI version of model. +! Data transpose only. +! +! 2. Method : +! +! Some derived data types are defined. All communiction in +! W3GATH, W3SCAT and W3WAVE are initialized so that all +! communication can be performed with single MPI_STARTALL, +! MPI_TESTALL and MPI_WAITALL calls. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! IMOD Int. I Model number. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! STRACE Subr. W3SERVMD Subroutine tracing. +! +! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT +! Subr. mpif.h MPI derived data type routines. +! +! MPI_SEND_INIT, MPI_RECV_INIT +! Subr. mpif.h MPI persistent communication calls. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3INIT Subr. W3INITMD Wave model initialization routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! None. +! +! 7. Remarks : +! +! - Basic MPP set up partially performed in W3INIT. +! - Each processor has to be able to send out individual error +! messages in this routine ! +! - No testing on IMOD, since only called by W3INIT. +! - In version 3.09 STORE was split into a send and receive +! buffer, to avoid/reduce possible conflicts between the FORTRAN +! and MPI standards when a gather is posted in a given buffer +! right after a send is completed. +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/SHRD Switch for shared / distributed memory architecture. +! !/DIST Id. +! !/MPI MPI communication calls. +! +! !/S Subroutine tracing, +! !/T Test output, general. +! !/MPIT Test output, MPI communications details. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +! +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +! + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB +#ifdef W3_MPI + USE W3GDATMD, ONLY: NSPEC + USE W3WDATMD, ONLY: VA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC, & + WW3_SPEC_VEC, IAPPRO, WADATS, & + NRQSG1, IRQSG1, NRQSG2, IRQSG2, & + GSTORE, SSTORE, MPIBUF, BSTAT, & + BISPL, ISPLOC, IBFLOC, NSPLOC +#endif + USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: IMOD +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + INTEGER :: NXXXX +#ifdef W3_MPI + INTEGER :: IERR_MPI, ISP, IH, ITARG, & + IERR1, IERR2, IP +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3MPII') +#endif +! +! 1. Set up derived data types -------------------------------------- / +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif + NXXXX = NSEALM * NAPROC +! +#ifdef W3_MPI + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, & + WW3_FIELD_VEC, IERR_MPI ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, & + WW3_SPEC_VEC, IERR_MPI ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MPI + IF( IAPROC .GT. NAPROC ) THEN + NSPLOC = 0 + NRQSG1 = 0 + NRQSG2 = 0 +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) +#endif +#ifdef W3_MPI + RETURN + END IF +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +! 2. Set up scatters and gathers for W3WAVE ------------------------- / +! ( persistent communication calls ) +! +#ifdef W3_DIST + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN +#endif +#ifdef W3_MPI + NSPLOC = 0 + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. IAPROC ) NSPLOC = NSPLOC + 1 + END DO +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MPI + NRQSG1 = NSPEC - NSPLOC + ALLOCATE ( WADATS(IMOD)%IRQSG1(MAX(1,NRQSG1),2) ) + IRQSG1 => WADATS(IMOD)%IRQSG1 + IH = 0 +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9021) +#endif +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Before VA MPI_SEND/RECV_INIT inits' +#endif +#ifdef W3_MPI + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .NE. IAPROC ) THEN + ITARG = IAPPRO(ISP) - 1 + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & + ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) + CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & + ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9022) IH, ISP, ITARG+1, & + IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 +#endif +#ifdef W3_MPI + END IF + END DO +#endif +#ifdef W3_DEBUGINIT + WRITE(*,*) 'After VA MPI_SEND/RECV_INIT inits' +#endif +#ifdef W3_MPIT + WRITE (NDST,9023) + WRITE (NDST,9020) NRQSG1 +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3MPII, step 1' + FLUSH(740+IAPROC) +#endif +! +! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / +! Also set up buffering of data. +! +#ifdef W3_MPI + NRQSG2 = MAX( 1 , NAPROC-1 ) + ALLOCATE ( WADATS(IMOD)%IRQSG2(NRQSG2*NSPLOC,2), & + WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & + WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) + NRQSG2 = NAPROC - 1 +#endif +! +#ifdef W3_MPI + IRQSG2 => WADATS(IMOD)%IRQSG2 + GSTORE => WADATS(IMOD)%GSTORE + SSTORE => WADATS(IMOD)%SSTORE +#endif +! +#ifdef W3_MPI + IH = 0 + ISPLOC = 0 + IBFLOC = 0 + WADATS(IMOD)%GSTORE = 0. + WADATS(IMOD)%SSTORE = 0. +#endif +! +! 3.a Loop over local spectral components +! +#ifdef W3_MPIT + WRITE (NDST,9031) +#endif +! +#ifdef W3_MPI + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. IAPROC ) THEN +#endif +! +#ifdef W3_MPI + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 +#endif +! +! 3.b Loop over non-local processes +! +#ifdef W3_MPI + DO IP=1, NAPROC + IF ( IP .NE. IAPROC ) THEN +#endif +! +#ifdef W3_MPI + ITARG = IP - 1 + IH = IH + 1 +#endif +! +#ifdef W3_MPI + CALL MPI_RECV_INIT & + ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & + IRQSG2(IH,1), IERR2 ) + CALL MPI_SEND_INIT & + ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & + IRQSG2(IH,2), IERR2 ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & + IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 +#endif +! +! ... End of loops +! +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9033) + WRITE (NDST,9030) NSPLOC, NRQSG2, IH +#endif +! +! 4. Initialize buffer management ----------------------------------- / +! +#ifdef W3_MPI + BSTAT = 0 + BISPL = 0 + ISPLOC = 0 + IBFLOC = 0 +#endif +! +#ifdef W3_DIST + END IF +#endif + RETURN +! +! Format statements +! +#ifdef W3_MPIT + 9010 FORMAT ( ' TEST W3MPII: DATA TYPES DEFINED'/ & + ' WW3_FIELD_VEC : ',I10/ & + ' WW3_SPEC_VEC : ',I10) + 9011 FORMAT ( ' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') +#endif +! +#ifdef W3_MPIT + 9020 FORMAT ( ' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & + ' NRQSG1 : ',I10) + 9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & + ' +------+------+------+--------------+--------------+'/ & + ' | IH | ISP | TARG | SCATTER | GATHER |'/ & + ' | | | | handle err | handle err |'/ & + ' +------+------+------+--------------+--------------+') + 9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) + 9023 FORMAT ( & + ' +------+------+------+--------------+--------------+'/) +#endif +! +#ifdef W3_MPIT + 9030 FORMAT ( ' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & + ' NSPLOC : ',I10/ & + ' NRQSG2 : ',I10/ & + ' TOTAL REQ. : ',I10/) + 9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & + ' +------+------+------+------+--------------+', & + '--------------+'/ & + ' | IH | ISP | TARG | IBFR | GATHER |', & + ' SCATTER |'/ & + ' | | | | | handle err |', & + ' handle err |'/ & + ' +------+------+------+------+--------------+', & + '--------------+') + 9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) + 9033 FORMAT ( ' +------+------+------+------+--------------+', & + '--------------+'/) +#endif +!/ +!/ End of W3MPII ----------------------------------------------------- / +!/ + END SUBROUTINE W3MPII +!/ ------------------------------------------------------------------- / + SUBROUTINE W3MPIO ( IMOD ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 11-Nov-2015 | +!/ +-----------------------------------+ +!/ +!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) +!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ Taken out of W3WAVE. +!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) +!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) +!/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) +!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) +!/ Add user-defined field data. +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) +!/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) +!/ structure and smaller memory footprint. +!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) +!/ 11-Nov-2015 : Added ICEF ( version 5.08 ) +!/ +! 1. Purpose : +! +! Prepare MPI persistent communication needed for WAVEWATCH I/O +! routines. +! +! 2. Method : +! +! Create handles as needed. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! IMOD Int. I Model number. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. +! W3SETA Subr. " Set pointers for output arrays +! STRACE Subr. W3SERVMD Subroutine tracing. +! +! MPI_SEND_INIT, MPI_RECV_INIT +! Subr. mpif.h MPI persistent communication calls. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3INIT Subr. W3INITMD Wave model initialization routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! 7. Remarks : +! +! - The communication as set up in W3MPII uses tags with number +! ranging from 1 through NSPEC. New and unique tags for IO +! related communication are assigned here dynamically. +! - No testing on IMOD, since only called by W3INIT. +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/MPI MPI communication calls. +! +! !/S Enable subroutine tracing. +! !/MPIT Enable test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +! +#ifdef W3_MPI + USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA + USE W3IORSMD, ONLY: OARST +#endif + USE W3SERVMD, ONLY: EXTCDE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +!/ + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM +#ifdef W3_MPI + USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF + USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC + USE W3ADATMD, ONLY: HS, WLM, T02 +#endif + + +#ifdef W3_MPI + USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, FP1, THP1, & + DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& + SXX, SYY, SXY, USERO, PHS, PTP, PLP, & + PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC,& + TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & + TAUOY, USSX, USSY, MSSX, MSSY, MSSD, & + MSCX, MSCY, MSCD, PRMS, TPMS, CHARN, & + TWS, TAUWNX, TAUWNY, BHD, CGE, & + CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & + BEDFORMS, PHIBBL, TAUBBL, T01, & + P2SMS, US3D, EF, TH1M, STH1M, TH2M, & + STH2M, HSIG, PHICE, TAUICE, USSP, & + STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, & + HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW, & + PTM1, PT1, PT2, PEP, WBT, CX, CY, & + TAUOCX, TAUOCY, WNMEAN +#endif + +#ifdef W3_MPI + USE W3GDATMD, ONLY: NK + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT, & + NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& + NOGRP, NGRPP, NOGE, FLOGRR + USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & + FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & + NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & + RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & + IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & + ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & + IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & + FLOGR2 + USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC +#endif + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: IMOD +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ +#ifdef W3_MPI + INTEGER :: IK, IFJ + INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & + IFROM, IX(4), IY(4), IS(4), & + IP(4), I, J, JSEA, ITARG, IB, & + JSEA0, JSEAN, NSEAB, IBOFF, & + ISEA, ISPROC, K, NRQMAX +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_MPI + LOGICAL :: FLGRDALL(NOGRP,NGRPP) + LOGICAL :: FLGRDARST(NOGRP,NGRPP) +#endif +#ifdef W3_MPIT + CHARACTER(LEN=5) :: STRING +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3MPIO') +#endif +! +! 1. Set-up for W3IOGO ---------------------------------------------- / +! +#ifdef W3_MPI + DO J=1, NOGRP + DO K=1, NGRPP + FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) + FLGRDARST(J,K) = (FLGRDALL(J,K) .OR. FLOGRR(J,K)) + END DO + END DO +#endif +! +#ifdef W3_MPI + NRQGO = 0 + NRQGO2 = 0 + IT0 = NSPEC + IROOT = NAPFLD - 1 +#endif +! +! +#ifdef W3_MPI + IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & + (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN +#endif +! +! NRQMAX is the maximum number of output fields that require MPI communication, +! aimed to gather field values stored in each processor into one processor in +! charge of model output; for each of such fields, this routine requires one +! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request +! handles in the vectors IRQGO and IRQGO2 respectively. +! NRQMAX is calculated as the sum of all fields described before (Hs) +! + 2 or 3 component fields (CUR) + 3 component fields + extra fields +! For group 1 fields except ICEF, all processors contain information on all +! grid points because they are input fields, and therefore this MPI +! communication is not necessary and they do not contribute to NRQMAX. +! +#ifdef W3_MPI + ! Calculation of NRQMAX splitted by output groups and field type + ! scalar 2-comp 3-comp + NRQMAX = 1 + 0 + 0 + & ! group 1 + 18 + 0 + 0 + & ! group 2 + 0 + 0 + 0 + & ! group 3 (extra contributions below) + 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 + 11 + 3 + 1 + & ! group 5 + 12 + 7 + 1 + & ! group 6 (extra contributions below) + 5 + 4 + 1 + & ! group 7 + 5 + 2 + 0 + & ! group 8 + 5 + 0 + 0 + & ! group 9 + NOEXTR + 0 + 0 ! group 10 + + ! Extra contributions to NRQMAX from group 3 + DO IFJ=1,5 + IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & + E3DF(3,IFJ) - E3DF(2,IFJ) + 1 + END DO + ! Extra contributions to NRQMAX from group 6 + IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & + P2MSF(3) - P2MSF(2) + 1 + IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK + IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK +#endif +! +#ifdef W3_MPI + IF ( NRQMAX .GT. 0 ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) + END IF + IRQGO => OUTPTS(IMOD)%OUT1%IRQGO + IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 +#endif +! +! 1.a Sends of fields +! +#ifdef W3_MPI + IH = 0 +#endif +! +#ifdef W3_MPI + IF ( IAPROC .LE. NAPROC ) THEN + IT = IT0 +#endif +#ifdef W3_MPIT + WRITE (NDST,9010) '(SEND)' +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 1, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR +#endif +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + NRQGO = IH +#endif +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9013) NRQGO, NRQMAX +#endif +! +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( NRQGO .GT. NRQMAX ) THEN + WRITE (NDSE,1010) NRQGO, NRQMAX + CALL EXTCDE (10) + END IF +#endif +! +#ifdef W3_MPI + IF ( IAPROC .EQ. NAPFLD ) THEN +#endif +! +! 1.b Setting up expanded arrays +! +#ifdef W3_MPI + IF (NAPFLD .EQ. NAPRST) THEN + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) + ELSE + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) + ENDIF +#endif +! +! 1.c Receives of fields +! +#ifdef W3_MPI + CALL W3XETA ( IMOD, NDSE, NDST ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9010) '(RECV)' +#endif +! +#ifdef W3_MPI + IH = 0 +#endif +! +#ifdef W3_MPI + DO I0=1, NAPROC + IT = IT0 + IFROM = I0 - 1 +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 1, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 5,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + DO I=1, NOEXTR + !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR +#endif +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + END DO +#endif +! +#ifdef W3_MPI + NRQGO2 = IH +#endif +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC +#endif +! +#ifdef W3_MPI + CALL W3SETA ( IMOD, NDSE, NDST ) +#endif +! +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN + WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC + CALL EXTCDE (11) + END IF +#endif +! +#ifdef W3_MPI + END IF +#endif +! +! 2. Set-up for W3IORS ---------------------------------------------- / +! 2.a General preparations +! +#ifdef W3_MPI + NRQRS = 0 + IH = 0 + IROOT = NAPRST - 1 +#endif +! +#ifdef W3_MPI + IF ( FLOUT(4) .OR. FLOUT(8) ) THEN + IF (OARST) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) + ENDIF + IRQRS => OUTPTS(IMOD)%OUT4%IRQRS +#endif +! +! 2.b Fields at end of file (always) +! +#ifdef W3_MPIT + WRITE (NDST,9020) +#endif +! +#ifdef W3_MPI + IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR +#endif +! +#ifdef W3_MPI + ELSE IF ( IAPROC .EQ. NAPRST ) THEN + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR +#endif +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF + END DO + END IF +#endif +! +#ifdef W3_MPI + IF (OARST) THEN + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 5 + CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 1, 9) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5, 11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( IAPROC .EQ. NAPRST ) THEN + IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) + CALL W3XETA ( IMOD, NDSE, NDST ) +#endif +! +#ifdef W3_MPI + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IT0 + 5 + IT = IT + 1 + CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 1, 9) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + ENDIF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 5,11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR +#endif +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + CALL W3SETA ( IMOD, NDSE, NDST ) + END IF + END IF +#endif +! +#ifdef W3_MPI + NRQRS = IH + IF (OARST) THEN + IT0 = IT0 + 34 + ELSE + IT0 = IT0 + 3 + ENDIF +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9022) + WRITE (NDST,9023) NRQRS +#endif +! +! 2.c Data server mode +! +#ifdef W3_MPI + IF ( IOSTYP .GT. 0 ) THEN +#endif +! +#ifdef W3_MPI + NBLKRS = 10 + RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) + IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 + NBLKRS = 1 + (NSEALM-1)/RSBLKS +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9025) RSBLKS, NBLKRS +#endif +#ifdef W3_MPI + IH = 0 +#endif +! +#ifdef W3_MPI + IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN + IF ( IAPROC .NE. NAPRST ) THEN +#endif +! +#ifdef W3_MPI + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS +#endif +! +#ifdef W3_MPI + DO IB=1, NBLKRS + IH = IH + 1 + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& + MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & + IRQRSS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & + IRQRSS(IH), IERR, NSEAB +#endif +#ifdef W3_MPI + END DO +#endif +! +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPI + ALLOCATE & + ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & + OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) +#endif +! +#ifdef W3_MPI + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + VAAUX => OUTPTS(IMOD)%OUT4%VAAUX + DO IB=1, NBLKRS + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + DO I0=1, NAPROC + IF ( I0 .NE. NAPRST ) THEN + IH = IH + 1 + IFROM = I0 - 1 + IBOFF = MOD(IB-1,2)*RSBLKS + CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& + NSPEC*NSEAB, MPI_REAL, IFROM, IT, & + MPI_COMM_WAVE, IRQRSS(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9026) IH, 'R', IB, IFROM, & + IT, IRQRSS(IH), IERR, NSEAB +#endif +#ifdef W3_MPI + END IF + END DO + END DO +#endif +! +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9027) + WRITE (NDST,9028) IH +#endif +#ifdef W3_MPI + IT0 = IT0 + NBLKRS +#endif +! +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + END IF +#endif +! +! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / +! +#ifdef W3_MPI + NRQBP = 0 + NRQBP2 = 0 + IH = 0 + IT = IT0 + IROOT = NAPBPT - 1 +#endif +! +#ifdef W3_MPI + IF ( FLOUT(5) ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & + OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) + IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 + IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 +#endif +! +! 3.a Loops over files and points +! +#ifdef W3_MPIT + WRITE (NDST,9030) 'MPI_SEND_INIT' +#endif +! +#ifdef W3_MPI + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) +#endif +! +#ifdef W3_MPI + IT = IT + 1 +#endif +! +! 3.b Residence processor of point +! +#ifdef W3_MPI + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) +#endif +! +! 3.c If stored locally, send data +! +#ifdef W3_MPI + IF ( IAPROC .EQ. ISPROC ) THEN + IH = IH + 1 + CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + END DO + END DO +#endif +! +! ... End of loops 4.a +! +#ifdef W3_MPI + NRQBP = IH +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9032) + WRITE (NDST,9033) NRQBP +#endif +! +! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / +! +#ifdef W3_MPI + IF ( IAPROC .EQ. NAPBPT ) THEN +#endif +! +#ifdef W3_MPI + IH = 0 + IT = IT0 +#endif +! +! 3.e Loops over files and points +! +#ifdef W3_MPIT + WRITE (NDST,9030) 'MPI_RECV_INIT' +#endif +! +#ifdef W3_MPI + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) +#endif +! +! 3.f Residence processor of point +! +#ifdef W3_MPI + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) +#endif +! +! 3.g Receive in correct array +! +#ifdef W3_MPI + IH = IH + 1 + IT = IT + 1 + ITARG = ISPROC - 1 + CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& + ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR +#endif +! +#ifdef W3_MPI + END DO + END DO +#endif +! +#ifdef W3_MPI + NRQBP2 = IH +#endif +! +! ... End of loops 4.e +! +#ifdef W3_MPIT + WRITE (NDST,9032) + WRITE (NDST,9033) NRQBP2 +#endif +! +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IT0 = IT0 + NBO2(NFBPO) +#endif +! +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPIT + WRITE (NDST,*) +#endif +! +! 4. Set-up for W3IOTR ---------------------------------------------- / +! +#ifdef W3_MPI + IH = 0 + IROOT = NAPTRK - 1 +#endif +! +#ifdef W3_MPI + IF ( FLOUT(3) ) THEN +#endif +! +! 4.a U* +! +#ifdef W3_MPIT + WRITE (NDST,9040) +#endif +! +#ifdef W3_MPI + IF ( IAPROC .NE. NAPTRK ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR +#endif +#ifdef W3_MPI + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR +#endif +#ifdef W3_MPI + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) +#endif +#ifdef W3_MPIT + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR +#endif +#ifdef W3_MPI + END IF + END DO + END IF +#endif +! +#ifdef W3_MPI + NRQTR = IH + IT0 = IT0 + 2 +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9042) + WRITE (NDST,9043) NRQTR +#endif +! +#ifdef W3_MPI + END IF +#endif +! +! 5. Set-up remaining counters -------------------------------------- / +! +#ifdef W3_MPI + IT0PRT = IT0 + IT0PNT = IT0PRT + 2*NAPROC + IT0TRK = IT0PNT + 5000 +#endif +! + RETURN +! +! Formats : +! +#ifdef W3_MPI + 1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) + 1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) +#endif +! +#ifdef W3_MPIT + 9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & + ' +------+-------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+-------+------+------+--------------+') + 9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') + 9012 FORMAT ( ' +------+-------+------+------+--------------+') + 9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) + 9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) +#endif +! +#ifdef W3_MPIT + 9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') + 9022 FORMAT ( ' +------+------+------+------+--------------+') + 9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) +#endif +! +#ifdef W3_MPIT + 9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & + ' BLOCK SIZE / BLOCKS : ',2I6/ & + ' +------+------+------+------+--------------+---------+'/ & + ' | IH | ID | TARG | TAG | handle err | spectra |'/ & + ' +------+------+------+------+--------------+---------+') + 9026 FORMAT ( & + ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') + 9027 FORMAT ( & + ' +------+------+------+------+--------------+---------+') + 9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) +#endif +! +#ifdef W3_MPIT + 9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & + ' +------+------+---+------+------+--------------+'/ & + ' | IH | IPT | F | TARG | TAG | handle err |'/ & + ' +------+------+---+------+------+--------------+') + 9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') + 9032 FORMAT ( & + ' +------+------+---+------+------+--------------+') + 9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) + 9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) +#endif +! +#ifdef W3_MPIT + 9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') + 9042 FORMAT ( & + ' +------+------+------+------+--------------+') + 9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) +#endif +!/ +!/ End of W3MPIO ----------------------------------------------------- / +!/ + END SUBROUTINE W3MPIO +!/ ------------------------------------------------------------------- / + SUBROUTINE W3MPIP ( IMOD ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 30-Oct-2009 | +!/ +-----------------------------------+ +!/ +!/ 02-Aug-2006 : Origination. ( version 3.10 ) +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ +! 1. Purpose : +! +! Prepare MPI persistent communication needed for WAVEWATCH I/O +! routines. +! +! 2. Method : +! +! Create handles as needed. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! IMOD Int. I Model number. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! STRACE Subr. W3SERVMD Subroutine tracing. +! +! MPI_SEND_INIT, MPI_RECV_INIT +! Subr. mpif.h MPI persistent communication calls. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3INIT Subr. W3INITMD Wave model initialization routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! 7. Remarks : +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/MPI MPI communication calls. +! +! !/S Enable subroutine tracing. +! !/MPIT Enable test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPI + USE W3SERVMD, ONLY: EXTCDE +#endif +!/ +#ifdef W3_MPI + USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS + USE W3WDATMD, ONLY: VA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT + USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT + USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2, & + NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC +#endif +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: IMOD +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ +#ifdef W3_MPI + INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA, & + IERR, ITARG, IX(4), IY(4), & + K, IS(4), IP(4) +#endif + INTEGER :: itout +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3MPIP') +#endif +! +#ifdef W3_MPI + IF ( O2IRQI ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF +#endif +! +! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / +! +#ifdef W3_MPI + NRQPO = 0 + NRQPO2 = 0 + IH = 0 + IT0 = IT0PNT + IROOT = NAPPNT - 1 +#endif +! +#ifdef W3_MPI + ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & + OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) + IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 + IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 + O2IRQI = .TRUE. +#endif +! +! 1.a Loop over output locations +! +#ifdef W3_MPIT + WRITE (NDST,9010) 'MPI_SEND_INIT' +#endif +! +#ifdef W3_MPI + DO I=1, NOPTS + DO K=1,4 + IX(K)=IPTINT(1,K,I) + IY(K)=IPTINT(2,K,I) + END DO +#endif +! 1.b Loop over corner points +! +#ifdef W3_MPI + DO J=1, 4 +#endif +! +#ifdef W3_MPI + IT = IT0 + (I-1)*4 + J + IS(J) = MAPFS (IY(J),IX(J)) + IF ( IS(J) .EQ. 0 ) THEN + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF +#endif +! +! 1.c Send if point is stored here +! +#ifdef W3_MPI + IF ( IP(J) .EQ. IAPROC ) THEN + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR +#endif +#ifdef W3_MPI + END IF +#endif +! +! ... End of loop 1.b +! +#ifdef W3_MPI + END DO +#endif +! +! ... End of loop 1.a +! +#ifdef W3_MPI + END DO +#endif +! +#ifdef W3_MPI + NRQPO = IH +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9013) NRQPO +#endif +! +! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / +! +#ifdef W3_MPI + IF ( IAPROC .EQ. NAPPNT ) THEN +#endif +! +#ifdef W3_MPI + IH = 0 +#endif +! +! 2.e Loop over output locations +! +#ifdef W3_MPIT + WRITE (NDST,9010) 'MPI_RECV_INIT' +#endif +! +#ifdef W3_MPI + DO I=1, NOPTS + DO K=1,4 + IX(K)=IPTINT(1,K,I) + IY(K)=IPTINT(2,K,I) + END DO +#endif +! +#ifdef W3_MPI + DO J=1, 4 +#endif +! +#ifdef W3_MPI + IT = IT0 + (I-1)*4 + J + IS(J) = MAPFS (IY(J),IX(J)) + IF ( IS(J) .EQ. 0 ) THEN + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF +#endif +! +! 1.g Receive in correct array +! +#ifdef W3_MPI + IH = IH + 1 + ITARG = IP(J) - 1 + CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & + ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR +#endif +! +! ... End of loop 1.f +! +#ifdef W3_MPI + END DO +#endif +! +! ... End of loop 1.e +! +#ifdef W3_MPI + END DO +#endif +! +#ifdef W3_MPI + NRQPO2 = NOPTS*4 +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9012) + WRITE (NDST,9014) NRQPO2 +#endif +! +#ifdef W3_MPI + END IF +#endif +! +! +#ifdef W3_MPI + IT0 = IT0 + 8*NOPTS +#endif +! +! 1.h Base tag number for track output +! +#ifdef W3_MPI + IT0TRK = IT0 +#endif +! + RETURN +! +! Formats : +! +#ifdef W3_MPI + 1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) +#endif +! +#ifdef W3_MPIT + 9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & + ' +------+------+---+------+------+--------------+'/ & + ' | IH | IPT | J | TARG | TAG | handle err |'/ & + ' +------+------+---+------+------+--------------+') + 9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') + 9012 FORMAT ( & + ' +------+------+---+------+------+--------------+') + 9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) + 9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) +#endif +!/ +!/ End of W3MPIP ----------------------------------------------------- / +!/ + END SUBROUTINE W3MPIP +!/ +!/ End of module W3INITMD -------------------------------------------- / +!/ + END MODULE W3INITMD diff --git a/model/ftn/w3iobcmd.ftn b/model/src/w3iobcmd.F90 similarity index 72% rename from model/ftn/w3iobcmd.ftn rename to model/src/w3iobcmd.F90 index 5fd51957c..87f28499e 100644 --- a/model/ftn/w3iobcmd.ftn +++ b/model/src/w3iobcmd.F90 @@ -191,10 +191,14 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) XFR, FR1, SIG2, TH, DTH, FILEXT, FACHFE, & GTYPE, UNGTYPE, SMCTYPE USE W3GDATMD, ONLY: DXYMAX -!/T1 USE W3GDATMD, ONLY: SIG -!/RTD !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 -!/RTD USE W3GDATMD, ONLY: PoLat, PoLon, AnglD -!/RTD USE W3SERVMD, ONLY: W3LLTOEQ, W3EQTOLL, W3ACTURN +#ifdef W3_T1 + USE W3GDATMD, ONLY: SIG +#endif +#ifdef W3_RTD + !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: PoLat, PoLon, AnglD + USE W3SERVMD, ONLY: W3LLTOEQ, W3EQTOLL, W3ACTURN +#endif USE W3WDATMD, ONLY: VA USE W3ADATMD, ONLY: CG USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPBPT, & @@ -207,9 +211,13 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) USE W3GSRUMD ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/SMC USE W3PSMCMD, ONLY: W3SMCGMP +#ifdef W3_SMC + USE W3PSMCMD, ONLY: W3SMCGMP +#endif ! IMPLICIT NONE !/ @@ -228,14 +236,22 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) !/ INTEGER :: IFILE, IERR, I, J, IX, IY, ISEA, & IP, ISP, NPTS, ISOUT, IS, IGRD -!/T1 INTEGER :: IK, ITH -!/S INTEGER, SAVE :: IENT = 0 -!/T1 REAL :: HS, HS0 -!/RTD !! Declare rotation angle and rotated lat/lon variables for -!/RTD !! boundary points. JGLi12Jun2012 -!/RTD REAL, ALLOCATABLE :: Anglbdy(:), ELatbdy(:), ELonbdy(:) -!/RTD REAL :: Spectr(NK*NTH) -!/RTD REAL :: XRLIM, YRLIM +#ifdef W3_T1 + INTEGER :: IK, ITH +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T1 + REAL :: HS, HS0 +#endif +#ifdef W3_RTD + !! Declare rotation angle and rotated lat/lon variables for + !! boundary points. JGLi12Jun2012 + REAL, ALLOCATABLE :: Anglbdy(:), ELatbdy(:), ELonbdy(:) + REAL :: Spectr(NK*NTH) + REAL :: XRLIM, YRLIM +#endif REAL, ALLOCATABLE :: TMPSPC(:,:) LOGICAL :: FLOK CHARACTER(LEN=18) :: FILEN @@ -244,7 +260,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOBC') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOBC') +#endif ! IOTST = 0 ! @@ -267,7 +285,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) CALL EXTCDE ( 1 ) END IF ! -!/T WRITE (NDST,9000) INXOUT, FILER, FILEW, FILED, NDSB +#ifdef W3_T + WRITE (NDST,9000) INXOUT, FILER, FILEW, FILED, NDSB +#endif ! ! open file ---------------------------------------------------------- * ! @@ -276,7 +296,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ! IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) -!/T WRITE (NDST,9001) FILEN(:5+I), NDSB +#ifdef W3_T + WRITE (NDST,9001) FILEN(:5+I), NDSB +#endif OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),FORM='UNFORMATTED', & ERR=801,IOSTAT=IERR,STATUS='OLD') END IF @@ -286,7 +308,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) NDSL(IFILE) = NDSB + IFILE - 1 WRITE (FILEN,'(A4,I1,A1,A)') 'nest', IFILE, '.', & FILEXT(:I) -!/T WRITE (NDST,9001) FILEN(:6+I), NDSL(IFILE) +#ifdef W3_T + WRITE (NDST,9001) FILEN(:6+I), NDSL(IFILE) +#endif OPEN (NDSL(IFILE),FILE=FNMPRE(:J)//FILEN(:6+I), & FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) END DO @@ -294,7 +318,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ! IF ( INXOUT.EQ.'DUMP' .AND. FILED ) THEN WRITE (FILEN,'(A5,A)') 'nest.', FILEXT(:I) -!/T WRITE (NDST,9001) FILEN(:5+I), NDSB +#ifdef W3_T + WRITE (NDST,9001) FILEN(:5+I), NDSB +#endif OPEN (NDSB,FILE=FNMPRE(:J)//FILEN(:5+I),FORM='UNFORMATTED', & ERR=800,IOSTAT=IERR) END IF @@ -310,24 +336,30 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), & NBO(IFILE)-NBO(IFILE-1) ! -!/T WRITE (NDST,9002) IFILE, NDSL(IFILE), IDSTRBC, & -!/T VERBPTBC, NBO(IFILE)-NBO(IFILE-1) +#ifdef W3_T + WRITE (NDST,9002) IFILE, NDSL(IFILE), IDSTRBC, & + VERBPTBC, NBO(IFILE)-NBO(IFILE-1) +#endif ! -!/RTD ! By running the ww3_grid program the arrays XBPO, YBPO have been -!/RTD ! remapped to standard lat-lon and stored in mod_def.* -!/RTD ! +#ifdef W3_RTD + ! By running the ww3_grid program the arrays XBPO, YBPO have been + ! remapped to standard lat-lon and stored in mod_def.* + ! +#endif WRITE (NDSL(IFILE)) & (XBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & (YBPO(I),I=NBO(IFILE-1)+1,NBO(IFILE)), & ((IPBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4),& ((RDBPO(I,J),I=NBO(IFILE-1)+1,NBO(IFILE)),J=1,4) ! -!/T0 WRITE (NDST,9003) -!/T0 DO I=NBO(IFILE-1)+1, NBO(IFILE) -!/T0 WRITE (NDST,9004) I-NBO(IFILE-1), XBPO(I), & -!/T0 YBPO(I), (IPBPO(I,J),J=1,4), & -!/T0 (RDBPO(I,J),J=1,4) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9003) + DO I=NBO(IFILE-1)+1, NBO(IFILE) + WRITE (NDST,9004) I-NBO(IFILE-1), XBPO(I), & + YBPO(I), (IPBPO(I,J),J=1,4), & + (RDBPO(I,J),J=1,4) + END DO +#endif ! END DO END IF @@ -339,17 +371,21 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) IF ( IAPROC .EQ. NAPBPT ) THEN WRITE (NDSB) IDSTRBC, VERBPTBC, NK, NTH, XFR, FR1, TH(1), NBI ! -!/T WRITE (NDST,9002) 1, NDSB, IDSTRBC, VERBPTBC, NBI +#ifdef W3_T + WRITE (NDST,9002) 1, NDSB, IDSTRBC, VERBPTBC, NBI +#endif ! WRITE (NDSB) (XBPI(I),I=1,NBI), (YBPI(I),I=1,NBI), & ((IPBPI(I,J),I=1,NBI),J=1,4), & ((RDBPI(I,J),I=1,NBI),J=1,4) ! -!/T0 WRITE (NDST,9003) -!/T0 DO I=1, NBI -!/T0 WRITE (NDST,9004) I, XBPI(I), YBPI(I), & -!/T0 (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9003) + DO I=1, NBI + WRITE (NDST,9004) I, XBPI(I), YBPI(I), & + (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) + END DO +#endif ! END IF END IF @@ -361,7 +397,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) READ (NDSB,ERR=803,IOSTAT=IERR) & IDTST, VERTST, NKI, NTHI, XFRI, FR1I, TH1I, NBI ! -!/T WRITE (NDST,9002) 1, NDSB, IDTST, VERTST, NBI +#ifdef W3_T + WRITE (NDST,9002) 1, NDSB, IDTST, VERTST, NBI +#endif ! IF ( IDTST .NE. IDSTRBC ) THEN IF ( IAPROC .EQ. NAPERR ) & @@ -388,50 +426,54 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ((IPBPI(I,J),I=1,NBI),J=1,4), & ((RDBPI(I,J),I=1,NBI),J=1,4) ! -!/RTD ! All boundary conditions position arrays XBPI, YBPI are defined -!/RTD ! in standard lat/lon coordinates. If Polat = 90. (and Polon = -180.), -!/RTD ! the b.c. positions don't need to be remapped -!/RTD IF ( Polat < 90. ) THEN -!/RTD !! Convert standard into rotated lat/lon. JGLi12Jun2012 -!/RTD ALLOCATE ( Anglbdy(NBI), ELatbdy(NBI), ELonbdy(NBI) ) -!/RTD -!/RTD CALL W3LLTOEQ ( YBPI, XBPI, ELatbdy, ELonbdy, & -!/RTD & Anglbdy, PoLat, PoLon, NBI ) -!/RTD -!/RTD XBPI = ELonbdy -!/RTD YBPI = ELatbdy -!/RTD !! W3LLTOEQ outputs longitudes on 0->360 degree grid -!/RTD !! Next section will revise to -180->180 convention if required -!/RTD !! by nested model rotated grid; determined by X0 lon value -!/RTD IF ( X0 .LT. 0.0 ) THEN -!/RTD DO I=1, NBI -!/RTD IF ( XBPI(I) .GT. 180.0) XBPI(I) = XBPI(I) - 360.0 -!/RTD ENDDO -!/RTD END IF -!/RTD !! The old (4.18) W3GFPT was very strict so this loop reassigns RTD -!/RTD !! values to within a tolerance of the boundary - possibly this is -!/RTD !! no longer required after the 20-Jan-2017 change? -!/RTD XRLIM = X0 + (NX-1) * SX -!/RTD YRLIM = Y0 + (NY-1) * SY -!/RTD DO I=1, NBI -!/RTD IF ( ABS(XBPI(I) - X0) .LT. SX/4.0 ) XBPI(I) = X0 -!/RTD IF ( ABS(YBPI(I) - Y0) .LT. SY/4.0 ) YBPI(I) = Y0 -!/RTD IF ( ABS(XBPI(I) - XRLIM) .LT. SX/4.0 ) XBPI(I) = XRLIM -!/RTD IF ( ABS(YBPI(I) - YRLIM) .LT. SY/4.0 ) YBPI(I) = YRLIM -!/RTD ENDDO -!/RTD -!/RTD DEALLOCATE ( Anglbdy, ELatbdy, ELonbdy ) -!/RTD -!/RTD END IF ! ( Polat < 90. ) -!/RTD +#ifdef W3_RTD + ! All boundary conditions position arrays XBPI, YBPI are defined + ! in standard lat/lon coordinates. If Polat = 90. (and Polon = -180.), + ! the b.c. positions don't need to be remapped + IF ( Polat < 90. ) THEN + !! Convert standard into rotated lat/lon. JGLi12Jun2012 + ALLOCATE ( Anglbdy(NBI), ELatbdy(NBI), ELonbdy(NBI) ) + + CALL W3LLTOEQ ( YBPI, XBPI, ELatbdy, ELonbdy, & + & Anglbdy, PoLat, PoLon, NBI ) + + XBPI = ELonbdy + YBPI = ELatbdy + !! W3LLTOEQ outputs longitudes on 0->360 degree grid + !! Next section will revise to -180->180 convention if required + !! by nested model rotated grid; determined by X0 lon value + IF ( X0 .LT. 0.0 ) THEN + DO I=1, NBI + IF ( XBPI(I) .GT. 180.0) XBPI(I) = XBPI(I) - 360.0 + ENDDO + END IF + !! The old (4.18) W3GFPT was very strict so this loop reassigns RTD + !! values to within a tolerance of the boundary - possibly this is + !! no longer required after the 20-Jan-2017 change? + XRLIM = X0 + (NX-1) * SX + YRLIM = Y0 + (NY-1) * SY + DO I=1, NBI + IF ( ABS(XBPI(I) - X0) .LT. SX/4.0 ) XBPI(I) = X0 + IF ( ABS(YBPI(I) - Y0) .LT. SY/4.0 ) YBPI(I) = Y0 + IF ( ABS(XBPI(I) - XRLIM) .LT. SX/4.0 ) XBPI(I) = XRLIM + IF ( ABS(YBPI(I) - YRLIM) .LT. SY/4.0 ) YBPI(I) = YRLIM + ENDDO + + DEALLOCATE ( Anglbdy, ELatbdy, ELonbdy ) + + END IF ! ( Polat < 90. ) + +#endif FLOK = .TRUE. IF (GTYPE .EQ. UNGTYPE) THEN CALL W3NESTUG(DXYMAX,FLOK) -!/SMC !Li For SMC grid check whether boundary points are within cell area. -!/SMC ELSE IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC CALL W3SMCGMP( IGRD, NBI, XBPI, YBPI, ISBPI ) -!/SMC IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,920) & -!/SMC ( ISBPI(I), XBPI(I), YBPI(I), I=1,NBI ) +#ifdef W3_SMC + !Li For SMC grid check whether boundary points are within cell area. + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + CALL W3SMCGMP( IGRD, NBI, XBPI, YBPI, ISBPI ) + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,920) & + ( ISBPI(I), XBPI(I), YBPI(I), I=1,NBI ) +#endif ELSE DO I=1, NBI ! W3GFTP: find the nearest grid point to the input boundary point @@ -452,11 +494,13 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) END DO END IF ! -!/T0 WRITE (NDST,9003) -!/T0 DO I=1, NBI -!/T0 WRITE (NDST,9005) I, ISBPI(I), XBPI(I), YBPI(I), & -!/T0 (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9003) + DO I=1, NBI + WRITE (NDST,9005) I, ISBPI(I), XBPI(I), YBPI(I), & + (IPBPI(I,J),J=1,4), (RDBPI(I,J),J=1,4) + END DO +#endif ! IF ( .NOT.FLOK ) CALL EXTCDE ( 20 ) ! @@ -477,7 +521,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ! READ (NDSB,END=810,ERR=810) TIME2, NBI2 BACKSPACE (NDSB) -!/T WRITE (NDST,9012) NDSB, TIME2, NBI2 +#ifdef W3_T + WRITE (NDST,9012) NDSB, TIME2, NBI2 +#endif CALL W3DMO5 ( IGRD, NDSE, NDST, 3 ) ! END IF @@ -485,7 +531,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ! Save previous spectra on read -------------------------------------- * ! IF ( INXOUT.EQ.'READ' .AND. .NOT.FILER ) THEN -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif TIME1 = TIME2 ABPI0(:,1:NBI2) = ABPIN(:,1:NBI2) END IF @@ -496,25 +544,33 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) DO IFILE=1, NFBPO NPTS = NBO2(IFILE) - NBO2(IFILE-1) WRITE (NDSL(IFILE)) TIME1, NPTS -!/T WRITE (NDST,9010) IFILE, NDSL(IFILE), TIME1, NPTS +#ifdef W3_T + WRITE (NDST,9010) IFILE, NDSL(IFILE), TIME1, NPTS +#endif END DO END IF ! IF ( INXOUT .EQ. 'DUMP' ) THEN WRITE (NDSB) TIME1, NBI2 -!/T WRITE (NDST,9011) NDSB, TIME1, NBI2 +#ifdef W3_T + WRITE (NDST,9011) NDSB, TIME1, NBI2 +#endif END IF ! IF ( INXOUT .EQ. 'READ' ) THEN READ (NDSB,ERR=810,END=810) TIME2, NBI2 -!/T WRITE (NDST,9011) NDSB, TIME2, NBI2 +#ifdef W3_T + WRITE (NDST,9011) NDSB, TIME2, NBI2 +#endif END IF ! ! Spectra ------------------------------------------------------------ * ! IF ( INXOUT .EQ. 'WRITE' ) THEN ! -!/T1 WRITE (NDST,9040) +#ifdef W3_T1 + WRITE (NDST,9040) +#endif ! DO IFILE=1, NFBPO DO ISOUT=NBO2(IFILE-1)+1, NBO2(IFILE) @@ -523,40 +579,48 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) ! ! ... Shared memory version data gather ! -!/SHRD DO IS=1, NSPEC -!/SHRD ABPOS(IS,ISOUT) = VA(IS,ISEA) * SIG2(IS) / & -!/SHRD CG(1+(IS-1)/NTH,ISEA) -!/SHRD END DO +#ifdef W3_SHRD + DO IS=1, NSPEC + ABPOS(IS,ISOUT) = VA(IS,ISEA) * SIG2(IS) / & + CG(1+(IS-1)/NTH,ISEA) + END DO +#endif ! ! ... Distributed memory version data gather ! ( Array pre-filled in W3WAVE ) ! -!/DIST DO IS=1, NSPEC -!/DIST ABPOS(IS,ISOUT) = ABPOS(IS,ISOUT) * SIG2(IS) / & -!/DIST CG(1+(IS-1)/NTH,ISEA) -!/DIST END DO -! -!/RTD ! Polat == 90. means the grid is standard lat-lon, and the spectra -!/RTD ! need not be rotated back -!/RTD IF ( Polat < 90. ) THEN -!/RTD ! Added spectral turning for rotated grid -!/RTD ! (rotate back to standard pole) -!/RTD Spectr = ABPOS(:,ISOUT) -!/RTD CALL W3ACTURN( NTH, NK, -AnglD(ISEA), Spectr ) -!/RTD ABPOS(:,ISOUT) = Spectr -!/RTD END IF +#ifdef W3_DIST + DO IS=1, NSPEC + ABPOS(IS,ISOUT) = ABPOS(IS,ISOUT) * SIG2(IS) / & + CG(1+(IS-1)/NTH,ISEA) + END DO +#endif +! +#ifdef W3_RTD + ! Polat == 90. means the grid is standard lat-lon, and the spectra + ! need not be rotated back + IF ( Polat < 90. ) THEN + ! Added spectral turning for rotated grid + ! (rotate back to standard pole) + Spectr = ABPOS(:,ISOUT) + CALL W3ACTURN( NTH, NK, -AnglD(ISEA), Spectr ) + ABPOS(:,ISOUT) = Spectr + END IF +#endif ! WRITE (NDSL(IFILE)) (ABPOS(IS,ISOUT),IS=1,NSPEC) ! -!/T1 HS = 0. -!/T1 DO IK=1, NK -!/T1 DO ITH=1, NTH -!/T1 IS = ITH + (IK-1)*NTH -!/T1 HS = HS + ABPOS(IS,ISOUT)*SIG(IK) -!/T1 END DO -!/T1 END DO -!/T1 HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) -!/T1 WRITE (NDST,9041) NDSL(IFILE), ISOUT, ISEA, HS +#ifdef W3_T1 + HS = 0. + DO IK=1, NK + DO ITH=1, NTH + IS = ITH + (IK-1)*NTH + HS = HS + ABPOS(IS,ISOUT)*SIG(IK) + END DO + END DO + HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) + WRITE (NDST,9041) NDSL(IFILE), ISOUT, ISEA, HS +#endif ! END DO END DO @@ -591,25 +655,29 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) DEALLOCATE ( TMPSPC ) END IF ! -!/T1 WRITE (NDST,9042) -!/T1 DO IP=1, NBI2 -!/T1 HS = 0. -!/T1 HS0 = 0. -!/T1 DO ISP=1, NSPEC -!/T1 HS = HS + ABPIN(ISP,IP)*SIG2(ISP) -!/T1 IF ( .NOT.FILER ) HS0 = HS0 + ABPI0(ISP,IP)*SIG2(ISP) -!/T1 END DO -!/T1 HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) -!/T1 HS0 = 4. * SQRT ( HS0 * DTH * 0.5 * (XFR-1./XFR) ) -!/T1 WRITE (NDST,9043) IP, HS0, HS -!/T1 END DO +#ifdef W3_T1 + WRITE (NDST,9042) + DO IP=1, NBI2 + HS = 0. + HS0 = 0. + DO ISP=1, NSPEC + HS = HS + ABPIN(ISP,IP)*SIG2(ISP) + IF ( .NOT.FILER ) HS0 = HS0 + ABPI0(ISP,IP)*SIG2(ISP) + END DO + HS = 4. * SQRT ( HS * DTH * 0.5 * (XFR-1./XFR) ) + HS0 = 4. * SQRT ( HS0 * DTH * 0.5 * (XFR-1./XFR) ) + WRITE (NDST,9043) IP, HS0, HS + END DO +#endif ! END IF ! ! Set first spectra on first read ------------------------------------ * ! IF ( INXOUT.EQ.'READ' .AND. FILER ) THEN -!/T WRITE (NDST,9021) +#ifdef W3_T + WRITE (NDST,9021) +#endif TIME1 = TIME2 DO IP=1, NBI2 ABPI0(:,IP) = ABPIN(:,IP) @@ -652,7 +720,9 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) CALL EXTCDE ( 43 ) END IF ! -!/T WRITE (NDST,9022) +#ifdef W3_T + WRITE (NDST,9022) +#endif TIME1(1) = TIME2(1) TIME1(2) = TIME2(2) DO 812, IP=0, NBI2 @@ -702,35 +772,45 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & ' NO DATA IN INPUT FILE'/) ! -!/T 9000 FORMAT (' TEST W3IOBC : INXOUT : ',A5/ & -!/T ' FLAGS : ',3L2/ & -!/T ' UNIT : ',I4) -!/T 9001 FORMAT (' TEST W3IOBC : OPENING FILE ',A,' (',I2,')') -!/T 9002 FORMAT (' TEST W3IOBC : FILE # : ',I4/ & -!/T ' UNIT : ',I4/ & -!/T ' ID : ',A/ & -!/T ' VERSION : ',A/ & -!/T ' POINTS : ',I4) -! -!/T0 9003 FORMAT (' TEST W3IOBC : POINT DATA ') -!/T0 9004 FORMAT (' ',I3,2E10.3,2X,4I4,2X,4F5.2) -!/T0 9005 FORMAT (' ',I3,I4,2E10.3,2X,4I4,2X,4F5.2) -! -!/T 9010 FORMAT (' TEST W3IOBC : OUTPUT FILE ',I1,' UNIT',I3,' TIME', & -!/T I9.8,I7.6,',',I5,' SPECTRA') -!/T 9011 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & -!/T I9.8,I7.6,',',I5,' SPECTRA') -!/T 9012 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & -!/T I9.8,I7.6,',',I5,' SPECTRA (TEST READ)') -! -!/T 9020 FORMAT (' TEST W3IOBC : SAVING OLD DATA') -!/T 9021 FORMAT (' TEST W3IOBC : SAVING FIRST DATA') -!/T 9022 FORMAT (' TEST W3IOBC : EOF REACHED') -! -!/T1 9040 FORMAT (' TEST W3IOBC : UNIT, ISOUT, ISEA, HS(NO TAIL) ') -!/T1 9041 FORMAT ( ' ',I3,2I6,F8.2) -!/T1 9042 FORMAT (' TEST W3IOBC : IP, HS(NO TAIL) ') -!/T1 9043 FORMAT ( ' ',I6,2F8.2) +#ifdef W3_T + 9000 FORMAT (' TEST W3IOBC : INXOUT : ',A5/ & + ' FLAGS : ',3L2/ & + ' UNIT : ',I4) + 9001 FORMAT (' TEST W3IOBC : OPENING FILE ',A,' (',I2,')') + 9002 FORMAT (' TEST W3IOBC : FILE # : ',I4/ & + ' UNIT : ',I4/ & + ' ID : ',A/ & + ' VERSION : ',A/ & + ' POINTS : ',I4) +#endif +! +#ifdef W3_T0 + 9003 FORMAT (' TEST W3IOBC : POINT DATA ') + 9004 FORMAT (' ',I3,2E10.3,2X,4I4,2X,4F5.2) + 9005 FORMAT (' ',I3,I4,2E10.3,2X,4I4,2X,4F5.2) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3IOBC : OUTPUT FILE ',I1,' UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA') + 9011 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA') + 9012 FORMAT (' TEST W3IOBC : INPUT FILE UNIT',I3,' TIME', & + I9.8,I7.6,',',I5,' SPECTRA (TEST READ)') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3IOBC : SAVING OLD DATA') + 9021 FORMAT (' TEST W3IOBC : SAVING FIRST DATA') + 9022 FORMAT (' TEST W3IOBC : EOF REACHED') +#endif +! +#ifdef W3_T1 + 9040 FORMAT (' TEST W3IOBC : UNIT, ISOUT, ISEA, HS(NO TAIL) ') + 9041 FORMAT ( ' ',I3,2I6,F8.2) + 9042 FORMAT (' TEST W3IOBC : IP, HS(NO TAIL) ') + 9043 FORMAT ( ' ',I6,2F8.2) +#endif !/ !/ End of W3IOBC ----------------------------------------------------- / !/ diff --git a/model/ftn/w3iogomd.ftn b/model/src/w3iogomd.F90 similarity index 90% rename from model/ftn/w3iogomd.ftn rename to model/src/w3iogomd.F90 index 308f11dfc..e8846e635 100644 --- a/model/ftn/w3iogomd.ftn +++ b/model/src/w3iogomd.F90 @@ -131,7 +131,9 @@ MODULE W3IOGOMD ! 7. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif !/ PUBLIC CHARACTER(LEN=1024) :: FLDOUT @@ -202,7 +204,9 @@ SUBROUTINE W3FLGRDUPDT ( NDSO, NDSEN, FLGRD, FLGR2, FLGD, FLG2 ) USE CONSTANTS USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF USE W3ODATMD, ONLY: NOGRP, NGRPP -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -218,11 +222,15 @@ SUBROUTINE W3FLGRDUPDT ( NDSO, NDSEN, FLGRD, FLGR2, FLGD, FLG2 ) !/ INTEGER :: I CHARACTER(LEN=10) :: VARNAME1(5),VARNAME2(5) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLGRDUPDT') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLGRDUPDT') +#endif ! VARNAME1(1) = 'EF'; VARNAME2(1) = 'E3D' VARNAME1(2) = 'TH1M'; VARNAME2(2) = 'TH1MF' @@ -350,7 +358,9 @@ SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & USE W3GDATMD, ONLY: US3DF, USSPF USE W3ODATMD, ONLY: NOGRP, NGRPP, NOGE, IDOUT USE W3SERVMD, ONLY: NEXTLN, STRSPLIT, STR_TO_UPPER -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -367,13 +377,17 @@ SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & !/ Local parameters !/ INTEGER :: IFI, IFJ, IOUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif CHARACTER(LEN=1) :: AFLG LOGICAL :: FLT, NAMES !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3READFLGRD') +#ifdef W3_S + CALL STRACE (IENT, 'W3READFLGRD') +#endif ! ! ! 1. Initialize flags -------------------------------------- * @@ -579,7 +593,9 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT USE W3SERVMD, ONLY: STRSPLIT, STR_TO_UPPER USE W3GDATMD, ONLY: US3DF, USSPF -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -596,12 +612,16 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & !/ Local parameters !/ INTEGER :: I, IFI, IFJ, IOUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: FLT !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3FLGRDFLAG') +#ifdef W3_S + CALL STRACE (IENT, 'W3FLGRDFLAG') +#endif ! ! ! 1. Initialize flags -------------------------------------- * @@ -739,23 +759,31 @@ SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) CASE('RHO') I = 1 J = 9 -!/BT4 CASE('D50') -!/BT4 I = 1 -!/BT4 J = 10 -!/IS2 CASE('IC1') -!/IS2 I = 1 -!/IS2 J = 11 -!/IS2 CASE('IC5') -!/IS2 I = 1 -!/IS2 J = 12 +#ifdef W3_BT4 + CASE('D50') + I = 1 + J = 10 +#endif +#ifdef W3_IS2 + CASE('IC1') + I = 1 + J = 11 + CASE('IC5') + I = 1 + J = 12 +#endif ! Group 2 ! -!/OASACM CASE('AHS') -!/OASACM I = 2 -!/OASACM J = 1 -!/OASOCM CASE('OHS') -!/OASOCM I = 2 -!/OASOCM J = 1 +#ifdef W3_OASACM + CASE('AHS') + I = 2 + J = 1 +#endif +#ifdef W3_OASOCM + CASE('OHS') + I = 2 + J = 1 +#endif CASE('HS') I = 2 J = 1 @@ -813,9 +841,11 @@ SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) CASE('WNM') I = 2 J = 19 -!/OASOCM CASE('THM') -!/OASOCM I = 2 -!/OASOCM J = 20 +#ifdef W3_OASOCM + CASE('THM') + I = 2 + J = 20 +#endif ! ! Group 3 ! @@ -897,12 +927,16 @@ SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) CASE('UST') I = 5 J = 1 -!/OASACM CASE('ACHA') -!/OASACM I = 5 -!/OASACM J = 2 -!/OASOCM CASE('OCHA') -!/OASOCM I = 5 -!/OASOCM J = 2 +#ifdef W3_OASACM + CASE('ACHA') + I = 5 + J = 2 +#endif +#ifdef W3_OASOCM + CASE('OCHA') + I = 5 + J = 2 +#endif CASE('CHA') I = 5 J = 2 @@ -1047,7 +1081,9 @@ SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) I = 10 J = 1 ! Not found: -!/COU CASE('DRY') +#ifdef W3_COU + CASE('DRY') +#endif CASE('UNSET') CASE DEFAULT I = -1 @@ -1183,7 +1219,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ICPRT, DTPRT, WSCUT, NOSWLL, FLOGRD, FLOGR2,& NOGRP, NGRPP USE W3ADATMD, ONLY: NSEALM -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3PARALL, ONLY : INIT_GET_ISEA IMPLICIT NONE @@ -1201,7 +1239,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) IKP0(NSEAL), IKP1(NSEAL), NKH(NSEAL),& ILOW, ICEN, IHGH, I, J, LKMS, HKMS, & ITL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FXPMC, FACTOR, FACTOR2, EBAND, FKD, & FP1STR, FP1TST, FPISTR, AABS, UABS, & XL, XH, XL2, XH2, EL, EH, DENOM, KD, & @@ -1241,17 +1281,21 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3OUTG') -! -!/DEBUGSTP WRITE(740+IAPROC,*) 'NTH=', NTH -!/DEBUGSTP WRITE(740+IAPROC,*) 'NK=', NK -!/DEBUGSTP WRITE(740+IAPROC,*) 'NSPEC=', NSPEC -!/DEBUGSTP WRITE(740+IAPROC,*) 'NSEAL=', NSEAL -!/DEBUGSTP WRITE(740+IAPROC,*) 'W3OUTG, initial A printing' -!/DEBUGSTP WRITE(740+IAPROC,*) 'size(A,1)=', size(A,1) -!/DEBUGSTP WRITE(740+IAPROC,*) 'size(A,2)=', size(A,2) -!/DEBUGSTP WRITE(740+IAPROC,*) 'size(A,3)=', size(A,3) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_S + CALL STRACE (IENT, 'W3OUTG') +#endif +! +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'NTH=', NTH + WRITE(740+IAPROC,*) 'NK=', NK + WRITE(740+IAPROC,*) 'NSPEC=', NSPEC + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'W3OUTG, initial A printing' + WRITE(740+IAPROC,*) 'size(A,1)=', size(A,1) + WRITE(740+IAPROC,*) 'size(A,2)=', size(A,2) + WRITE(740+IAPROC,*) 'size(A,3)=', size(A,3) + FLUSH(740+IAPROC) +#endif DO I=1,NOGRP DO J=1,NGRPP FLOLOC(I,J) = & @@ -1378,7 +1422,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! DO ITH=1, NTH ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) +#endif ! DO JSEA=1, NSEAL NKH(JSEA) = MIN ( NK , & @@ -1406,21 +1452,27 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ABXY(JSEA) = ABXY(JSEA) + ESC(ITH)*FACTOR * A(ITH,IK,JSEA) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! ! 2.c Finalize integration over band and update mean arrays ! ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,FACTOR2,MA,MC,MB,KD,FKD,USSCO,M1,M2) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,FACTOR2,MA,MC,MB,KD,FKD,USSCO,M1,M2) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) FACTOR = DDEN(IK) / CG(IK,ISEA) EBD(IK,JSEA) = AB(JSEA) * FACTOR ET (JSEA) = ET (JSEA) + EBD(IK,JSEA) -!/IG1 IF (IK.EQ.NINT(IGPARS(5))) HSIG(JSEA) = 4*SQRT(ET(JSEA)) +#ifdef W3_IG1 + IF (IK.EQ.NINT(IGPARS(5))) HSIG(JSEA) = 4*SQRT(ET(JSEA)) +#endif ETF(JSEA) = ETF(JSEA) + EBD(IK,JSEA) * CG(IK,ISEA) EWN(JSEA) = EWN(JSEA) + EBD(IK,JSEA) / WN(IK,ISEA) ETR(JSEA) = ETR(JSEA) + EBD(IK,JSEA) / SIG(IK) @@ -1547,7 +1599,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) STH2M(JSEA,IK)= SQRT(ABS(0.5*(1-M2)))*RADE END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! @@ -1566,8 +1620,12 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! Compute spectral parameters wrt the mean wave direction ! (no tail contribution - Prognostic) DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF ( MAPSTA(IY,IX) .GT. 0 ) THEN @@ -1587,11 +1645,17 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! DO ITH=1, NTH ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif ABX2M(JSEA) = ABX2M(JSEA) + A(ITH,IK,JSEA)* & (ECOS(ITH)*COS(THMP(JSEA))+ESIN(ITH)*SIN(THMP(JSEA)))**2 ABY2M(JSEA) = ABY2M(JSEA) + A(ITH,IK,JSEA)* & @@ -1605,15 +1669,23 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) (ESIN(ITH)*COS(THMP(JSEA))-ECOS(ITH)*SIN(THMP(JSEA))) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR) +#endif ! DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif FACTOR = DDEN(IK) / CG(IK,ISEA) MSSXM(JSEA) = MSSXM(JSEA) + ABX2M(JSEA)*FACTOR* & WN(IK,ISEA)**2 @@ -1627,15 +1699,23 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) WN(IK,ISEA)**2 END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY,STEX,STEY,STED,ITL,IK) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY,STEX,STEY,STED,ITL,IK) +#endif ! DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) ! @@ -1780,7 +1860,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) HMAXD(JSEA) = STMAXDL(JSEA)*SQRT(2*(1+PHIST(JSEA))) ENDDO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! End of Space-Time Extremes Section @@ -1788,7 +1870,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! ! 3. Finalize computation of mean parameters ------------------------ * ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,EBAND) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,EBAND) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -1829,24 +1913,32 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) UBS(JSEA) = UBS(JSEA) + FTWL * EBAND/GRAV END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! SXX = SXX * DWAT * GRAV SYY = SYY * DWAT * GRAV SXY = SXY * DWAT * GRAV ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF ( MAPSTA(IY,IX) .GT. 0 ) THEN -!/O9 IF ( ET(JSEA) .GE. 0. ) THEN +#ifdef W3_O9 + IF ( ET(JSEA) .GE. 0. ) THEN +#endif HS (JSEA) = 4. * SQRT ( ET(JSEA) ) -!/O9 ELSE -!/O9 HS (JSEA) = - 4. * SQRT ( -ET(JSEA) ) -!/O9 END IF +#ifdef W3_O9 + ELSE + HS (JSEA) = - 4. * SQRT ( -ET(JSEA) ) + END IF +#endif IF ( ET(JSEA) .GT. 1.E-7 ) THEN QP(JSEA) = ( 2. / ET(JSEA)**2 ) * EET1(JSEA) * TPIINV**2 WLM(JSEA) = EWN(JSEA) / ET(JSEA) * TPI @@ -1892,24 +1984,30 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) END IF END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 3.b Clean-up small values if !/O8 switch selected ! -!/O8 DO JSEA=1, NSEAL -!/O8 IF ( HS(JSEA).LE.HSMIN .AND. HS(JSEA).NE.UNDEF) THEN -!/O8 WLM(JSEA) = UNDEF -!/O8 T02(JSEA) = UNDEF -!/O8 T0M1(JSEA) = UNDEF -!/O8 THM(JSEA) = UNDEF -!/O8 THS(JSEA) = UNDEF -!/O8 END IF -!/O8 END DO +#ifdef W3_O8 + DO JSEA=1, NSEAL + IF ( HS(JSEA).LE.HSMIN .AND. HS(JSEA).NE.UNDEF) THEN + WLM(JSEA) = UNDEF + T02(JSEA) = UNDEF + T0M1(JSEA) = UNDEF + THM(JSEA) = UNDEF + THS(JSEA) = UNDEF + END IF + END DO +#endif ! ! 4. Peak frequencies and directions -------------------------------- * ! 4.a Initialize ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FPISTR,FP1STR,FP1TST) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FPISTR,FP1STR,FP1TST) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -1917,42 +2015,58 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) FP0 (JSEA) = UNDEF IKP0(JSEA) = 0 THP0(JSEA) = UNDEF -!/ST0 FP1 (JSEA) = UNDEF -!/ST0 IKP1(JSEA) = NK -!/ST1 FP1 (JSEA) = UNDEF -!/ST1 IKP1(JSEA) = 0 -!/ST2 FP1 (JSEA) = UNDEF -!/ST2 IKP1(JSEA) = NK -!/ST2 FPISTR = MAX ( 0.003 , FPIS(ISEA) * UST(ISEA) / GRAV ) -!/ST2 FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 -!/ST2 FP1TST = MAX ( 0.003 , FP1STR * UST(ISEA) / GRAV ) -!/ST2 IF ( FP1TST.LE.SIG(NK) .AND. FP1TST.GT.SIG(1) ) THEN -!/ST2 FP1 (JSEA) = TPIINV * FP1TST -!/ST2 IKP1(JSEA) = MAX ( 1 , NINT(FACTI2+FACTI1*LOG(FP1TST)) ) -!/ST2 END IF -!/ST3 FP1 (JSEA) = UNDEF -!/ST3 IKP1(JSEA) = 0 -!/ST4 FP1 (JSEA) = UNDEF -!/ST4 IKP1(JSEA) = 0 -!/ST6 FP1 (JSEA) = UNDEF -!/ST6 IKP1(JSEA) = NK -!/ST6 FPISTR = MAX ( 0.003 , FPIS(ISEA) * UST(ISEA) / GRAV ) -!/ST6 FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 -!/ST6 FP1TST = FP1STR / UST(ISEA) * GRAV -!/ST6 IF ( FP1TST.LE.SIG(NK) .AND. FP1TST.GT.SIG(1) ) THEN -!/ST6 FP1 (JSEA) = TPIINV * FP1TST -!/ST6 IKP1(JSEA) = MAX ( 1 , NINT(FACTI2+FACTI1*LOG(FP1TST)) ) -!/ST6 END IF +#ifdef W3_ST0 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = NK +#endif +#ifdef W3_ST1 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = 0 +#endif +#ifdef W3_ST2 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = NK + FPISTR = MAX ( 0.003 , FPIS(ISEA) * UST(ISEA) / GRAV ) + FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 + FP1TST = MAX ( 0.003 , FP1STR * UST(ISEA) / GRAV ) + IF ( FP1TST.LE.SIG(NK) .AND. FP1TST.GT.SIG(1) ) THEN + FP1 (JSEA) = TPIINV * FP1TST + IKP1(JSEA) = MAX ( 1 , NINT(FACTI2+FACTI1*LOG(FP1TST)) ) + END IF +#endif +#ifdef W3_ST3 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = 0 +#endif +#ifdef W3_ST4 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = 0 +#endif +#ifdef W3_ST6 + FP1 (JSEA) = UNDEF + IKP1(JSEA) = NK + FPISTR = MAX ( 0.003 , FPIS(ISEA) * UST(ISEA) / GRAV ) + FP1STR = 3.6E-4 + 0.92*FPISTR - 6.3E-10/FPISTR**3 + FP1TST = FP1STR / UST(ISEA) * GRAV + IF ( FP1TST.LE.SIG(NK) .AND. FP1TST.GT.SIG(1) ) THEN + FP1 (JSEA) = TPIINV * FP1TST + IKP1(JSEA) = MAX ( 1 , NINT(FACTI2+FACTI1*LOG(FP1TST)) ) + END IF +#endif THP1(JSEA) = UNDEF END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 4.b Discrete peak frequencies ! DO IK=NK-1, 2, -1 ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -1960,41 +2074,59 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) EC (JSEA) = EBD(IK,JSEA) IKP0(JSEA) = IK END IF -!/ST1 IF ( IKP1(JSEA).EQ.0 & -!/ST1 .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & -!/ST1 .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & -!/ST1 .AND. SIG(IK).GT.FXPMC/UST(ISEA) & -!/ST1 .AND. SIG(IK).LT.0.75*SIG(NK) ) & -!/ST1 IKP1(JSEA) = IK -!/ST3 IF ( IKP1(JSEA).EQ.0 & -!/ST3 .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & -!/ST3 .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & -!/ST3 .AND. SIG(IK).GT.FXPMC/MAX(1.E-4,UST(ISEA)) & -!/ST3 .AND. SIG(IK).LT.0.75*SIG(NK) ) & -!/ST3 IKP1(JSEA) = IK -!/ST4 IF ( IKP1(JSEA).EQ.0 & -!/ST4 .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & -!/ST4 .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & -!/ST4 .AND. SIG(IK).GT.FXPMC/MAX(1.E-4,UST(ISEA)) & -!/ST4 .AND. SIG(IK).LT.0.75*SIG(NK) ) & -!/ST4 IKP1(JSEA) = IK +#ifdef W3_ST1 + IF ( IKP1(JSEA).EQ.0 & + .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & + .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & + .AND. SIG(IK).GT.FXPMC/UST(ISEA) & + .AND. SIG(IK).LT.0.75*SIG(NK) ) & + IKP1(JSEA) = IK +#endif +#ifdef W3_ST3 + IF ( IKP1(JSEA).EQ.0 & + .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & + .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & + .AND. SIG(IK).GT.FXPMC/MAX(1.E-4,UST(ISEA)) & + .AND. SIG(IK).LT.0.75*SIG(NK) ) & + IKP1(JSEA) = IK +#endif +#ifdef W3_ST4 + IF ( IKP1(JSEA).EQ.0 & + .AND. EBD(IK-1,JSEA).LT.EBD(IK,JSEA) & + .AND. EBD(IK-1,JSEA).LT.EBD(IK+1,JSEA) & + .AND. SIG(IK).GT.FXPMC/MAX(1.E-4,UST(ISEA)) & + .AND. SIG(IK).LT.0.75*SIG(NK) ) & + IKP1(JSEA) = IK +#endif END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) IF ( IKP0(JSEA) .NE. 0 ) FP0(JSEA) = SIG(IKP0(JSEA)) * TPIINV -!/ST1 IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV -!/ST3 IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV -!/ST4 IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV +#ifdef W3_ST1 + IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV +#endif +#ifdef W3_ST3 + IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV +#endif +#ifdef W3_ST4 + IF ( IKP1(JSEA) .NE. 0 ) FP1(JSEA) = SIG(IKP1(JSEA)) * TPIINV +#endif END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 4.c Continuous peak frequencies ! @@ -2003,7 +2135,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) XL2 = XL**2 XH2 = XH**2 ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,ILOW,ICEN,IHGH,EL,EH,DENOM) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,ILOW,ICEN,IHGH,EL,EH,DENOM) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2015,48 +2149,62 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) DENOM = XL*EH - XH*EL FP0(JSEA) = FP0 (JSEA) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) & / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) -!/ST1 ILOW = MAX ( 1 , IKP1(JSEA)-1 ) -!/ST1 ICEN = MAX ( 1 , IKP1(JSEA) ) -!/ST1 IHGH = MIN ( NK , IKP1(JSEA)+1 ) -!/ST1 EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) -!/ST1 EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) -!/ST1 DENOM = XL*EH - XH*EL -!/ST1 FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & -!/ST1 / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) -!/ST3 ILOW = MAX ( 1 , IKP1(JSEA)-1 ) -!/ST3 ICEN = MAX ( 1 , IKP1(JSEA) ) -!/ST3 IHGH = MIN ( NK , IKP1(JSEA)+1 ) -!/ST3 EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) -!/ST3 EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) -!/ST3 DENOM = XL*EH - XH*EL -!/ST3 FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & -!/ST3 / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) -!/ST4 ILOW = MAX ( 1 , IKP1(JSEA)-1 ) -!/ST4 ICEN = MAX ( 1 , IKP1(JSEA) ) -!/ST4 IHGH = MIN ( NK , IKP1(JSEA)+1 ) -!/ST4 EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) -!/ST4 EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) -!/ST4 DENOM = XL*EH - XH*EL -!/ST4 FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & -!/ST4 / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) +#ifdef W3_ST1 + ILOW = MAX ( 1 , IKP1(JSEA)-1 ) + ICEN = MAX ( 1 , IKP1(JSEA) ) + IHGH = MIN ( NK , IKP1(JSEA)+1 ) + EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) + EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) + DENOM = XL*EH - XH*EL + FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) +#endif +#ifdef W3_ST3 + ILOW = MAX ( 1 , IKP1(JSEA)-1 ) + ICEN = MAX ( 1 , IKP1(JSEA) ) + IHGH = MIN ( NK , IKP1(JSEA)+1 ) + EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) + EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) + DENOM = XL*EH - XH*EL + FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) +#endif +#ifdef W3_ST4 + ILOW = MAX ( 1 , IKP1(JSEA)-1 ) + ICEN = MAX ( 1 , IKP1(JSEA) ) + IHGH = MIN ( NK , IKP1(JSEA)+1 ) + EL = EBD(ILOW,JSEA) - EBD(ICEN,JSEA) + EH = EBD(IHGH,JSEA) - EBD(ICEN,JSEA) + DENOM = XL*EH - XH*EL + FP1(JSEA) = FP1(JSEA) * ( 1. + 0.5 * (XL2*EH - XH2*EL ) & + / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) +#endif END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 4.d Peak directions ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA) +#endif ! DO JSEA=1, NSEAL ETX(JSEA) = 0. ETY(JSEA) = 0. END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! DO ITH=1, NTH ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2066,11 +2214,15 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) END IF END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2082,11 +2234,15 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) IKP1(JSEA) = MAX ( 1 , IKP1(JSEA) ) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! DO ITH=1, NTH ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2096,11 +2252,15 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) END IF END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,IX,IY) +#endif ! DO JSEA =1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2113,9 +2273,13 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) END IF END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(ISEA,JSEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(ISEA,JSEA) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2124,32 +2288,36 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) THP1(JSEA) = ATAN2(ETY(JSEA),ETX(JSEA)) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 5. Test output (local to MPP only) ! -!/T WRITE (NDST,9050) -!/T DO JSEA =1, NSEAL -!/T CALL INIT_GET_ISEA(ISEA, JSEA) -!/T IX = MAPSF(ISEA,1) -!/T IY = MAPSF(ISEA,2) -!/T IF ( HS(JSEA) .EQ. UNDEF ) THEN -!/T WRITE (NDST,9051) ISEA, IX, IY -!/T ELSE IF ( WLM(JSEA) .EQ. UNDEF ) THEN -!/T WRITE (NDST,9052) ISEA, IX, IY, HS(JSEA) -!/T ELSE IF ( FP0(JSEA) .EQ. UNDEF ) THEN -!/T WRITE (NDST,9053) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & -!/T T0M1(JSEA), RADE*THM(JSEA), THS(JSEA) -!/T ELSE IF ( FP1(JSEA) .EQ. UNDEF ) THEN -!/T WRITE (NDST,9054) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & -!/T T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& -!/T THP0(JSEA) -!/T ELSE -!/T WRITE (NDST,9055) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & -!/T T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& -!/T THP0(JSEA), FP1(JSEA), THP1(JSEA) -!/T END IF -!/T END DO +#ifdef W3_T + WRITE (NDST,9050) + DO JSEA =1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + IF ( HS(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9051) ISEA, IX, IY + ELSE IF ( WLM(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9052) ISEA, IX, IY, HS(JSEA) + ELSE IF ( FP0(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9053) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & + T0M1(JSEA), RADE*THM(JSEA), THS(JSEA) + ELSE IF ( FP1(JSEA) .EQ. UNDEF ) THEN + WRITE (NDST,9054) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & + T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& + THP0(JSEA) + ELSE + WRITE (NDST,9055) ISEA, IX, IY, HS(JSEA), WLM(JSEA), & + T0M1(JSEA), RADE*THM(JSEA), THS(JSEA), FP0(JSEA),& + THP0(JSEA), FP1(JSEA), THP1(JSEA) + END IF + END DO +#endif ! ! 6. Fill arrays wth partitioned data ! @@ -2177,7 +2345,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! ! 6.b Loop over local sea points ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(ISEA,JSEA,IX,IY,I,J) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(ISEA,JSEA,IX,IY,I,J) +#endif ! DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -2249,7 +2419,9 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END IF @@ -2270,13 +2442,15 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! ! Formats ! -!/T 9050 FORMAT (' TEST W3OUTG : ISEA, IX, IY, HS, L, Tm, THm, THs', & -!/T ', FP0, THP0, FP1, THP1') -!/T 9051 FORMAT (2X,I8,2I8) -!/T 9052 FORMAT (2X,I8,2I8,F6.2) -!/T 9053 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1) -!/T 9054 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,F6.3,F6.0) -!/T 9055 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,2(F6.3,F6.0)) +#ifdef W3_T + 9050 FORMAT (' TEST W3OUTG : ISEA, IX, IY, HS, L, Tm, THm, THs', & + ', FP0, THP0, FP1, THP1') + 9051 FORMAT (2X,I8,2I8) + 9052 FORMAT (2X,I8,2I8,F6.2) + 9053 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1) + 9054 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,F6.3,F6.0) + 9055 FORMAT (2X,I8,2I8,F6.2,F7.1,F6.2,2F6.1,2(F6.3,F6.0)) +#endif !/ !/ End of W3OUTG ----------------------------------------------------- / @@ -2427,8 +2601,12 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, only : IAPROC USE W3ODATMD, ONLY : OFILES -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -2448,16 +2626,22 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) MGRPP, ISEA, MOSWLL, IK, IFI, IFJ & ,IFILOUT INTEGER, ALLOCATABLE :: MAPTMP(:,:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: AUX1(NSEA), AUX2(NSEA), & AUX3(NSEA), AUX4(NSEA) -!/SMC REAL :: UDARC +#ifdef W3_SMC + REAL :: UDARC +#endif CHARACTER(LEN=30) :: IDTST, TNAME CHARACTER(LEN=10) :: VERTST !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOGO') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOGO') +#endif ! ! test input parameters ---------------------------------------------- * ! @@ -2470,7 +2654,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) CALL W3SETO ( IGRD, NDSE, NDST ) CALL W3SETG ( IGRD, NDSE, NDST ) CALL W3SETA ( IGRD, NDSE, NDST ) -!/MPI CALL W3XETA ( IGRD, NDSE, NDST ) +#ifdef W3_MPI + CALL W3XETA ( IGRD, NDSE, NDST ) +#endif CALL W3SETW ( IGRD, NDSE, NDST ) ! IPASS = IPASS + 1 @@ -2490,7 +2676,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) END IF END IF ! -!/T WRITE (NDST,9000) IPASS, INXOUT, WRITE, NDSOG, IGRD, FILEXT +#ifdef W3_T + WRITE (NDST,9000) IPASS, INXOUT, WRITE, NDSOG, IGRD, FILEXT +#endif ! ! ! open file ---------------------------------------------------------- * @@ -2500,7 +2688,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) I = LEN_TRIM(FILEXT) J = LEN_TRIM(FNMPRE) ! -!/T WRITE (NDST,9001) FNMPRE(:J)//'out_grd.'//FILEXT(:I) +#ifdef W3_T + WRITE (NDST,9001) FNMPRE(:J)//'out_grd.'//FILEXT(:I) +#endif IF ( WRITE ) THEN OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) @@ -2545,8 +2735,10 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! END IF ! -!/T WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & -!/T UNDEF +#ifdef W3_T + WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & + UNDEF +#endif ! END IF ! @@ -2570,7 +2762,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! ! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) -!/T WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) +#ifdef W3_T + WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) +#endif IF ( WRITE ) THEN OPEN (NDSOG,FILE=FNMPRE(:J)//TIMETAG//'.out_grd.' & //FILEXT(:I),FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) @@ -2615,8 +2809,10 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! END IF ! -!/T WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & -!/T UNDEF +#ifdef W3_T + WRITE (NDST,9002) IDSTR, VEROGR, GNAME, NSEA, NX, NY, & + UNDEF +#endif ! END IF ! @@ -2628,7 +2824,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) READ (NDSOG,END=803,ERR=802,IOSTAT=IERR) TIME, FLOGRD END IF ! -!/T WRITE (NDST,9003) TIME, FLOGRD +#ifdef W3_T + WRITE (NDST,9003) TIME, FLOGRD +#endif ! ! MAPSTA ------------------------------------------------------------- * ! @@ -2820,7 +3018,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) IF ( FLOGRD(IFI,IFJ) ) THEN ! -!/T WRITE (NDST,9010) FLOGRD(IFI,IFJ), IDOUT(IFI,IFJ) +#ifdef W3_T + WRITE (NDST,9010) FLOGRD(IFI,IFJ), IDOUT(IFI,IFJ) +#endif ! IF ( WRITE ) THEN ! @@ -2833,11 +3033,13 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) WRITE ( NDSOG ) CY(1:NSEA) ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN DO ISEA=1, NSEA -!/SMC !!Li Rotate map-east wind in Arctic part back to local east. JGLi02Feb2016 -!/SMC IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN -!/SMC UDARC = UD(ISEA) - ANGARC(ISEA - NGLO)*DERA -!/SMC UD(ISEA) = MOD(TPI + UDARC, TPI) -!/SMC ENDIF +#ifdef W3_SMC + !!Li Rotate map-east wind in Arctic part back to local east. JGLi02Feb2016 + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = UD(ISEA) - ANGARC(ISEA - NGLO)*DERA + UD(ISEA) = MOD(TPI + UDARC, TPI) + ENDIF +#endif IF (UA(ISEA) .NE.UNDEF) THEN AUX1(ISEA) = UA(ISEA)*COS(UD(ISEA)) AUX2(ISEA) = UA(ISEA)*SIN(UD(ISEA)) @@ -2858,11 +3060,13 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) WRITE ( NDSOG ) BERG(1:NSEA) ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN DO ISEA=1, NSEA -!/SMC !!Li Rotate map-east momentum in Arctic part back to local east. JGLi02Feb2016 -!/SMC IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN -!/SMC UDARC = TAUADIR(ISEA) - ANGARC(ISEA - NGLO)*DERA -!/SMC TAUADIR(ISEA) = MOD(TPI + UDARC, TPI) -!/SMC ENDIF +#ifdef W3_SMC + !!Li Rotate map-east momentum in Arctic part back to local east. JGLi02Feb2016 + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = TAUADIR(ISEA) - ANGARC(ISEA - NGLO)*DERA + TAUADIR(ISEA) = MOD(TPI + UDARC, TPI) + ENDIF +#endif IF (TAUA(ISEA) .NE.UNDEF) THEN AUX1(ISEA) = TAUA(ISEA)*COS(TAUADIR(ISEA)) AUX2(ISEA) = TAUA(ISEA)*SIN(TAUADIR(ISEA)) @@ -2875,14 +3079,20 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) WRITE ( NDSOG ) AUX2 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN WRITE ( NDSOG ) RHOAIR(1:NSEA) -!/BT4 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN -!/BT4 WRITE ( NDSOG ) SED_D50(1:NSEA) -!/IS2 ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN -!/IS2 WRITE (NDSOG ) ICEH(1:NSEA) -!/IS2 ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN -!/IS2 WRITE (NDSOG ) ICEF(1:NSEA) -!/SETUP ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN -!/SETUP WRITE ( NDSOG ) ZETA_SETUP(1:NSEA) +#ifdef W3_BT4 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + WRITE ( NDSOG ) SED_D50(1:NSEA) +#endif +#ifdef W3_IS2 + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + WRITE (NDSOG ) ICEH(1:NSEA) + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + WRITE (NDSOG ) ICEF(1:NSEA) +#endif +#ifdef W3_SETUP + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN + WRITE ( NDSOG ) ZETA_SETUP(1:NSEA) +#endif ! ! Section 2) @@ -3160,14 +3370,20 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) TAUADIR(1:NSEA) ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) RHOAIR(1:NSEA) -!/BT4 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN -!/BT4 READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SED_D50(1:NSEA) -!/IS2 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN -!/IS2 READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEH(1:NSEA) -!/IS2 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN -!/IS2 READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) -!/SETUP ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN -!/SETUP READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ZETA_SETUP(1:NSEA) +#ifdef W3_BT4 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) SED_D50(1:NSEA) +#endif +#ifdef W3_IS2 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEH(1:NSEA) + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) +#endif +#ifdef W3_SETUP + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 13 ) THEN + READ (NDSOG,END=801,ERR=802,IOSTAT=IERR) ZETA_SETUP(1:NSEA) +#endif ! ! Section 2) ! @@ -3483,7 +3699,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! IF(OFILES(1) .EQ. 1) CLOSE(NDSOG) ! -!/MPI CALL W3SETA ( IGRD, NDSE, NDST ) +#ifdef W3_MPI + CALL W3SETA ( IGRD, NDSE, NDST ) +#endif ! RETURN ! @@ -3503,7 +3721,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! 803 CONTINUE IOTST = -1 -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif RETURN ! ! Formats @@ -3540,25 +3760,27 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ' ERROR IN READING FROM FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST W3IOGO : IPASS =',I4,' INXOUT = ',A, & -!/T ' WRITE = ',L1,' UNIT =',I3/ & -!/T ' IGRD =',I3,' FEXT = ',A) -!/T 9001 FORMAT (' TEST W3IOGO : OPENING NEW FILE [',A,']') -!/T 9002 FORMAT (' TEST W3IOGO : TEST PARAMETERS:'/ & -!/T ' IDSTR : ',A/ & -!/T ' VEROGR : ',A/ & -!/T ' GNAME : ',A/ & -!/T ' NSEA :',I6/ & -!/T ' NX,NY : ',I9,I12/ & -!/T ' UNDEF : ',F8.2) -!/T 9003 FORMAT (' TEST W3IOGO : TIME :',I9.8,I7.6/ & -!/T ' FLAGS :',20L2,1X,20L2/ & -!/T ' ',20L2,2X,20L2/ & -!/T ' ',20L2,2X,20L2/ & -!/T ' ',20L2,2X,20L2/ & -!/T ' ',20L2,2X,20L2) -!/T 9010 FORMAT (' TEST W3IOGO : PROC = ',L1,' FOR ',A) -!/T 9020 FORMAT (' TEST W3IOGO : END OF FILE REACHED') +#ifdef W3_T + 9000 FORMAT (' TEST W3IOGO : IPASS =',I4,' INXOUT = ',A, & + ' WRITE = ',L1,' UNIT =',I3/ & + ' IGRD =',I3,' FEXT = ',A) + 9001 FORMAT (' TEST W3IOGO : OPENING NEW FILE [',A,']') + 9002 FORMAT (' TEST W3IOGO : TEST PARAMETERS:'/ & + ' IDSTR : ',A/ & + ' VEROGR : ',A/ & + ' GNAME : ',A/ & + ' NSEA :',I6/ & + ' NX,NY : ',I9,I12/ & + ' UNDEF : ',F8.2) + 9003 FORMAT (' TEST W3IOGO : TIME :',I9.8,I7.6/ & + ' FLAGS :',20L2,1X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2/ & + ' ',20L2,2X,20L2) + 9010 FORMAT (' TEST W3IOGO : PROC = ',L1,' FOR ',A) + 9020 FORMAT (' TEST W3IOGO : END OF FILE REACHED') +#endif !/ !/ End of W3IOGO ----------------------------------------------------- / !/ @@ -3650,7 +3872,9 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) USE W3ADATMD, ONLY: CG, WN, DW USE W3ADATMD, ONLY: USSX, USSY, US3D, USSP USE W3ODATMD, ONLY: IAPROC, NAPROC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -3665,7 +3889,9 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) !/ INTEGER :: IK, ITH, ISEA, JSEA INTEGER :: IKST, IKFI, IB -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FACTOR, FKD,KD REAL :: ABX(NSEAL), ABY(NSEAL), USSCO REAL :: MINDIFF @@ -3673,7 +3899,9 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'CALC_U3STOKES') +#ifdef W3_S + CALL STRACE (IENT, 'CALC_U3STOKES') +#endif ! ! 1. Initialize storage arrays -------------------------------------- * ! @@ -3714,27 +3942,41 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) ! DO ITH=1, NTH ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA) +#endif ! DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif ABX(JSEA) = ABX(JSEA) + A(ITH,IK,JSEA)*ECOS(ITH) ABY(JSEA) = ABY(JSEA) + A(ITH,IK,JSEA)*ESIN(ITH) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! END DO ! ! 2.c Finalize integration over band and update mean arrays ! ! -!/OMPG/!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,KD,FKD,USSCO,MINDIFF,IB) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE(JSEA,ISEA,FACTOR,KD,FKD,USSCO,MINDIFF,IB) +#endif ! DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif FACTOR = DDEN(IK) / CG(IK,ISEA) ! ! Deep water limits @@ -3775,7 +4017,9 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) USSP(JSEA,NK+Spc2BND(IK)) = USSP(JSEA,NK+Spc2Bnd(IK)) + ABY(JSEA)*USSCO ENDIF END DO -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif END DO ! RETURN @@ -3853,7 +4097,9 @@ SUBROUTINE CALC_WBT (A) FTE, XFR, MAPSF, MAPSTA, DMIN USE W3GDATMD, ONLY: BTBETA USE W3PARALL, ONLY: INIT_GET_ISEA -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -3865,7 +4111,9 @@ SUBROUTINE CALC_WBT (A) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! INTEGER :: FPOPT = 0 ! @@ -3879,7 +4127,9 @@ SUBROUTINE CALC_WBT (A) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'CALC_WBT') +#ifdef W3_S + CALL STRACE (IENT, 'CALC_WBT') +#endif ! DO JSEA = 1, NSEAL ! JSEA 2 ISEA diff --git a/model/src/w3iogrmd.F90 b/model/src/w3iogrmd.F90 new file mode 100644 index 000000000..516bcc8af --- /dev/null +++ b/model/src/w3iogrmd.F90 @@ -0,0 +1,2002 @@ +#include "w3macros.h" +!/ ------------------------------------------------------------------- / + MODULE W3IOGRMD +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ ! F. Ardhuin ! +!/ | FORTRAN 90 | +!/ | Last update : 15-Apr-2020 | +!/ +-----------------------------------+ +!/ +!/ For updates see W3IOGR documentation. +!/ +! 1. Purpose : +! +! Reading/writing of model definition file . +! +! 2. Variables and types : +! +! Name Type Scope Description +! ---------------------------------------------------------------- +! VERGRD C*10 Private Model definition file version number. +! IDSTR C*35 Private Model definition file ID string. +! ---------------------------------------------------------------- +! +! 3. Subroutines and functions : +! +! Name Type Scope Description +! ---------------------------------------------------------------- +! W3IOGR Subr. Public Read/write model definition file. +! ---------------------------------------------------------------- +! +! 4. Subroutines and functions used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3SETG Subr. W3GDATMD Point to data structure for spatial gr. +! W3DIMX Subr. Id. Set up arrays for spatial grid. +! W3DIMS Subr. Id. Set array dimensions for a spec. grid. +! W3SETO Subr. W3ODATMD Point to data structure for spatial gr. +! W3DMO5 Subr. Id. Set array dimensions. +! INPTAB Subr. W3SRC2MD Fill interpolation tables for +! dispersion relation. +! DISTAB Subr. W3DISPMD Input coefficient lookup table. +! INSNL1 Subr. W3SNL1MD Initialization of the DIA. +! INSNL2 Subr. W3SNL2MD Initialization of WRT. +! INSNL3 Subr. W3SNL3MD Initialization of GMD. +! INSNL5 Subr. W3SNL5MD Initialization of GKE. +! INSNLS Subr. W3SNLSMD Initialization of nonlinear `smoother'. +! STRACE Subr. W3SERVMD Subroutine tracing. +! EXTCDE Subr. W3SERVMD Abort program with exit code. +! ---------------------------------------------------------------- +! +! 5. Remarks : +! +! - Arrays allocated here on read or ing ww3_grid on write. +! +! 6. Switches : +! +! See subroutine. +! +! 7. Source code : +! +!/ ------------------------------------------------------------------- / + PUBLIC +!/ +!/ Private parameter statements (ID strings) +!/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERGRD = '2021-08-06' + CHARACTER(LEN=35), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III MODEL DEFINITION FILE' +!/ +!/ Public variables +!/ +!/ + CONTAINS +!/ ------------------------------------------------------------------- / + SUBROUTINE W3IOGR ( INXOUT, NDSM, IMOD, FEXT ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ ! F. Ardhuin ! +!/ | FORTRAN 90 | +!/ | Last update : 19-Oct-2020 | +!/ +-----------------------------------+ +!/ +!/ 14-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Major changes to logistics. +!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) +!/ 09-Jan-2001 : Flat grid option. ( version 2.06 ) +!/ 02-Feb-2001 : Exact-NL version 3.0 ( version 2.07 ) +!/ 27-Feb-2001 : Third propagation scheme added. ( version 2.08 ) +!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) +!/ 29-Mar-2001 : Sub-grid islands added. ( version 2.10 ) +!/ 11-Jan-2002 : Sub-grid ice added. ( version 2.15 ) +!/ 09-May-2002 : Switch clean up. ( version 2.21 ) +!/ 27-Aug-2002 : Exact-NL version 4.0 ( version 2.22 ) +!/ 26-Nov-2002 : Adding first VDIA and MDIA. ( version 3.01 ) +!/ 01-Aug-2003 : Adding moving grid GSE correction. ( version 3.03 ) +!/ 08-Mar-2004 : Multiple grid version. ( version 3.06 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 24-Jun-2005 : Add MAPST2 processing. ( version 3.07 ) +!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) +!/ 23-Jun-2006 : Add W3SLN1 parameters. ( version 3.09 ) +!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) +!/ 25-Jul-2006 : Reorder for 'GRID' option to read ( version 3.10 ) +!/ spectral data also. +!/ 28-Oct-2006 : Add partitioning pars. ( version 3.10 ) +!/ 26-Mar-2007 : Add partitioning pars. ( version 3.11 ) +!/ 16-Apr-2006 : Add Miche limiter pars. ( version 3.11 ) +!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) +!/ 09-Oct-2007 : Adding WAM cycle 4+ Sin and Sds. ( version 3.13 ) +!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) +!/ 30-Oct-2009 : Fix ndst arg in call to w3dmo5. ( version 3.14 ) +!/ (T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 23-Dec-2009 : Addition of COU namelists ( version 3.14 ) +!/ 31-Oct-2010 : Implement unstructured grids ( version 3.14 ) +!/ (A. Roland and F. Ardhuin) +!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to +!/ specify index closure for a grid. ( version 3.14 ) +!/ (T. J. Campbell, NRL) +!/ 12-Jun-2012 : Add /RTD option or rotated grid option. +!/ (Jian-Guo Li) ( version 4.06 ) +!/ 13-Jul-2012 : Move GMD (SNL3) and nonlinear filter (SNLS) +!/ from 3.15 (HLT). ( version 4.08 ) +!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) +!/ 19-Dec-2012 : Add NOSWLL to file. ( version 4.11 ) +!/ 01-Jul-2013 : Document UQ / UNO switches in file ( version 4.12 ) +!/ 10-Sep-2013 : Add IG1 parameters ( version 4.12 ) +!/ 16-Sep-2013 : Add Arctic part in SMC grid. ( version 4.12 ) +!/ 11-Nov-2013 : Make SMC and RTD grids compatible. ( version 4.13 ) +!/ 06-Mar-2014 : Writes out a help message on error ( version 4.18 ) +!/ 10-Mar-2014 : Add IC2 parameters ( version 5.01 ) +!/ 29-May-2014 : Add IC3 parameters ( version 5.01 ) +!/ 20-Aug-2016 : Add IOBPA ( version 5.12 ) +!/ 08-Mar-2018 : Add FSWND for SMC grid. ( version 6.02 ) +!/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters +!/ for unstructured grids ( version 6.04 ) +!/ 27-Jul-2018 : Added PTMETH and PTFCUT parameters ( version 6.05 ) +!/ (C. Bunney, UKMO) +!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) +!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) +!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) +!/ 18-Jun-2020 : Adds 360-day calendar option ( version 7.08 ) +!/ 19-Oct-2020 : Add AIRCMIN, AIRGB parameters ( version 7.08 ) +!/ 07-07-2021 : S_{nl} GKE NL5 (Q. Liu) ( version 7.12 ) +!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) +!/ +!/ Copyright 2009-2013 National Weather Service (NWS), +!/ National Oceanic and Atmospheric Administration. All rights +!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ No unauthorized use without permission. +!/ +! 1. Purpose : +! +! Reading and writing of the model definition file. +! +! 2. Method : +! +! The file is opened within the routine, the name is pre-defined +! and the unit number is given in the parameter list. The model +! definition file is written using UNFORMATTED write statements. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! INXOUT C*(*) I Test string for read/write, valid are: +! 'READ', 'WRITE' and 'GRID'. +! NDSM Int. I File unit number. +! IMOD Int. I Model number for W3GDAT etc. +! FEXT C*(*) I File extension to be used. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! See above. +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3INIT Subr. W3INITMD Wave model initialization routine. +! ...... Prog. N/A All WAVEWATCH III aux programs and +! drivers. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! Tests on INXOUT, file status and on array dimensions. +! +! 7. Remarks : +! +! - The model definition file has the pre-defined name +! 'mod_def.FILEXT'. +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/MPI MPI calls +! +! !/LNn Select source terms +! !/STn +! !/NLn +! !/BTn +! !/DBn +! !/TRn +! !/BSn +! !/XXn +! +! !/S Enable subroutine tracing. +! !/T Enable test output +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3GDATMD +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE +#endif + USE W3ODATMD +#ifdef W3_ST2 + USE W3SRC2MD, ONLY: INPTAB +#endif +#ifdef W3_ST3 + USE W3SRC3MD, ONLY: INSIN3 +#endif +#ifdef W3_ST4 + USE W3SRC4MD, ONLY: INSIN4, TAUT, TAUHFT, TAUHFT2, & + DELU, DELTAUW, DELUST, & + DELALP, DELTAIL, & + DIKCUMUL +#endif +#ifdef W3_NL1 + USE W3SNL1MD, ONLY: INSNL1 +#endif +#ifdef W3_NL2 + USE W3SNL2MD, ONLY: INSNL2 +#endif +#ifdef W3_NL3 + USE W3SNL3MD, ONLY: INSNL3 +#endif +#ifdef W3_NL5 + USE W3SNL5MD, ONLY: INSNL5 +#endif +#ifdef W3_NLS + USE W3SNLSMD, ONLY: INSNLS +#endif +#ifdef W3_IS2 + USE W3SIS2MD, ONLY: INSIS2 +#endif + USE W3TIMEMD, ONLY: CALTYPE + USE W3SERVMD, ONLY: EXTCDE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif + USE W3DISPMD +#ifdef W3_UOST + USE W3UOSTMD, ONLY: UOST_INITGRID +#endif +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS + USE MallocInfo_m +#endif +! + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: NDSM + INTEGER, INTENT(IN), OPTIONAL :: IMOD + CHARACTER, INTENT(IN) :: INXOUT*(*) + CHARACTER, INTENT(IN), OPTIONAL :: FEXT*(*) +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + INTEGER :: IGRD, IERR, I, J, MTH, MK, ISEA, IX, IY +#ifdef W3_ST4 + INTEGER :: IK, ITH, IK2, ITH2 +#endif + INTEGER, ALLOCATABLE :: MAPTMP(:,:) +#ifdef W3_MPI + INTEGER :: IERR_MPI, IP +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: K +#endif + LOGICAL :: WRITE, FLTEST = .FALSE., TESTLL, & + FLSNL2 = .FALSE. + LOGICAL, SAVE :: FLINP = .FALSE. , FLDISP = .FALSE., & + FLIS = .FALSE. + CHARACTER(LEN=10) :: VERTST + CHARACTER(LEN=13) :: TEMPXT + CHARACTER(LEN=30) :: TNAME0, TNAME1, TNAME2, TNAME3, & + TNAME4, TNAME5, TNAME6, & + TNAMEP, TNAMEG, TNAMEF, TNAMEI + CHARACTER(LEN=30) :: FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, & + FNAMEP, FNAMEG, FNAMEF, FNAMEI + CHARACTER(LEN=35) :: IDTST + CHARACTER(LEN=60) :: MESSAGE(5) + LOGICAL :: GLOBAL +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3IOGR') +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + + MESSAGE =(/ ' MOD DEF FILE WAS GENERATED WITH A DIFFERENT ', & + ' WW3 VERSION OR USING A DIFFERENT SWITCH FILE. ', & + ' MAKE SURE WW3_GRID IS COMPILED WITH SAME SWITCH', & + ' AS WW3_SHEL OR WW3_MULTI, RUN WW3_GRID AGAIN ', & + ' AND THEN TRY AGAIN THE PROGRAM YOU JUST USED. '/) +! + TNAMEF = '------------------------------' + TNAME0 = '------------------------------' + TNAME1 = '------------------------------' + TNAME2 = '------------------------------' + TNAME3 = '------------------------------' + TNAME4 = '------------------------------' + TNAME5 = '------------------------------' + TNAME6 = '------------------------------' + TNAMEP = '------------------------------' + TNAMEG = '------------------------------' + TNAMEI = '------------------------------' +! +#ifdef W3_FLX1 + TNAMEF = 'Wu (1980) ' +#endif +#ifdef W3_FLX2 + TNAMEF = 'Tolman and Chalikov (1996) ' +#endif +#ifdef W3_FLX3 + TNAMEF = 'T and C(1996) with cap on Cd ' +#endif +#ifdef W3_FLX4 + TNAMEF = 'Hwang (2011) with cap on Cd ' +#endif +#ifdef W3_FLX5 + TNAMEF = 'Direct use of stress ' +#endif +#ifdef W3_LN0 + TNAME0 = 'Not defined ' +#endif +#ifdef W3_LN1 + TNAME0 = 'Cavaleri and M.-R. (1982) ' +#endif +#ifdef W3_ST0 + TNAME1 = 'Not defined ' +#endif +#ifdef W3_ST1 + TNAME1 = 'WAM cycles 1 through 3 ' +#endif +#ifdef W3_ST2 + TNAME1 = 'Tolman and Chalikov (1996) ' +#endif +#ifdef W3_ST3 + TNAME1 = 'WAM cycle 4+ ' +#endif +#ifdef W3_ST4 + TNAME1 = 'Ardhuin et al. (2009+) ' +#endif +#ifdef W3_ST6 + TNAME1 = 'BYDB input and dissipation ' +#endif +#ifdef W3_NL0 + TNAME2 = 'Not defined ' +#endif +#ifdef W3_NL1 + TNAME2 = 'Discrete Interaction Approx. ' +#endif +#ifdef W3_NL2 + TNAME2 = 'Exact nonlinear interactions ' +#endif +#ifdef W3_NL3 + TNAME2 = 'Generalized Multiple DIA ' +#endif +#ifdef W3_NL4 + TNAME2 = 'Two Scaled Approximation ' +#endif +#ifdef W3_NL5 + TNAME2 = 'Generalized Kinetic Equation ' +#endif +#ifdef W3_BT0 + TNAME3 = 'Not defined ' +#endif +#ifdef W3_BT1 + TNAME3 = 'JONSWAP ' +#endif +#ifdef W3_BT4 + TNAME3 = 'SHOWEX ' +#endif +#ifdef W3_BT8 + TNAME3 = 'Muddy Bed (D & L) ' +#endif +#ifdef W3_IC1 + TNAMEI = 'Ice sink term (uniform k_i) ' +#endif +#ifdef W3_IC2 + TNAMEI = 'Ice sink term (Lui et al) ' +#endif +#ifdef W3_IC3 + TNAMEI = 'Ice sink term (Wang and Shen) ' +#endif +#ifdef W3_IC4 + TNAMEI = 'Ice sink term (empirical) ' +#endif +#ifdef W3_IC5 + TNAMEI = 'Ice sink term (eff. medium) ' +#endif +#ifdef W3_DB0 + TNAME4 = 'Not defined ' +#endif +#ifdef W3_DB1 + TNAME4 = 'Battjes and Janssen (1978) ' +#endif +#ifdef W3_TR0 + TNAME5 = 'Not defined ' +#endif +#ifdef W3_BS0 + TNAME6 = 'Not defined ' +#endif +#ifdef W3_PR0 + TNAMEP = 'No propagation ' +#endif +#ifdef W3_PR1 + TNAMEP = 'First order upstream ' +#endif +#ifdef W3_UQ + TNAMEP = '3rd order UQ scheme ' +#endif +#ifdef W3_UNO + TNAMEP = '2nd order UNO scheme ' +#endif +#ifdef W3_PR0 + TNAMEG = 'No GSE aleviation ' +#endif +#ifdef W3_PR1 + TNAMEG = 'No GSE aleviation (1up prop) ' +#endif +#ifdef W3_PR2 + TNAMEG = 'Diffusion operator ' +#endif +#ifdef W3_PR3 + TNAMEG = 'Averaging operator ' +#endif +! + FNAMEF = TNAMEF + FNAME0 = TNAME0 + FNAME1 = TNAME1 + FNAME2 = TNAME2 + FNAME3 = TNAME3 + FNAME4 = TNAME4 + FNAME5 = TNAME5 + FNAME6 = TNAME6 + FNAMEP = TNAMEP + FNAMEG = TNAMEG + FNAMEI = TNAMEI +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 2' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + FLTEST = .TRUE. +#endif +#ifdef W3_NL2 + FLSNL2 = .TRUE. +#endif +! +! test input parameters ---------------------------------------------- * +! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF +! + IF ( PRESENT(FEXT) ) THEN + TEMPXT = FEXT + ELSE + TEMPXT = 'ww3' + END IF +! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'WRITE' & + .AND. INXOUT.NE.'GRID') THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 3' + FLUSH(740+IAPROC) +#endif + WRITE = INXOUT .EQ. 'WRITE' +! +#ifdef W3_T + WRITE (NDST,9000) INXOUT, WRITE, NDSM, IGRD, TEMPXT +#endif +! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + FILEXT = TEMPXT +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! open file ---------------------------------------------------------- * +! + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) +! +!AR: ADD DEBUGFLAG WRITE(*,*) 'FILE=', FNMPRE(:J)//'mod_def.'//FILEXT(:I) + IF ( WRITE ) THEN + OPEN (NDSM,FILE=FNMPRE(:J)//'mod_def.'//FILEXT(:I), & + FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSM,FILE=FNMPRE(:J)//'mod_def.'//FILEXT(:I), & + FORM='UNFORMATTED',STATUS='OLD',ERR=800,IOSTAT=IERR) + ENDIF +! + REWIND ( NDSM ) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 5, WRITE=', WRITE + FLUSH(740+IAPROC) +#endif +! +! Dimensions and test information -------------------------------------- +! + IF ( WRITE ) THEN + WRITE (NDSM) & + IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI +! +#ifdef W3_SMC + WRITE (NDSM) NCel, NUFc, NVFc, NRLv, MRFct + WRITE (NDSM) NGLO, NARC, NBGL, NBAC, NBSMC +#endif +! + WRITE (NDSM) & + (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) +#ifdef W3_T + WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI + WRITE (NDST,9002) (NBO(I),I=0,NFBPO) + WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) +#endif + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IDTST, VERTST, NX, NY, NSEA, MTH, MK, & + NBI, NFBPO, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI +! +#ifdef W3_SMC + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NCel, NUFc, NVFc, NRLv, MRFct + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NGLO, NARC, NBGL, NBAC, NBSMC +#endif +! + NK = MK + NTH = MTH + NK2 = NK + 2 + NSPEC = NK * NTH +#ifdef W3_T + WRITE (NDST,9001) IDSTR, VERGRD, NX, NY, NSEA, NTH, NK, & + NBI, NFBPO, 9, GNAME, FNAME0, FNAME1, FNAME2, FNAME3, & + FNAME4, FNAME5, FNAME6, FNAMEP, FNAMEG, & + FNAMEF, FNAMEI +#endif +! + IF ( IDTST .NE. IDSTR ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,901) IDTST, IDSTR + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VERGRD ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,902) VERTST, VERGRD + CALL EXTCDE ( 11 ) + END IF + IF ( NFBPO .GT. 9 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,904) NFBPO, 9 + CALL EXTCDE ( 13 ) + END IF + IF ( FNAME0 .NE. TNAME0 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 0, FILEXT(:I), FNAME0, TNAME0, & + MESSAGE + CALL EXTCDE ( 14 ) + END IF + IF ( FNAME1 .NE. TNAME1 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 1, FILEXT(:I), FNAME1, TNAME1, & + MESSAGE + CALL EXTCDE ( 15 ) + END IF + IF ( FNAME2 .NE. TNAME2 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 2, FILEXT(:I), FNAME2, TNAME2, & + MESSAGE + CALL EXTCDE ( 16 ) + END IF + IF ( FNAME3 .NE. TNAME3 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 3, FILEXT(:I), FNAME3, TNAME3, & + MESSAGE + CALL EXTCDE ( 17 ) + END IF + IF ( FNAMEI .NE. TNAMEI ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 3, FILEXT(:I), FNAMEI, TNAMEI, & + MESSAGE + CALL EXTCDE ( 17 ) + END IF + IF ( FNAME4 .NE. TNAME4 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 4, FILEXT(:I), FNAME4, TNAME4, & + MESSAGE + CALL EXTCDE ( 18 ) + END IF + IF ( FNAME5 .NE. TNAME5 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 5, FILEXT(:I), FNAME5, TNAME5, & + MESSAGE + CALL EXTCDE ( 19 ) + END IF + IF ( FNAME6 .NE. TNAME6 ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) 6, FILEXT(:I), FNAME6, TNAME6, & + MESSAGE + CALL EXTCDE ( 20 ) + END IF + IF ( FNAMEP .NE. TNAMEP ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) FNAMEP, TNAMEP + CALL EXTCDE ( 22 ) + END IF + IF ( FNAMEG .NE. TNAMEG ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,907) FNAMEG, TNAMEG, MESSAGE + CALL EXTCDE ( 22 ) + END IF + IF ( FNAMEF .NE. TNAMEF ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,908) FILEXT(:I), FNAMEF, TNAMEF, MESSAGE + CALL EXTCDE ( 24 ) + END IF +! + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + (NBO(I),I=0,NFBPO), (NBO2(I),I=0,NFBPO) +#ifdef W3_T + WRITE (NDST,9002) (NBO(I),I=0,NFBPO) + WRITE (NDST,9003) (NBO2(I),I=0,NFBPO) +#endif +! + ENDIF +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 6' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +! Parameters in modules --------------------------------------------- * +! Module W3GDAT GRID +! + ALLOCATE ( MAPTMP(NY,NX) ) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7' + FLUSH(740+IAPROC) +#endif +! + IF ( WRITE ) THEN + MAPTMP = MAPSTA + 8*MAPST2 + WRITE (NDSM) & + GTYPE, FLAGLL, ICLOSE +! +! Writes different kind of information depending on grid type +! + SELECT CASE ( GTYPE ) +!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + WRITE (NDSM) & + SX, SY, X0, Y0 + CASE ( CLGTYPE ) + WRITE (NDSM) & + XGRD, YGRD + CASE (UNGTYPE) + WRITE (NDSM) & + FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & + FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & + DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & + NTRI,COUNTOT, COUNTRI, NNZ, & + B_JGS_TERMINATE_MAXITER, & + B_JGS_TERMINATE_DIFFERENCE, & + B_JGS_TERMINATE_NORM, & + B_JGS_LIMITER, & + B_JGS_BLOCK_GAUSS_SEIDEL, & + B_JGS_USE_JACOBI, & + B_JGS_MAXITER, & + B_JGS_PMIN, & + B_JGS_DIFF_THR, & + B_JGS_NORM_THR, & + B_JGS_NLEVEL, & + B_JGS_SOURCE_NONLINEAR + !Init COUNTCON to zero, it needs to be set somewhere or + !removed + COUNTCON=0 + WRITE (NDSM) & + X0, Y0, SX, SY, DXYMAX, XYB, TRIGP, TRIA, & + LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & + DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & + POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI + END SELECT !GTYPE +! + WRITE (NDSM) & + ZB, MAPTMP, MAPFS, MAPSF, TRFLAG +! +#ifdef W3_SMC + IF( GTYPE .EQ. SMCTYPE ) THEN + WRITE (NDSM) NLvCel, NLvUFc, NLvVFc + WRITE (NDSM) IJKCel, IJKUFc, IJKVFc, ISMCBP + WRITE (NDSM) ICLBAC + WRITE (NDSM) ANGARC + WRITE (NDSM) CTRNX, CTRNY, CLATF + IF ( FLTEST ) THEN + WRITE (NDSE,"(' NRLv, MRFct and NBSMC values are',3I9)") NRLv, MRFct, NBSMC + WRITE (NDSE,"(' IJKCel, IJKUFc, IJKVFc Write for',3I9)") NCel, NUFc, NVFc + WRITE (NDSE,"(' CTRNXY transparency write for 2x', I9)") NCel + ENDIF + ENDIF +#endif +! + IF ( TRFLAG .NE. 0 ) WRITE (NDSM) TRNX, TRNY + WRITE (NDSM) & + DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & + FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, FLCTH, & + FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, CTHG0S, & + STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, IICEDISP, & + ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, IICEHDISP,& + IICEDDISP, IICEFDISP, BTBETA, & + AAIRCMIN, AAIRGB + + WRITE(NDSM)GRIDSHIFT +#ifdef W3_SEC1 + WRITE (NDSM) NITERSEC1 +#endif +#ifdef W3_RTD + !! Add rotated Polat/lon and AnglD to mod_def JGLi12Jun2012 + WRITE (NDSM) PoLat, PoLon, AnglD, FLAGUNR + +#endif +!! WRITE(NDSM) & +!! COUG_2D, COUG_RAD3D, COUG_US3D + ELSE +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + GTYPE, FLAGLL, ICLOSE +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.2' + FLUSH(740+IAPROC) +#endif +!!Li IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST ) + IF (.NOT.GINIT) CALL W3DIMX ( IGRD, NX, NY, NSEA, NDSE, NDST & +#ifdef W3_SMC + , NCel, NUFc, NVFc, NRLv, NBSMC & + , NARC, NBAC, NSPEC & +#endif + ) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.3' + FLUSH(740+IAPROC) +#endif +! +! Reads different kind of information depending on grid type +! + SELECT CASE ( GTYPE ) +!!Li SMCTYPE shares info with RLGTYPE. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SX, SY, X0, Y0 + DO IX=1,NX + XGRD(:,IX) = X0 + REAL(IX-1)*SX + END DO + DO IY=1,NY + YGRD(IY,:) = Y0 + REAL(IY-1)*SY + END DO + CASE ( CLGTYPE ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + XGRD, YGRD + !Set SX, SY, X0, Y0 to large values if curvilinear grid + X0 = HUGE(X0); Y0 = HUGE(Y0) + SX = HUGE(SX); SY = HUGE(SY) + CASE (UNGTYPE) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.4' + FLUSH(740+IAPROC) +#endif + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + FSN, FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP, & + FSBCCFL, FSREFRACTION, FSFREQSHIFT, FSSOURCE, & + DO_CHANGE_WLV, SOLVERTHR_STP, CRIT_DEP_STP, & + NTRI,COUNTOT, COUNTRI, NNZ, & + B_JGS_TERMINATE_MAXITER, & + B_JGS_TERMINATE_DIFFERENCE, & + B_JGS_TERMINATE_NORM, & + B_JGS_LIMITER, & + B_JGS_BLOCK_GAUSS_SEIDEL, & + B_JGS_USE_JACOBI, & + B_JGS_MAXITER, & + B_JGS_PMIN, & + B_JGS_DIFF_THR, & + B_JGS_NORM_THR, & + B_JGS_NLEVEL, & + B_JGS_SOURCE_NONLINEAR +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.5, GUGINIT=', GUGINIT + FLUSH(740+IAPROC) +#endif + IF (.NOT. GUGINIT) THEN +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'Before call to W3DIMUG from W3IOGR' + FLUSH(740+IAPROC) +#endif + CALL W3DIMUG ( IGRD, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) + END IF +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.6' + FLUSH(740+IAPROC) +#endif + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + X0, Y0, SX, SY, DXYMAX, XYB, TRIGP, TRIA, & + LEN, IEN, ANGLE0, ANGLE, SI, MAXX, MAXY, & + DXYMAX, INDEX_CELL, CCON, COUNTCON, IE_CELL, & + POS_CELL, IOBP, IOBPA, IOBDP, IOBPD, IAA, JAA, POSI + +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.6.4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + XGRD(1,:)=XYB(:,1) + YGRD(1,:)=XYB(:,2) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.7' + FLUSH(740+IAPROC) +#endif + END SELECT !GTYPE +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.8' + FLUSH(740+IAPROC) +#endif + IF (GTYPE.NE.UNGTYPE) CALL W3GNTX ( IGRD, NDSE, NDST ) +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.9' + FLUSH(740+IAPROC) +#endif + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZB, MAPTMP, MAPFS, MAPSF, TRFLAG +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.10' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_SMC + IF( GTYPE .EQ. SMCTYPE ) THEN + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NLvCel, NLvUFc, NLvVFc + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IJKCel, IJKUFc, IJKVFc, ISMCBP + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ICLBAC + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ANGARC + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + CTRNX, CTRNY, CLATF + ENDIF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.11' + FLUSH(740+IAPROC) +#endif + MAPSTA = MOD(MAPTMP+2,8) - 2 + MAPST2 = (MAPTMP-MAPSTA) / 8 + MAPSF(:,3) = MAPSF(:,2) + (MAPSF(:,1)-1)*NY +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.12' + FLUSH(740+IAPROC) +#endif + IF ( TRFLAG .NE. 0 ) THEN + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) TRNX, TRNY + END IF +#ifdef W3_UOST + ! UOST (Unresolved Obstacles Source Term) is enabled. + ! setting TRNX, TRNY to null values + TRNX = 1 + TRNY = 1 +#endif + +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.13' + FLUSH(740+IAPROC) +#endif + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, & + FICE0, FICEN, FICEL, PFMOVE, FLDRY, FLCX, FLCY, & + FLCTH, FLCK, FLSOU, FLBPI, FLBPO, CLATS, CLATIS, & + CTHG0S, STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, & + IICEDISP, ICESCALES(1:4), CALTYPE, CMPRTRCK, IICEHFAC, & + IICEDDISP, IICEHDISP, IICEFDISP, BTBETA, & + AAIRCMIN, AAIRGB +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.14' + FLUSH(740+IAPROC) +#endif + + READ(NDSM,END=801,ERR=802,IOSTAT=IERR)GRIDSHIFT +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.15' + FLUSH(740+IAPROC) +#endif +#ifdef W3_SEC1 + READ (NDSM) NITERSEC1 +#endif +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.16' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_RTD + !! Read rotated Polat/lon and AnglD from mod_def JGLi12Jun2012 + READ (NDSM) PoLat, PoLon, AnglD, FLAGUNR + +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 7.17' + FLUSH(740+IAPROC) +#endif + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 8' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9010) GTYPE, FLAGLL, ICLOSE, SX, SY, X0, Y0, TRFLAG + WRITE (NDST,9011) 'MAPSTA' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9012) (MAPSTA(IY,IX),IX=1,MIN(NX,30)) + END DO + WRITE (NDST,9011) 'MAPST2' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9012) (MAPST2(IY,IX),IX=1,MIN(NX,30)) + END DO + WRITE (NDST,9011) 'MAPFS' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9013) (MAPFS(IY,IX),IX=1,MIN(NX,12)) + END DO + IF ( TRFLAG .NE. 0 ) THEN + WRITE (NDST,9011) 'TRNX' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9014) (TRNX(IY,IX),IX=1,MIN(NX,12)) + END DO + WRITE (NDST,9011) 'TRNY' + DO IY=MIN(NY,20), 1, -1 + WRITE (NDST,9014) (TRNY(IY,IX),IX=1,MIN(NX,12)) + END DO + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 9' + FLUSH(740+IAPROC) +#endif + DEALLOCATE ( MAPTMP ) +! +#ifdef W3_T + WRITE (NDST,9015) DTCFL, DTCFLI, DTMAX, DTMIN, & + DMIN, CTMAX, FICE0, FICEN, FICEL, PFMOVE, & + STEXU, STEYU, STEDU + WRITE (NDST,9016) FLDRY, FLCX, FLCY, FLCTH, FLCK, & + FLSOU, FLBPI, FLBPO + WRITE (NDST,9017) (CLATS(ISEA),ISEA=1,1), & + (CLATIS(ISEA),ISEA=1,1), (CTHG0S(IY),ISEA=1,1) +#endif +! +! Spectral parameters ------------------------------------------------ * +! Module W3GDATMD SGRD +! + IF ( WRITE ) THEN + WRITE (NDSM) & + MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & + XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & + FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE + ELSE + IF (.NOT.SINIT) CALL W3DIMS ( IGRD, NK, NTH, NDSE, NDST ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + MAPWN, MAPTH, DTH, TH, ESIN, ECOS, ES2, ESC, EC2, & + XFR, FR1, SIG, SIG2, DSIP, DSII, DDEN, DDEN2, FTE, & + FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE + END IF + +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 10' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9030) (MAPWN(I),I=1,8), (MAPTH(I),I=1,8), DTH*RADE, & + (TH(I)*RADE,I=1,4), (ESIN(I),I=1,4), (ECOS(I),I=1,4), & + XFR, SIG(1)*TPIINV, SIG(NK)*TPIINV, FTE, FTF, FTWN, FTTR, & + FTWL, FACTI1, FACTI2, FACHFA, FACHFE +#endif +! +! +! Output flags for 3D parameters ------------------------------------- * +! Module W3GDATMD + IF ( WRITE ) THEN + WRITE (NDSM) & + E3DF, P2MSF, US3DF,USSPF, USSP_WN + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + E3DF, P2MSF, US3DF,USSPF, USSP_WN + END IF + + IF ( INXOUT .EQ. 'GRID' ) THEN + CLOSE (NDSM) + RETURN + END IF +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 11' + FLUSH(740+IAPROC) +#endif +! +! Parameters for output boundary points ------------------------------ * +! Module W3ODATMD OUT5 +! + IF ( WRITE ) THEN + WRITE (NDSM) & + XBPO, YBPO, RDBPO, IPBPO, ISBPO + ELSE + CALL W3DMO5 ( IGRD, NDSE, NDST, 2 ) + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + XBPO, YBPO, RDBPO, IPBPO, ISBPO + END IF +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 12' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9020) + DO I=1, NFBPO + WRITE (NDST,9021) I + DO J=NBO(I-1)+1,NBO(I) + WRITE (NDST,9022) J-NBO(I-1), (IPBPO(J,K),K=1,4), & + (RDBPO(J,K),K=1,4) + END DO + WRITE (NDST,9023) (ISBPO(J),J=NBO2(I-1)+1,NBO2(I)) + END DO +#endif +! +! Parameters for spectral partitioning ------------------------------ * +! Module W3ODATMD OUT6 +! + IF ( WRITE ) THEN + WRITE (NDSM) & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & + PTMETH, PTFCUT + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL, & + PTMETH, PTFCUT + END IF +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 13' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9025) IHMAX, HSPMIN, WSMULT, WSCUT, FLCOMB, NOSWLL +#endif +! +! Numerical parameters ----------------------------------------------- * +! Module W3GDATMD NPAR +! + IF ( WRITE ) THEN + WRITE (NDSM) & + FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & + FFACBERG, DELAB, FWTABLE +#ifdef W3_RWND + WRITE (NDSM) & + RWINDC +#endif +#ifdef W3_WCOR + WRITE (NDSM) & + WWCOR +#endif +#ifdef W3_REF1 + WRITE (NDSM) & + RREF, REFPARS, REFLC, REFLD +#endif +#ifdef W3_IG1 + WRITE (NDSM) & + IGPARS(1:12) +#endif +#ifdef W3_IC2 + WRITE (NDSM) & + IC2PARS(1:8) +#endif +#ifdef W3_IC3 + WRITE (NDSM) & + IC3PARS +#endif +#ifdef W3_IC4 + WRITE (NDSM) & + IC4PARS,IC4_KI,IC4_FC +#endif +#ifdef W3_IC5 + WRITE (NDSM) & + IC5PARS +#endif + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX, & + FFACBERG, DELAB, FWTABLE +#ifdef W3_RWND + READ (NDSM) & + RWINDC +#endif +#ifdef W3_WCOR + READ (NDSM) & + WWCOR +#endif +#ifdef W3_REF1 + READ (NDSM) & + RREF, REFPARS, REFLC, REFLD +#endif +#ifdef W3_IG1 + READ (NDSM) & + IGPARS(1:12) +#endif +#ifdef W3_IC2 + READ (NDSM) & + IC2PARS(1:8) +#endif +#ifdef W3_IC3 + READ (NDSM) & + IC3PARS +#endif +#ifdef W3_IC4 + READ (NDSM) & + IC4PARS,IC4_KI,IC4_FC +#endif +#ifdef W3_IC5 + READ (NDSM) & + IC5PARS +#endif + END IF +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 14' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9040) FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, & + FACSD, FHMAX +#endif +! +! Source term parameters --------------------------------------------- * +! Module W3GDATMD SFLP +! Module W3GDATMD SLNP +! Module W3GDATMD SRCP +! Module W3GDATMD SNLP +! Module W3GDATMD SBTP +! +#ifdef W3_FLX2 + IF ( WRITE ) THEN + WRITE (NDSM) NITTIN, CINXSI + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) NITTIN, CINXSI + END IF +#endif +! +#ifdef W3_FLX2 + IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CINXSI +#endif +! +#ifdef W3_FLX3 + IF ( WRITE ) THEN + WRITE (NDSM) & + NITTIN, CINXSI, CD_MAX, CAP_ID + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + NITTIN, CINXSI, CD_MAX, CAP_ID + END IF +#endif +! +#ifdef W3_FLX3 + IF ( FLTEST ) WRITE (NDST,9048) NITTIN, CAP_ID, CINXSI, CD_MAX +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 15' + FLUSH(740+IAPROC) +#endif +#ifdef W3_FLX4 + IF ( WRITE ) THEN + WRITE (NDSM) FLX4A0 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) FLX4A0 + END IF +#endif +! +! +#ifdef W3_LN1 + IF ( WRITE ) THEN + WRITE (NDSM) SLNC1, FSPM, FSHF + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SLNC1, FSPM, FSHF + END IF +#endif +! +#ifdef W3_LN1 + IF ( FLTEST ) WRITE (NDST,9049) SLNC1, FSPM, FSHF +#endif +! +#ifdef W3_ST1 + IF ( WRITE ) THEN + WRITE (NDSM) SINC1, SDSC1 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SINC1, SDSC1 + END IF +#endif +! +#ifdef W3_ST1 + IF ( FLTEST ) WRITE (NDST,9050) SINC1, SDSC1 +#endif +! +#ifdef W3_ST2 + IF ( WRITE ) THEN + WRITE (NDSM) & + ZWIND, FSWELL, & + SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZWIND, FSWELL, & + SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS, & + CDSA0, CDSA1, CDSA2, SDSALN, & + CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 + IF ( .NOT. FLINP ) CALL INPTAB + FLINP = .TRUE. + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 16' + FLUSH(740+IAPROC) +#endif +#ifdef W3_ST2 + IF ( FLTEST ) WRITE (NDST,9050) & + ZWIND, FSWELL, CDSA0, CDSA1, CDSA2, & + SDSALN, CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, & + XF2, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS +#endif +! +#ifdef W3_ST3 + IF ( WRITE ) THEN + WRITE (NDSM) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, & + DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + SSWELLF, SSDSC1, WWNMEANP, WWNMEANPTAIL, SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, & + DDELTA1, DDELTA2, SSTXFTF, SSTXFTWN, & + FFXPM, FFXFM + IF ( .NOT. FLINP ) THEN + CALL INSIN3 + FLINP = .TRUE. + END IF + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 17' + FLUSH(740+IAPROC) +#endif +#ifdef W3_ST4 + IF ( WRITE ) THEN + CALL INSIN4(.TRUE.) + WRITE (NDSM) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & + ZZ0RAT, SSDSC, & + SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & + SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & + SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & + SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & + SSDSHCK, DELUST, DELTAIL, DELTAUW, & + DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & + IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & + DIKCUMUL, CUMULW + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ZZWND, AALPHA, ZZ0MAX, BBETA, SSINTHP, ZZALP, & + TTAUWSHELTER, SSWELLFPAR, SSWELLF, SSINBR, & + ZZ0RAT, SSDSC, & + SSDSISO, SSDSBR, SSDSBT, SSDSBM, SSDSP, & + SSDSCOS, SSDSDTH, WWNMEANP, WWNMEANPTAIL,SSTXFTF,& + SSTXFTFTAIL, SSTXFTWN, SSTXFTF, SSTXFTWN, & + SSDSBRF1, SSDSBRF2, SSDSBRFDF,SSDSBCK, SSDSABK, & + SSDSPBK, SSDSBINT, FFXPM, FFXFM, FFXFA, & + SSDSHCK, DELUST, DELTAIL, DELTAUW, & + DELU, DELALP, TAUT, TAUHFT, TAUHFT2, & + IKTAB, DCKI, QBI, SATINDICES, SATWEIGHTS, & + DIKCUMUL, CUMULW + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 18' + FLUSH(740+IAPROC) +#endif +#ifdef W3_ST6 + IF ( WRITE ) THEN + WRITE (NDSM) SIN6A0, SDS6ET, SDS6A1, SDS6A2, & + SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& + SIN6WS, SIN6FC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SIN6A0, SDS6ET, SDS6A1, SDS6A2, & + SDS6P1, SDS6P2, SWL6S6, SWL6B1, SWL6CSTB1,& + SIN6WS, SIN6FC + END IF +#endif +! +! ... Nonlinear interactions +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 19' + FLUSH(740+IAPROC) +#endif +#ifdef W3_NL1 + IF ( WRITE ) THEN + WRITE (NDSM) & + SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 + END IF +#endif +! +#ifdef W3_NL1 + IF ( FLTEST ) WRITE (NDST,9051) SNLC1, LAM, & + KDCON, KDMN, SNLS1, SNLS2, SNLS3 +#endif +! +#ifdef W3_NL2 + IF ( WRITE ) THEN + WRITE (NDSM) IQTPE, NLTAIL, NDPTHS + WRITE (NDSM) DPTHNL + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + IQTPE, NLTAIL, NDPTHS + ALLOCATE ( MPARS(IGRD)%SNLPS%DPTHNL(NDPTHS) ) + DPTHNL => MPARS(IGRD)%SNLPS%DPTHNL + PINIT = .TRUE. + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) DPTHNL + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 20' + FLUSH(740+IAPROC) +#endif +#ifdef W3_NL2 + IF ( FLTEST ) WRITE (NDST,9051) IQTPE, NLTAIL, NDPTHS + IF ( FLTEST ) WRITE (NDST,9151) DPTHNL +#endif +! +#ifdef W3_NL3 + IF ( WRITE ) THEN + WRITE (NDSM) SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS + WRITE (NDSM) SNLL(1:SNLNQ), SNLM(1:SNLNQ), & + SNLT(1:SNLNQ), SNLCD(1:SNLNQ), & + SNLCS(1:SNLNQ) + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLNQ, SNLMSC, SNLNSC, SNLSFD, SNLSFS + ALLOCATE ( MPARS(IGRD)%SNLPS%SNLL(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLM(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLT(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLCD(SNLNQ), & + MPARS(IGRD)%SNLPS%SNLCS(SNLNQ) ) + SNLL => MPARS(IGRD)%SNLPS%SNLL + SNLM => MPARS(IGRD)%SNLPS%SNLM + SNLT => MPARS(IGRD)%SNLPS%SNLT + SNLCD => MPARS(IGRD)%SNLPS%SNLCD + SNLCS => MPARS(IGRD)%SNLPS%SNLCS + PINIT = .TRUE. + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SNLL, SNLM, SNLT, SNLCD, SNLCS + END IF +#endif +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 21' + FLUSH(740+IAPROC) +#endif +#ifdef W3_NL3 + IF ( FLTEST ) WRITE (NDST,9051) SNLNQ, SNLMSC, SNLNSC, & + SNLSFD, SNLSFS + IF ( FLTEST ) THEN + DO I=1, SNLNQ + WRITE (NDST,9151) SNLL(I), SNLM(I), SNLT(I), & + SNLCD(I), SNLCS(I) + END DO + END IF +#endif +! +#ifdef W3_NL4 + IF ( WRITE ) THEN + WRITE (NDSM) ITSA, IALT + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + ITSA, IALT + END IF +#endif +! +#ifdef W3_NL4 + IF ( FLTEST ) WRITE (NDST,9051) ITSA, IALT +#endif +! +! (QL: INXOUT = Grid option ?) +#ifdef W3_NL5 + IF (WRITE) THEN + CALL INSNL5 + WRITE (NDSM) QR5DPT, QR5OML, QI5DIS, QI5KEV, & + QI5NNZ, QI5IPL, QI5PMX + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + QR5DPT, QR5OML, QI5DIS, QI5KEV, & + QI5NNZ, QI5IPL, QI5PMX + END IF + IF ( FLTEST ) WRITE (NDST,9051) QR5DPT, QR5OML, QI5DIS, & + QI5KEV, QI5NNZ, QI5IPL, & + QI5PMX +#endif +! +#ifdef W3_NLS + IF ( WRITE ) THEN + WRITE (NDSM) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 + END IF +#endif +! +#ifdef W3_NLS + IF ( FLTEST ) WRITE (NDST,9251) & + CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 +#endif +! +#ifdef W3_NL1 + IF ( .NOT. WRITE ) CALL INSNL1 ( IGRD ) +#endif +#ifdef W3_NL3 + IF ( .NOT. WRITE ) CALL INSNL3 +#endif +#ifdef W3_NLS + IF ( .NOT. WRITE ) CALL INSNLS +#endif +! +! Layered barriers needed for file management in xnl_init +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 22' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLSNL2 .AND. .NOT.WRITE ) THEN + DO IP=1, IAPROC-1 + CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) + END DO + END IF +#endif +#ifdef W3_NL2 + IF ( .NOT. WRITE ) CALL INSNL2 +#endif +#ifdef W3_MPI + IF ( FLSNL2 .AND. .NOT.WRITE ) THEN + DO IP=IAPROC, NAPROC-1 + CALL MPI_BARRIER ( MPI_COMM_WAVE, IERR_MPI ) + END DO + END IF +#endif +! +! ... Bottom friction ... +! +#ifdef W3_BT1 + IF ( WRITE ) THEN + WRITE (NDSM) SBTC1 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) SBTC1 + END IF +#endif +! +#ifdef W3_BT1 + IF ( FLTEST ) WRITE (NDST,9052) SBTC1 +#endif +! +! +#ifdef W3_BT4 + IF ( WRITE ) THEN + WRITE (NDSM) & + SBTCX, SED_D50, SED_PSIC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SBTCX, SED_D50, SED_PSIC + END IF +#endif +! +! ... Depth induced breaking ... +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 23' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DB1 + IF ( WRITE ) THEN + WRITE (NDSM) & + SDBC1, SDBC2, FDONLY + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + SDBC1, SDBC2, FDONLY + END IF +#endif +! +#ifdef W3_DB1 + IF ( FLTEST ) WRITE (NDST,9053) SDBC1, SDBC2, FDONLY +#endif + +#ifdef W3_UOST + IF ( WRITE ) THEN + WRITE (NDSM) UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW + CALL UOST_INITGRID(IGRD, UOSTFILELOCAL, UOSTFILESHADOW, & + UOSTFACTORLOCAL, UOSTFACTORSHADOW) +#endif + +#ifdef W3_UOST + END IF +#endif + +! +#ifdef W3_IS1 + IF ( WRITE ) THEN + WRITE (NDSM) IS1C1, IS1C2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS1C1, IS1C2 + END IF +#endif +! +#ifdef W3_IS2 + IF ( WRITE ) THEN + WRITE (NDSM) IS2PARS + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) IS2PARS + IF ( .NOT. FLIS ) THEN + CALL INSIS2 + FLIS = .TRUE. + END IF + END IF +#endif +! +! Propagation scheme ------------------------------------------------- * +! Module W3GDATMD PROP +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 24' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_PR2 + IF ( WRITE ) THEN + WRITE (NDSM) DTME, CLATMN + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTME, CLATMN + END IF +#endif +! +#ifdef W3_PR2 + IF ( FLTEST ) WRITE (NDST,9060) DTME, CLATMN +#endif +! +#ifdef W3_PR3 + IF ( WRITE ) THEN + WRITE (NDSM) WDCG, WDTH + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + WDCG, WDTH + END IF +#endif +! +#ifdef W3_PR3 + IF ( FLTEST ) WRITE (NDST,9060) WDCG, WDTH +#endif +! +#ifdef W3_SMC + IF ( WRITE ) THEN + WRITE(NDSM) DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + DTMS, Refran, FUNO3, FVERG, FSWND, ARCTC + END IF +#endif +! +#ifdef W3_SMC + IF ( FLTEST ) WRITE (NDST,9260) DTMS, Refran +#endif +! +#ifdef W3_FLD1 + IF ( WRITE ) THEN + WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + END IF +#endif +#ifdef W3_FLD2 + IF ( WRITE ) THEN + WRITE (NDSM) TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + ELSE + READ (NDSM,END=801,ERR=802,IOSTAT=IERR) & + TAIL_ID, TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + END IF +#endif +! +! Interpolation tables ( fill locally ) ----------------------------- * +! Module W3DISPMD +! +#ifdef W3_DEBUGIOGR + WRITE(740+IAPROC,*) 'W3IOGR, step 25' + FLUSH(740+IAPROC) +#endif + IF ( .NOT.WRITE .AND. .NOT.FLDISP ) THEN +#ifdef W3_T + WRITE (NDST,9070) +#endif + CALL DISTAB + FLDISP = .TRUE. + END IF +! + CLOSE ( NDSM ) + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WIOGR SECTION 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + RETURN +! +! Escape locations read errors --------------------------------------- * +! + 800 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) FILEXT(:I), IERR + CALL EXTCDE ( 50 ) +! + 801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) FILEXT(:I) + CALL EXTCDE ( 51 ) +! + 802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) FILEXT(:I), IERR, & + MESSAGE + CALL EXTCDE ( 52 ) +! +! Formats +! + 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL INXOUT VALUE: ',A/) + 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) + 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL VERGRD, READ : ',A/ & + ' CHECK : ',A/) + 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' ILEGAL NFBPO READ : ',I8/ & + ' CHECK : ',I8/) + 905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED SOURCE TERM IDENTIFIER',I2/ & + ' IN mod_def.',A,' FILE : ',A/ & + ' EXPECTED FROM switch FILE : ',A,/ & + 5(A,/) /) +! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) + 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED PROPAGATION SCHEME IDENTIFIER'/ & + ' IN FILE :',A/ & + ' EXPECTED :',A/ & + ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) + 907 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED GSE ALEVIATION IDENTIFIER'/ & + ' IN FILE :',A/ & + ' EXPECTED :',A/ & + , 5(A,/) /) +! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) + 908 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR :'/ & + ' UNEXPECTED FLUX PARAMETERIZATION IDENTIFIER'/ & + ' IN mod_def.',A,' :',A/ & + ' EXPECTED :',A/ & + , 5(A,/) /) +! ' CHECK CONSISTENCY OF SWITCHES IN PROGRAMS'/) +! + 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & + ' ERROR IN OPENING mod_def.',A,' FILE'/ & + ' IOSTAT =',I5/) + 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/ & + ' PREMATURE END OF mod_def.',A,' FILE'/) + 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOGR : '/, & + ' ERROR IN READING FROM mod_def.',A,' FILE'/ & + ' IOSTAT =',I5, & + 5(A,/) /) +! +#ifdef W3_T + 9000 FORMAT (' TEST W3IOGR : INXOUT = ',A,', WRITE = ',L1, & + ', UNIT =',I3,', IGRD =',I3,', FEXT = ',A) + 9001 FORMAT (' TEST W3IOGR : TEST PARAMETERS :'/ & + ' IDSTR : ',A/ & + ' VERGRD : ',A/ & + ' NX/Y/SEA : ',3I10/ & + ' NTH,NK : ',2I10/ & + ' NBI : ',I10/ & + ' NFBPO : ',2I10/ & + ' GNAME : ',A/ & + ' FNAME0 : ',A/ & + ' FNAME1 : ',A/ & + ' FNAME2 : ',A/ & + ' FNAME3 : ',A/ & + ' FNAME4 : ',A/ & + ' FNAME5 : ',A/ & + ' FNAME6 : ',A/ & + ' FNAMEP : ',A/ & + ' FNAMEG : ',A/ & + ' FNAMEF : ',A/ & + ' FNAMEI : ',A) + 9002 FORMAT (' NBO : ',10I5) + 9003 FORMAT (' NBO2 : ',10I5) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3IOGR : MODULE W3GDATMD GRID'/ & + ' GTYPE : ',I9/ & + ' FLAGLL : ',L9/ & + ' ICLOSE : ',I9/ & + ' SX, SY : ',2E10.3/ & + ' X0, Y0 : ',2E10.3/ & + ' TRFLAG : ',I9) + 9011 FORMAT (' LOWER LEFT PART OF ',A) + 9012 FORMAT (' ',4X,30I2) + 9013 FORMAT (' ',12I6) + 9014 FORMAT (' ',12F6.2) + 9015 FORMAT (' STEPS : ',4F8.1/ & + ' DEPTH : ',F8.1,F10.3/ & + ' FICE0/N: ',F9.2,F8.2/ & + ' FICEL : ',F9.1 / & + ' PFMOVE : ',F9.2 / & + ' STEXU : ',F9.2 / & + ' STEYU : ',F9.2 / & + ' STEDU : ',F9.2) +#endif +! +#ifdef W3_T + 9016 FORMAT (' FLAGS : ',8L2) + 9017 FORMAT (' CLATS : ',3F8.3,' ...'/ & + ' CLATIS : ',3F8.3,' ...'/ & + ' CTHG0S : ',3E11.3,' ...') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT5') + 9021 FORMAT (' INTERPOLATION DATA : FILE ',I1) + 9022 FORMAT (' ',I5,2X,4I4,2X,4F5.2) + 9023 FORMAT (' ',10I7) + 9025 FORMAT (' TEST W3IOGR : MODULE W3ODATMD OUT6'/ & + ' PARTITIONING DATA :',I5,3E10.3,L4,2X,I4) +#endif +! +#ifdef W3_T + 9030 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SGRD'/ & + ' MAPWN : ',8I4,' ...'/ & + ' MAPTH : ',8I4,' ...'/ & + ' DTH : ',F6.1/ & + ' TH : ',4F6.1,' ...'/ & + ' ESIN : ',4F6.3,' ...'/ & + ' ECOS : ',4F6.3,' ...'/ & + ' XFR : ',F6.3/ & + ' FR : ',F6.3,' ...',F6.3/ & + ' FACs : ',6E10.3/ & + ' ',3E10.3) +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3IOGR : MODULE W3GDATMD NPAR'/ & + ' FACs : ',5E10.3/ & + ' ',4E10.3) +#endif +! +#ifdef W3_FLX2 + 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & + ' FLUXES : ',I5,3X,E10.3) +#endif +#ifdef W3_FLX3 + 9048 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SFLP'/ & + ' FLUXES : ',2I5,3X,2E10.3) +#endif +! +#ifdef W3_LN1 + 9049 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SLNP'/ & + ' INPUT : ',3E10.3) +#endif +! +#ifdef W3_ST1 + 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & + ' INPUT : ',E10.3/ & + ' DISSIP : ',E10.3) +#endif +#ifdef W3_ST2 + 9050 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SRCP'/ & + ' INPUT : ',2E10.3/ & + ' DISSIP : ',4E10.3/ & + ' ',5E10.3/ & + ' ',3E10.3/ & + ' STAB2 : ',6E10.3) +#endif +! +#ifdef W3_NL1 + 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',2E10.3/ & + ' ',5E10.3) +#endif +! +#ifdef W3_NL2 + 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,F5.1,I4) + 9151 FORMAT (' ',5F7.1) +#endif +! +#ifdef W3_NL3 + 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,4F8.3) + 9151 FORMAT (' ',2F8.3,F6.1,2E12.4) +#endif +! +#ifdef W3_NL4 + 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ',I4,I4) +#endif +! +#ifdef W3_NL5 + 9051 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP'/ & + ' DATA : ', F7.1, F8.2, 2I2.1, I12, 2I2.1) +#endif +! +#ifdef W3_NLS + 9251 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SNLP (NLS)'/ & + ' DATA : ',F8.3,E12.4,4F8.3) +#endif +! +#ifdef W3_BT1 + 9052 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SBTP'/ & + ' DATA : ',E10.3) +#endif +! +#ifdef W3_DB1 + 9053 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SDBP'/ & + ' DATA : ',2E10.3,L4) +#endif +! +#ifdef W3_PR2 + 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & + ' DATA : ',2E10.3) +#endif +! +#ifdef W3_PR3 + 9060 FORMAT (' TEST W3IOGR : MODULE W3GDATMD PROP'/ & + ' DATA : ',2F6.2) +#endif +! +#ifdef W3_SMC + 9260 FORMAT (' TEST W3IOGR : MODULE W3GDATMD SMCG'/ & + ' DATA : ',3E10.3) +#endif +! +#ifdef W3_T + 9070 FORMAT (' TEST W3IOGR : DISPERSION INTEPOLATION TABLES') +#endif +!/ +!/ End of W3IOGR ----------------------------------------------------- / +!/ + END SUBROUTINE W3IOGR +!/ +!/ End of module W3IOGRMD -------------------------------------------- / +!/ + END MODULE W3IOGRMD diff --git a/model/ftn/w3iopomd.ftn b/model/src/w3iopomd.F90 similarity index 70% rename from model/ftn/w3iopomd.ftn rename to model/src/w3iopomd.F90 index 73accf507..072ab5ce1 100644 --- a/model/ftn/w3iopomd.ftn +++ b/model/src/w3iopomd.F90 @@ -215,14 +215,18 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ICLOSE,ICLOSE_NONE,ICLOSE_SMPL,ICLOSE_TRPL, & MAPSTA, MAPFS, FILEXT, ZB, TRNX, TRNY USE W3GDATMD, ONLY: XYB, TRIGP,MAXX, MAXY, DXYMAX -!/RTD !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 -!/RTD USE W3GDATMD, ONLY: PoLat, PoLon, FLAGUNR -!/RTD USE W3SERVMD, ONLY: W3LLTOEQ +#ifdef W3_RTD + !! Use rotated N-Pole lat/lon and conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: PoLat, PoLon, FLAGUNR + USE W3SERVMD, ONLY: W3LLTOEQ +#endif USE W3ODATMD, ONLY: W3DMO2 USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR, NAPOUT, SCREEN, & NOPTS, PTLOC, PTNME, GRDID, IPTINT, PTIFAC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TRIAMD ! IMPLICIT NONE @@ -240,29 +244,43 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) LOGICAL :: INGRID INTEGER :: IPT, J, K INTEGER :: IX1, IY1, IXS, IYS -!/S INTEGER, SAVE :: IENT = 0 -!/O7a INTEGER :: IX0, IXN, IY0, IYN, NNX, & -!/O7a KX, KY, JX, IIX, IX2, IY2, IS1 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_O7a + INTEGER :: IX0, IXN, IY0, IYN, NNX, & + KX, KY, JX, IIX, IX2, IY2, IS1 +#endif INTEGER :: IX(4), IY(4) ! Indices of points used in interp. REAL :: RD(4) ! Interpolation coefficient -!/O7a REAL :: RD1, RD2, RDTOT, ZBOX(4), DEPTH +#ifdef W3_O7a + REAL :: RD1, RD2, RDTOT, ZBOX(4), DEPTH +#endif REAL, PARAMETER :: ACC = 0.05 REAL :: FACTOR INTEGER :: ITOUT ! Triangle index in unstructured grids -!/O7a CHARACTER(LEN=1) :: SEA(5), LND(5), OUT(5) -!/O7a CHARACTER(LEN=9) :: PARTS -!/O7a CHARACTER(LEN=1), ALLOCATABLE :: STRING(:), LINE1(:), LINE2(:) -! -!/O7a DATA SEA / ' ', 's', 'e', 'a', ' ' / -!/O7a DATA LND / ' ', 'l', 'n', 'd', ' ' / -!/O7a DATA OUT / ' ', 'x', 'x', 'x', ' ' / +#ifdef W3_O7a + CHARACTER(LEN=1) :: SEA(5), LND(5), OUT(5) + CHARACTER(LEN=9) :: PARTS + CHARACTER(LEN=1), ALLOCATABLE :: STRING(:), LINE1(:), LINE2(:) +#endif +! +#ifdef W3_O7a + DATA SEA / ' ', 's', 'e', 'a', ' ' / + DATA LND / ' ', 'l', 'n', 'd', ' ' / + DATA OUT / ' ', 'x', 'x', 'x', ' ' / +#endif !/ -!/RTD !! Declare a few temporary variables for rotated grid. JGLi12Jun2012 -!/RTD REAL, ALLOCATABLE :: EquLon(:),EquLat(:),StdLon(:),StdLat(:),AnglPT(:) +#ifdef W3_RTD + !! Declare a few temporary variables for rotated grid. JGLi12Jun2012 + REAL, ALLOCATABLE :: EquLon(:),EquLat(:),StdLon(:),StdLat(:),AnglPT(:) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOPP') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOPP') +#endif ! IF ( FLAGLL ) THEN FACTOR = 1. @@ -275,19 +293,21 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ! NOPTS = 0 ! -!/RTD !! Convert standard lon/lat to rotated lon/lat JGLi12Jun2012 -!/RTD ALLOCATE( EquLon(NPT), EquLat(NPT), & -!/RTD & StdLon(NPT), StdLat(NPT), AnglPT(NPT) ) -!/RTD -!/RTD StdLon = XPT -!/RTD StdLat = YPT -!/RTD -!/RTD CALL W3LLTOEQ ( StdLat, StdLon, EquLat, EquLon, & -!/RTD & AnglPT, PoLat, PoLon, NPT ) -!/RTD -!/RTD XPT = EquLon -!/RTD YPT = EquLat -!/RTD +#ifdef W3_RTD + !! Convert standard lon/lat to rotated lon/lat JGLi12Jun2012 + ALLOCATE( EquLon(NPT), EquLat(NPT), & + & StdLon(NPT), StdLat(NPT), AnglPT(NPT) ) + + StdLon = XPT + StdLat = YPT + + CALL W3LLTOEQ ( StdLat, StdLon, EquLat, EquLon, & + & AnglPT, PoLat, PoLon, NPT ) + + XPT = EquLon + YPT = EquLat + +#endif ! ! Removed by F.A. 2011/04/04 /T CALL W3GSUP( GSU, NDST ) ! @@ -295,11 +315,15 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ! DO IPT=1, NPT ! -!/T WRITE (NDST,9010) IPT, XPT(IPT), YPT(IPT), PNAMES(IPT) +#ifdef W3_T + WRITE (NDST,9010) IPT, XPT(IPT), YPT(IPT), PNAMES(IPT) +#endif ! -!/RTD !! Need to wrap rotated Elon values greater than X0. JGLi12Jun2012 -!/RTD XPT(IPT) = MOD( EquLon(IPT)+360.0, 360.0 ) -!/RTD IF( XPT(IPT) .LT. X0 ) XPT(IPT) = XPT(IPT) + 360.0 +#ifdef W3_RTD + !! Need to wrap rotated Elon values greater than X0. JGLi12Jun2012 + XPT(IPT) = MOD( EquLon(IPT)+360.0, 360.0 ) + IF( XPT(IPT) .LT. X0 ) XPT(IPT) = XPT(IPT) + 360.0 +#endif ! ! Check if point within grid and compute interpolation weights ! @@ -321,9 +345,11 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) CYCLE END IF ! -!/T DO K = 1,4 -!/T WRITE (NDST,9012) IX(K), IY(K), RD(K) -!/T END DO +#ifdef W3_T + DO K = 1,4 + WRITE (NDST,9012) IX(K), IY(K), RD(K) + END DO +#endif ! ! Check if point not on land ! @@ -347,10 +373,12 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ! PTLOC (1,NOPTS) = XPT(IPT) PTLOC (2,NOPTS) = YPT(IPT) -!/RTD !! Store the standard lon/lat in PTLOC for output purpose, assuming -!/RTD !! they are not used for any inside calculation. JGLi12Jun2012 -!/RTD PTLOC (1,NOPTS) = StdLon(IPT) -!/RTD PTLOC (2,NOPTS) = StdLat(IPT) +#ifdef W3_RTD + !! Store the standard lon/lat in PTLOC for output purpose, assuming + !! they are not used for any inside calculation. JGLi12Jun2012 + PTLOC (1,NOPTS) = StdLon(IPT) + PTLOC (2,NOPTS) = StdLat(IPT) +#endif ! DO K = 1,4 IPTINT(1,K,NOPTS) = IX(K) @@ -362,147 +390,181 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ! END DO ! End loop over output points (IPT). ! -!/RTD DEALLOCATE( EquLon, EquLat, StdLon, StdLat, AnglPT ) +#ifdef W3_RTD + DEALLOCATE( EquLon, EquLat, StdLon, StdLat, AnglPT ) +#endif ! ! Diagnostic output ! -!/O7a IF ( IAPROC .EQ. NAPOUT ) THEN -!/O7a WRITE (SCREEN,940) NOPTS -!/O7a DO J=1, NOPTS -! -!/O7a WRITE (SCREEN,941) PTNME(J), PTLOC(:,J)*FACTOR -!/O7a IX(:) = IPTINT(1,:,J) -!/O7a IY(:) = IPTINT(2,:,J) -!/O7a RD(:) = PTIFAC(:,J) -!/O7a WRITE (SCREEN,942) (IX(K),IY(K),RD(K),K=1,4) -! -!/O7a ZBOX = 0. -!/O7a RDTOT = 0. -!/O7a DO K = 1,4 -!/O7a IF ( MAPFS(IY(K),IX(K)) .GT. 0 ) THEN -!/O7a ZBOX(K) = ZB(IX(K)) -!/O7a RDTOT = RDTOT + RD(K) -!/O7a END IF -!/O7a END DO -!/O7a RDTOT = MAX ( 1.E-7 , RDTOT ) -! -!/O7a DEPTH = - ( RD(1)*ZBOX(1) + & -!/O7a RD(2)*ZBOX(2) + & -!/O7a RD(3)*ZBOX(3) + & -!/O7a RD(4)*ZBOX(4) ) / RDTOT -!/O7a WRITE (SCREEN,943) DEPTH -! -!/O7a ! *** implementation of O7a option with curvilinear grids is incomplete *** -! -!/O7a IF ( RD1 .LT. 0.05 ) IX2 = IX1 -!/O7a IF ( RD1 .GT. 0.95 ) IX1 = IX2 -!/O7a IF ( RD2 .LT. 0.05 ) IY2 = IY1 -!/O7a IF ( RD2 .GT. 0.95 ) IY1 = IY2 -!/O7a IX0 = IX1 - 1 -!/O7a IXN = IX2 + 1 -!/O7a IY0 = MAX ( 1 , IY1 - 1 ) -!/O7a IYN = MIN ( IY2 + 1 , NY ) -!/O7a NNX = 13 * ( IXN - IX0 + 1 ) -! -!/O7a ALLOCATE ( STRING(NNX), LINE1(NNX), LINE2(NNX) ) -!/O7a DO KX=1, NNX -!/O7a LINE1(KX) = ' ' -!/O7a LINE2(KX) = '-' -!/O7a END DO -!/O7a DO KX=7, NNX, 13 -!/O7a LINE1(KX) = '|' -!/O7a LINE2(KX) = '+' -!/O7a END DO -! -!/O7a IF ( ICLOSE.NE.ICLOSE_NONE ) THEN -!/O7a WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) -!/O7a ELSE -!/O7a WRITE (SCREEN,945) (KX,KX=IX0,IXN) -!/O7a END IF -!/O7a WRITE (SCREEN,946) LINE1 -! -!/O7a DO KY=IYN, IY0, -1 -! -!/O7a STRING = LINE1 -!/O7a DO KX=IX0, IXN -!/O7a IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN -!/O7a IIX = 1 + MOD(KX-1+NX,NX) -!/O7a IS1 = MAPFS(KY,IIX) -!/O7a IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN -!/O7a WRITE (PARTS,'(F8.1,1X)') -ZB(IS1) -!/O7a NNX = 2 + (KX-IX0)*13 -!/O7a DO JX=1, 9 -!/O7a STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) -!/O7a END DO -!/O7a ENDIF -!/O7a END IF -!/O7a END DO -!/O7a WRITE (SCREEN,946) STRING -! -!/O7a STRING = LINE2 -!/O7a DO KX=IX0, IXN -!/O7a NNX = 5 + (KX-IX0)*13 -!/O7a IF ( ICLOSE.EQ.ICLOSE_NONE .AND. (KX.LT.1.OR.KX.GT.NX) ) THEN -!/O7a STRING(NNX:NNX+4) = OUT -!/O7a ELSE -!/O7a IIX = 1 + MOD(KX-1+NX,NX) -!/O7a IF ( MAPSTA(KY,IIX) .EQ. 0 ) THEN -!/O7a STRING(NNX:NNX+4) = LND -!/O7a ELSE -!/O7a STRING(NNX:NNX+4) = SEA -!/O7a END IF -!/O7a END IF -!/O7a END DO -!/O7a WRITE (SCREEN,947) KY, STRING -! -!/O7a STRING = LINE1 -!/O7a DO KX=IX0, IXN -!/O7a IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN -!/O7a IS1 = MAPFS(KY,KX) -!/O7a IIX = 1 + MOD(KX-1+NX,NX) -!/O7a IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN -!/O7a WRITE (PARTS,'(I4,1A,I4)') & -!/O7a NINT(1000.*TRNX(KY,IIX)), & -!/O7a '|', NINT(1000.*TRNY(KY,IIX)) -!/O7a NNX = 2 + (KX-IX0)*13 -!/O7a DO JX=1, 9 -!/O7a STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) -!/O7a END DO -!/O7a ENDIF -!/O7a END IF -!/O7a END DO -!/O7a WRITE (SCREEN,946) STRING -!/O7a WRITE (SCREEN,946) LINE1 -! -!/O7a END DO -! -!/O7a IF ( ICLOSE.NE.ICLOSE_NONE ) THEN -!/O7a WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) -!/O7a ELSE -!/O7a WRITE (SCREEN,945) (KX,KX=IX0,IXN) -!/O7a END IF -!/O7a DEALLOCATE ( STRING, LINE1, LINE2 ) +#ifdef W3_O7a + IF ( IAPROC .EQ. NAPOUT ) THEN + WRITE (SCREEN,940) NOPTS + DO J=1, NOPTS +#endif +! +#ifdef W3_O7a + WRITE (SCREEN,941) PTNME(J), PTLOC(:,J)*FACTOR + IX(:) = IPTINT(1,:,J) + IY(:) = IPTINT(2,:,J) + RD(:) = PTIFAC(:,J) + WRITE (SCREEN,942) (IX(K),IY(K),RD(K),K=1,4) +#endif +! +#ifdef W3_O7a + ZBOX = 0. + RDTOT = 0. + DO K = 1,4 + IF ( MAPFS(IY(K),IX(K)) .GT. 0 ) THEN + ZBOX(K) = ZB(IX(K)) + RDTOT = RDTOT + RD(K) + END IF + END DO + RDTOT = MAX ( 1.E-7 , RDTOT ) +#endif +! +#ifdef W3_O7a + DEPTH = - ( RD(1)*ZBOX(1) + & + RD(2)*ZBOX(2) + & + RD(3)*ZBOX(3) + & + RD(4)*ZBOX(4) ) / RDTOT + WRITE (SCREEN,943) DEPTH +#endif +! +#ifdef W3_O7a + ! *** implementation of O7a option with curvilinear grids is incomplete *** +#endif +! +#ifdef W3_O7a + IF ( RD1 .LT. 0.05 ) IX2 = IX1 + IF ( RD1 .GT. 0.95 ) IX1 = IX2 + IF ( RD2 .LT. 0.05 ) IY2 = IY1 + IF ( RD2 .GT. 0.95 ) IY1 = IY2 + IX0 = IX1 - 1 + IXN = IX2 + 1 + IY0 = MAX ( 1 , IY1 - 1 ) + IYN = MIN ( IY2 + 1 , NY ) + NNX = 13 * ( IXN - IX0 + 1 ) +#endif +! +#ifdef W3_O7a + ALLOCATE ( STRING(NNX), LINE1(NNX), LINE2(NNX) ) + DO KX=1, NNX + LINE1(KX) = ' ' + LINE2(KX) = '-' + END DO + DO KX=7, NNX, 13 + LINE1(KX) = '|' + LINE2(KX) = '+' + END DO +#endif +! +#ifdef W3_O7a + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) + ELSE + WRITE (SCREEN,945) (KX,KX=IX0,IXN) + END IF + WRITE (SCREEN,946) LINE1 +#endif +! +#ifdef W3_O7a + DO KY=IYN, IY0, -1 +#endif +! +#ifdef W3_O7a + STRING = LINE1 + DO KX=IX0, IXN + IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN + IIX = 1 + MOD(KX-1+NX,NX) + IS1 = MAPFS(KY,IIX) + IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN + WRITE (PARTS,'(F8.1,1X)') -ZB(IS1) + NNX = 2 + (KX-IX0)*13 + DO JX=1, 9 + STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) + END DO + ENDIF + END IF + END DO + WRITE (SCREEN,946) STRING +#endif +! +#ifdef W3_O7a + STRING = LINE2 + DO KX=IX0, IXN + NNX = 5 + (KX-IX0)*13 + IF ( ICLOSE.EQ.ICLOSE_NONE .AND. (KX.LT.1.OR.KX.GT.NX) ) THEN + STRING(NNX:NNX+4) = OUT + ELSE + IIX = 1 + MOD(KX-1+NX,NX) + IF ( MAPSTA(KY,IIX) .EQ. 0 ) THEN + STRING(NNX:NNX+4) = LND + ELSE + STRING(NNX:NNX+4) = SEA + END IF + END IF + END DO + WRITE (SCREEN,947) KY, STRING +#endif +! +#ifdef W3_O7a + STRING = LINE1 + DO KX=IX0, IXN + IF ( ICLOSE.NE.ICLOSE_NONE .OR. (KX.GE.1 .AND. KX.LE.NX) ) THEN + IS1 = MAPFS(KY,KX) + IIX = 1 + MOD(KX-1+NX,NX) + IF ( MAPSTA(KY,IIX) .NE. 0 ) THEN + WRITE (PARTS,'(I4,1A,I4)') & + NINT(1000.*TRNX(KY,IIX)), & + '|', NINT(1000.*TRNY(KY,IIX)) + NNX = 2 + (KX-IX0)*13 + DO JX=1, 9 + STRING(NNX+JX:NNX+JX) = PARTS(JX:JX) + END DO + ENDIF + END IF + END DO + WRITE (SCREEN,946) STRING + WRITE (SCREEN,946) LINE1 +#endif +! +#ifdef W3_O7a + END DO +#endif +! +#ifdef W3_O7a + IF ( ICLOSE.NE.ICLOSE_NONE ) THEN + WRITE (SCREEN,945) (1+MOD(KX+NX-1,NX),KX=IX0,IXN) + ELSE + WRITE (SCREEN,945) (KX,KX=IX0,IXN) + END IF + DEALLOCATE ( STRING, LINE1, LINE2 ) +#endif -!/O7a END DO -!/O7a WRITE (SCREEN,*) -!/O7a WRITE (SCREEN,*) -!/O7a END IF +#ifdef W3_O7a + END DO + WRITE (SCREEN,*) + WRITE (SCREEN,*) + END IF +#endif ! RETURN ! ! Formats ! -!/O7a 940 FORMAT (/' Diagnostic output for output points [',I3,'] :'/& -!/O7a '--------------------------------------------'/ & -!/O7a ' Bottom level in m above grid point'/ & -!/O7a ' X/Y transparency in thousands below') -!/O7a 941 FORMAT (/' Point ',A,' at ',2F8.2,' (degr or km)'/ & -!/O7a ' -------------------------------------------------') -!/O7a 942 FORMAT ( ' Interp. cell :',4(' (',2I5,F4.2,')')) -!/O7a 943 FORMAT ( ' Depth (water level = 0) :',F10.1,' m'/) -!/O7a 945 FORMAT ( ' IX = ',4I13) -!/O7a 946 FORMAT ( ' ',52A1) -!/O7a 947 FORMAT ( ' IY =',I5,2X,52A1) +#ifdef W3_O7a + 940 FORMAT (/' Diagnostic output for output points [',I3,'] :'/& + '--------------------------------------------'/ & + ' Bottom level in m above grid point'/ & + ' X/Y transparency in thousands below') + 941 FORMAT (/' Point ',A,' at ',2F8.2,' (degr or km)'/ & + ' -------------------------------------------------') + 942 FORMAT ( ' Interp. cell :',4(' (',2I5,F4.2,')')) + 943 FORMAT ( ' Depth (water level = 0) :',F10.1,' m'/) + 945 FORMAT ( ' IX = ',4I13) + 946 FORMAT ( ' ',52A1) + 947 FORMAT ( ' IY =',I5,2X,52A1) +#endif ! 1000 FORMAT (/' *** WAVEWATCH-III WARNING :'/ & ' OUTPUT POINT OUT OF GRID : ',2F10.3,2X,A/ & @@ -518,14 +580,16 @@ SUBROUTINE W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) ' OUTPUT POINT ON LAND : ',2E10.3,2X,A/ & ' POINT SKIPPPED '/) ! -!/T 9010 FORMAT (' TEST W3IOPP : INPUT : ',I4,2F12.2,2X,A) -!/T 9011 FORMAT (' CORR. : ',2F12.2) -!/T 9012 FORMAT (' TEST W3IOPP : INT. DATA: ',2I6,1F8.2) -!/T 9013 FORMAT (' TEST W3IOPP : INT. DATA B): ',4I4,2F8.2) -!/T 9020 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & -!/T 4(/' ',2I5,2F6.3)) -!/T 9021 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & -!/T 4(/' ',2I5,F6.3)) +#ifdef W3_T + 9010 FORMAT (' TEST W3IOPP : INPUT : ',I4,2F12.2,2X,A) + 9011 FORMAT (' CORR. : ',2F12.2) + 9012 FORMAT (' TEST W3IOPP : INT. DATA: ',2I6,1F8.2) + 9013 FORMAT (' TEST W3IOPP : INT. DATA B): ',4I4,2F8.2) + 9020 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & + 4(/' ',2I5,2F6.3)) + 9021 FORMAT (' TEST W3IOPP : PREPROCESSED DATA',I4,2X,A,2X,2F12.2, & + 4(/' ',2I5,F6.3)) +#endif !/ !/ End of W3IOPP ----------------------------------------------------- / !/ @@ -617,28 +681,46 @@ SUBROUTINE W3IOPE ( A ) USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, SIG, NX, NY, NSEA, NSEAL, & MAPSTA, MAPFS -!/RTD !! Use spectral rotation sub and angle. JGLi12Jun2012 -!/RTD USE W3GDATMD, ONLY: NSPEC, AnglD, FLAGUNR -!/RTD USE W3SERVMD, ONLY: W3ACTURN +#ifdef W3_RTD + !! Use spectral rotation sub and angle. JGLi12Jun2012 + USE W3GDATMD, ONLY: NSPEC, AnglD, FLAGUNR + USE W3SERVMD, ONLY: W3ACTURN +#endif USE W3WDATMD, ONLY: ICE, ICEH, ICEF -!/FLX5 USE W3WDATMD, ONLY: RHOAIR +#ifdef W3_FLX5 + USE W3WDATMD, ONLY: RHOAIR +#endif USE W3ADATMD, ONLY: CG, DW, UA, UD, AS, CX, CY, & SP => SPPNT -!/FLX5 USE W3ADATMD, ONLY: TAUA, TAUADIR +#ifdef W3_FLX5 + USE W3ADATMD, ONLY: TAUA, TAUADIR +#endif USE W3ODATMD, ONLY: NDST, NOPTS, IPTINT, PTIFAC, IL, IW, II, & DPO, WAO, WDO, ASO, CAO, CDO, ICEO, ICEHO, & ICEFO, SPCO, NAPROC -!/FLX5 USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP -!/SETUP USE W3ODATMD, ONLY: ZET_SETO -!/MPI USE W3ODATMD, ONLY: IRQPO2 +#ifdef W3_FLX5 + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif +#ifdef W3_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3ODATMD, ONLY: ZET_SETO +#endif +#ifdef W3_MPI + USE W3ODATMD, ONLY: IRQPO2 +#endif USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ARRYMD, ONLY: PRT2DS +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ARRYMD, ONLY: PRT2DS +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -650,21 +732,33 @@ SUBROUTINE W3IOPE ( A ) !/ INTEGER :: I, IX1, IY1, IX(4), IY(4), J, IS(4), & IM(4), IK, ITH, ISP -!/MPI INTEGER :: IOFF, IERR_MPI -!/MPI INTEGER :: STAT(MPI_STATUS_SIZE,4*NOPTS) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IOFF, IERR_MPI + INTEGER :: STAT(MPI_STATUS_SIZE,4*NOPTS) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: RD(4), RDS, RDI, FACRD, & WNDX, WNDY, CURX, CURY, FAC1(NK), & FAC2(NK), FAC3(NK), FAC4(NK) -!/FLX5 REAL :: TAUX, TAUY +#ifdef W3_FLX5 + REAL :: TAUX, TAUY +#endif INTEGER :: JSEA, ISEA -!/T REAL :: SPTEST(NK,NTH) -!/RTD REAL :: Spectr(NSPEC), AnglDIS -!/RTD INTEGER :: IROT +#ifdef W3_T + REAL :: SPTEST(NK,NTH) +#endif +#ifdef W3_RTD + REAL :: Spectr(NSPEC), AnglDIS + INTEGER :: IROT +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOPE') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOPE') +#endif ! CX(0) = 0. CY(0) = 0. @@ -673,7 +767,9 @@ SUBROUTINE W3IOPE ( A ) ! DO I=1, NOPTS ! -!/T WRITE (NDST,9000) I +#ifdef W3_T + WRITE (NDST,9000) I +#endif ! ! Unpack interpolation data ! @@ -681,7 +777,9 @@ SUBROUTINE W3IOPE ( A ) IY(:) = IPTINT(2,:,I) RD(:) = PTIFAC(:,I) ! -!/T! WRITE (NDST,9001) IX1, IY1, IX(2) +#ifdef W3_T +! WRITE (NDST,9001) IX1, IY1, IX(2) +#endif ! ! ! Correct for land and ice and get sea point counters @@ -698,7 +796,9 @@ SUBROUTINE W3IOPE ( A ) IF ( IM(J).GT.0 ) THEN IW(I) = IW(I) + 1 RDS = RDS + RD(J) -!/RTD IROT = IS(J) ! For rotation angle +#ifdef W3_RTD + IROT = IS(J) ! For rotation angle +#endif ELSE IF ( IM(J).LT.0 ) THEN II(I) = II(I) + 1 @@ -717,7 +817,9 @@ SUBROUTINE W3IOPE ( A ) RD = RD * FACRD END IF ! -!/T WRITE (NDST,9002) (IS(J),J=1,4), (IM(J),J=1,4), (RD(J),J=1,4) +#ifdef W3_T + WRITE (NDST,9002) (IS(J),J=1,4), (IM(J),J=1,4), (RD(J),J=1,4) +#endif ! ! Interpolate ice depth, wind, stresses, rho air and current ! @@ -725,8 +827,12 @@ SUBROUTINE W3IOPE ( A ) ICEFO(I) = 0 DO J=1, 4 ISEA = MAPFS(IY(J),IX(J)) -!/DIST JSEA = 1 + (ISEA-1)/NAPROC -!/SHRD JSEA = ISEA +#ifdef W3_DIST + JSEA = 1 + (ISEA-1)/NAPROC +#endif +#ifdef W3_SHRD + JSEA = ISEA +#endif ICEFO(I) = ICEFO(I) + RD(J)*ICEF(JSEA) END DO ELSE @@ -742,13 +848,17 @@ SUBROUTINE W3IOPE ( A ) ! DPO(I) = RD(1)*DW(IS(1)) + RD(2)*DW(IS(2)) + & RD(3)*DW(IS(3)) + RD(4)*DW(IS(4)) -!/SETUP DPO(I) = RD(1)*ZETA_SETUP(IS(1)) + & -!/SETUP RD(2)*ZETA_SETUP(IS(2)) + & -!/SETUP RD(3)*ZETA_SETUP(IS(3)) + & -!/SETUP RD(4)*ZETA_SETUP(IS(4)) -! -!/FLX5 DAIRO(I) = RD(1)*RHOAIR(IS(1)) + RD(2)*RHOAIR(IS(2)) + & -!/FLX5 RD(3)*RHOAIR(IS(3)) + RD(4)*RHOAIR(IS(4)) +#ifdef W3_SETUP + DPO(I) = RD(1)*ZETA_SETUP(IS(1)) + & + RD(2)*ZETA_SETUP(IS(2)) + & + RD(3)*ZETA_SETUP(IS(3)) + & + RD(4)*ZETA_SETUP(IS(4)) +#endif +! +#ifdef W3_FLX5 + DAIRO(I) = RD(1)*RHOAIR(IS(1)) + RD(2)*RHOAIR(IS(2)) + & + RD(3)*RHOAIR(IS(3)) + RD(4)*RHOAIR(IS(4)) +#endif ! WNDX = RD(1) * UA(IS(1)) * COS(UD(IS(1))) + & RD(2) * UA(IS(2)) * COS(UD(IS(2))) + & @@ -762,28 +872,34 @@ SUBROUTINE W3IOPE ( A ) WAO(I) = SQRT ( WNDX**2 + WNDY**2 ) IF ( WAO(I).GT.1.E-7 ) THEN WDO(I) = ATAN2(WNDY,WNDX) -!/RTD IF ( FLAGUNR ) WDO(I) = WDO(I) - AnglD(IS(1))*DERA +#ifdef W3_RTD + IF ( FLAGUNR ) WDO(I) = WDO(I) - AnglD(IS(1))*DERA +#endif ELSE WDO(I) = 0. END IF ! -!/FLX5 TAUX = RD(1) * TAUA(IS(1)) * COS(TAUADIR(IS(1))) + & -!/FLX5 RD(2) * TAUA(IS(2)) * COS(TAUADIR(IS(2))) + & -!/FLX5 RD(3) * TAUA(IS(3)) * COS(TAUADIR(IS(3))) + & -!/FLX5 RD(4) * TAUA(IS(4)) * COS(TAUADIR(IS(4))) -!/FLX5 TAUY = RD(1) * TAUA(IS(1)) * SIN(TAUADIR(IS(1))) + & -!/FLX5 RD(2) * TAUA(IS(2)) * SIN(TAUADIR(IS(2))) + & -!/FLX5 RD(3) * TAUA(IS(3)) * SIN(TAUADIR(IS(3))) + & -!/FLX5 RD(4) * TAUA(IS(4)) * SIN(TAUADIR(IS(4))) -!/FLX5! -!/FLX5 TAUAO(I) = SQRT ( TAUX**2 + TAUY**2 ) -!/FLX5 IF ( TAUAO(I).GT.1.E-7 ) THEN -!/FLX5 TAUDO(I) = ATAN2(TAUY,TAUX) -!/FLX5!/RTD IF ( FLAGUNR ) TAUDO(I) = TAUDO(I) - AnglD(IS(1))*DERA -!/FLX5 ELSE -!/FLX5 TAUDO(I) = 0. -!/FLX5 END IF -!/FLX5! +#ifdef W3_FLX5 + TAUX = RD(1) * TAUA(IS(1)) * COS(TAUADIR(IS(1))) + & + RD(2) * TAUA(IS(2)) * COS(TAUADIR(IS(2))) + & + RD(3) * TAUA(IS(3)) * COS(TAUADIR(IS(3))) + & + RD(4) * TAUA(IS(4)) * COS(TAUADIR(IS(4))) + TAUY = RD(1) * TAUA(IS(1)) * SIN(TAUADIR(IS(1))) + & + RD(2) * TAUA(IS(2)) * SIN(TAUADIR(IS(2))) + & + RD(3) * TAUA(IS(3)) * SIN(TAUADIR(IS(3))) + & + RD(4) * TAUA(IS(4)) * SIN(TAUADIR(IS(4))) +! + TAUAO(I) = SQRT ( TAUX**2 + TAUY**2 ) + IF ( TAUAO(I).GT.1.E-7 ) THEN + TAUDO(I) = ATAN2(TAUY,TAUX) +#ifdef W3_RTD + IF ( FLAGUNR ) TAUDO(I) = TAUDO(I) - AnglD(IS(1))*DERA +#endif + ELSE + TAUDO(I) = 0. + END IF +! +#endif ASO(I) = RD(1)*AS(IS(1)) + RD(2)*AS(IS(2)) + & RD(3)*AS(IS(3)) + RD(4)*AS(IS(4)) ! @@ -795,7 +911,9 @@ SUBROUTINE W3IOPE ( A ) CAO(I) = SQRT ( CURX**2 + CURY**2 ) IF ( CAO(I).GT.1.E-7 ) THEN CDO(I) = ATAN2(CURY,CURX) -!/RTD IF ( FLAGUNR ) CDO(I) = CDO(I) - AnglD(IS(1))*DERA +#ifdef W3_RTD + IF ( FLAGUNR ) CDO(I) = CDO(I) - AnglD(IS(1))*DERA +#endif ELSE CDO(I) = 0. END IF @@ -807,24 +925,30 @@ SUBROUTINE W3IOPE ( A ) RD = RD * FACRD END IF ! -!/T WRITE (NDST,9003) (RD(J),J=1,4) +#ifdef W3_T + WRITE (NDST,9003) (RD(J),J=1,4) +#endif ! ! Extract spectra, shared memory version ! (done in separate step for MPP compatibility) ! -!/SHRD DO J=1, 4 -!/SHRD DO IK=1, NK -!/SHRD DO ITH=1, NTH -!/SHRD SP(ITH,IK,J) = A(ITH,IK,IS(J)) -!/SHRD END DO -!/SHRD END DO -!/SHRD END DO +#ifdef W3_SHRD + DO J=1, 4 + DO IK=1, NK + DO ITH=1, NTH + SP(ITH,IK,J) = A(ITH,IK,IS(J)) + END DO + END DO + END DO +#endif ! ! Extract spectra, distributed memory version(s) ! -!/MPI IOFF = 1 + 4*(I-1) -!/MPI CALL MPI_STARTALL ( 4, IRQPO2(IOFF), IERR_MPI ) -!/MPI CALL MPI_WAITALL ( 4, IRQPO2(IOFF), STAT, IERR_MPI ) +#ifdef W3_MPI + IOFF = 1 + 4*(I-1) + CALL MPI_STARTALL ( 4, IRQPO2(IOFF), IERR_MPI ) + CALL MPI_WAITALL ( 4, IRQPO2(IOFF), STAT, IERR_MPI ) +#endif ! ! Interpolate spectrum ! @@ -842,30 +966,38 @@ SUBROUTINE W3IOPE ( A ) + RD(2) * SP(ITH,IK,2) * FAC2(IK) & + RD(3) * SP(ITH,IK,3) * FAC3(IK) & + RD(4) * SP(ITH,IK,4) * FAC4(IK) -!/T SPTEST(IK,ITH) = SPCO(ISP,I) +#ifdef W3_T + SPTEST(IK,ITH) = SPCO(ISP,I) +#endif END DO END DO ! -!/RTD !! Rotate the interpolated spectrum by -AnglD(IS(1)). JGLi12Jun2012 -!/RTD !! SPCO still holds action not energy spectrum yet. JGLi18Jun2013 -!/RTD !! Use new index IROT rather than IS(1) as in some cases -!/RTD !! IS(1) will be a coast point and have an index of 0. C.Bunney 15/02/2011 -!/RTD IF ( FLAGUNR ) THEN -!/RTD Spectr = SPCO(:,I) -!/RTD AnglDIS = -AnglD(IROT) -!/RTD CALL W3ACTURN( NTH, NK, AnglDIS, Spectr ) -!/RTD SPCO(:,I) = Spectr -!/RTD END IF -!/RTD -! -!/T WRITE (NDST,9004) DPO(I), WAO(I), WDO(I)*RADE, & -!/T CAO(I), CDO(I)*RADE +#ifdef W3_RTD + !! Rotate the interpolated spectrum by -AnglD(IS(1)). JGLi12Jun2012 + !! SPCO still holds action not energy spectrum yet. JGLi18Jun2013 + !! Use new index IROT rather than IS(1) as in some cases + !! IS(1) will be a coast point and have an index of 0. C.Bunney 15/02/2011 + IF ( FLAGUNR ) THEN + Spectr = SPCO(:,I) + AnglDIS = -AnglD(IROT) + CALL W3ACTURN( NTH, NK, AnglDIS, Spectr ) + SPCO(:,I) = Spectr + END IF + +#endif +! +#ifdef W3_T + WRITE (NDST,9004) DPO(I), WAO(I), WDO(I)*RADE, & + CAO(I), CDO(I)*RADE +#endif ! FA COMMENTED OUT: BUG !At line 1974 of file w3arrymd.f90 !Fortran runtime error: Index '52' of dimension 1 of array 'pnum2' above upper bound of 51 -!/T ! CALL PRT2DS (NDST, NK, NK, NTH, SPTEST, SIG(1:), ' ', 1.,0.,& -!/T ! 0.0001, 'E(f,theta)', 'm**2s', 'TEST OUTPUT' ) +#ifdef W3_T + ! CALL PRT2DS (NDST, NK, NK, NTH, SPTEST, SIG(1:), ' ', 1.,0.,& + ! 0.0001, 'E(f,theta)', 'm**2s', 'TEST OUTPUT' ) +#endif ! END DO ! @@ -873,11 +1005,13 @@ SUBROUTINE W3IOPE ( A ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3IOPE : POINT NR.:',I3) -!/T 9001 FORMAT (' TEST W3IOPE :',2I8,' (',I3,')') -!/T 9002 FORMAT (' TEST W3IOPE :',4I7,2X,4I2,2X,4F5.2) -!/T 9003 FORMAT (' TEST W3IOPE :',40X,4F5.2) -!/T 9004 FORMAT (' TEST W3IOPE :',F8.1,2(F7.2,F7.1)) +#ifdef W3_T + 9000 FORMAT (' TEST W3IOPE : POINT NR.:',I3) + 9001 FORMAT (' TEST W3IOPE :',2I8,' (',I3,')') + 9002 FORMAT (' TEST W3IOPE :',4I7,2X,4I2,2X,4F5.2) + 9003 FORMAT (' TEST W3IOPE :',40X,4F5.2) + 9004 FORMAT (' TEST W3IOPE :',F8.1,2(F7.2,F7.1)) +#endif !/ !/ End of W3IOPE ----------------------------------------------------- / !/ @@ -967,13 +1101,19 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) IL, IW, II, PTLOC, PTIFAC, DPO, WAO, WDO, & ASO, CAO, CDO, SPCO, PTNME, O2INIT, FNMPRE, & GRDID, ICEO, ICEHO, ICEFO -!/FLX5 USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#ifdef W3_FLX5 + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif USE W3ODATMD, ONLY : OFILES !/ -!/SETUP USE W3ODATMD, ONLY: ZET_SETO +#ifdef W3_SETUP + USE W3ODATMD, ONLY: ZET_SETO +#endif !/ USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -989,7 +1129,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) !/ local parameters !/ INTEGER :: IGRD, IERR, MK, MTH, I, J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL,SAVE :: WRITE CHARACTER(LEN=31) :: IDTST CHARACTER(LEN=10) :: VERTST @@ -998,7 +1140,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOPO') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOPO') +#endif IPASS = IPASS + 1 IOTST = 0 ! @@ -1036,7 +1180,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) I = LEN_TRIM(FILEXT) J = LEN_TRIM(FNMPRE) ! -!/T WRITE (NDST,9001) FNMPRE(:J)//'out_pnt.'//FILEXT(:I) +#ifdef W3_T + WRITE (NDST,9001) FNMPRE(:J)//'out_pnt.'//FILEXT(:I) +#endif IF ( WRITE ) THEN OPEN (NDSOP,FILE=FNMPRE(:J)//'out_pnt.'//FILEXT(:I), & FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) @@ -1073,7 +1219,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) END IF ! -!/T WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS +#ifdef W3_T + WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS +#endif ! ! Point specific info ------------------------------------------------ * ! ( IPASS = 1 ) @@ -1086,10 +1234,12 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) END IF ! -!/T WRITE (NDST,9003) -!/T DO I=1, NOPTS -!/T WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) -!/T END DO +#ifdef W3_T + WRITE (NDST,9003) + DO I=1, NOPTS + WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) + END DO +#endif ! END IF ! @@ -1113,8 +1263,10 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) ! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) ! -!/T WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_pnt.'// & -!/T FILEXT(:I) +#ifdef W3_T + WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_pnt.'// & + FILEXT(:I) +#endif IF ( WRITE ) THEN OPEN (NDSOP,FILE=FNMPRE(:J)//TIMETAG//'.out_pnt.' & //FILEXT(:I),FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) @@ -1149,7 +1301,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) CALL W3DMO2 ( IGRD, NDSE, NDST, NOPTS ) END IF ! -!/T WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS +#ifdef W3_T + WRITE (NDST,9002) IDSTR, VEROPT, NK, NTH, NOPTS +#endif ! ! Point specific info ------------------------------------------------ * ! ( IPASS GE.1 .AND. OFILES(2) .EQ. 1) @@ -1162,10 +1316,12 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) ((PTLOC(J,I),J=1,2),I=1,NOPTS), (PTNME(I),I=1,NOPTS) END IF ! -!/T WRITE (NDST,9003) -!/T DO I=1, NOPTS -!/T WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) -!/T END DO +#ifdef W3_T + WRITE (NDST,9003) + DO I=1, NOPTS + WRITE (NDST,9004) I, PTLOC(1,I), PTLOC(2,I), PTNME(I) + END DO +#endif ! END IF ! @@ -1178,7 +1334,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) READ (NDSOP,END=803,ERR=802,IOSTAT=IERR) TIME END IF ! -!/T WRITE (NDST,9010) TIME +#ifdef W3_T + WRITE (NDST,9010) TIME +#endif ! ! ! Loop over spectra -------------------------------------------------- * @@ -1193,15 +1351,23 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) IL(I) = 0 WRITE (NDSOP) & IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & -!/FLX5 TAUAO(I), TAUDO(I), DAIRO(I), & -!/SETUP ZET_SETO(I), & +#ifdef W3_FLX5 + TAUAO(I), TAUDO(I), DAIRO(I), & +#endif +#ifdef W3_SETUP + ZET_SETO(I), & +#endif ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) ELSE READ (NDSOP,END=801,ERR=802,IOSTAT=IERR) & IW(I), II(I), IL(I), DPO(I), WAO(I), WDO(I), & -!/FLX5 TAUAO(I), TAUDO(I), DAIRO(I), & -!/SETUP ZET_SETO(I), & +#ifdef W3_FLX5 + TAUAO(I), TAUDO(I), DAIRO(I), & +#endif +#ifdef W3_SETUP + ZET_SETO(I), & +#endif ASO(I), CAO(I), CDO(I), ICEO(I), ICEHO(I), & ICEFO(I), GRDID(I), (SPCO(J,I),J=1,NSPEC) END IF @@ -1227,7 +1393,9 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) ! 803 CONTINUE IOTST = -1 -!/T WRITE (NDST,9011) +#ifdef W3_T + WRITE (NDST,9011) +#endif RETURN ! ! Formats @@ -1255,26 +1423,34 @@ SUBROUTINE W3IOPO ( INXOUT, NDSOP, IOTST, IMOD ) ' ERROR IN READING FROM FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST W3IOPO : IPASS =',I4,' INXOUT = ',A, & -!/T ' WRITE = ',L1,' UNIT =',I3/ & -!/T ' IGRD =',I3,' FEXT = ',A) +#ifdef W3_T + 9000 FORMAT (' TEST W3IOPO : IPASS =',I4,' INXOUT = ',A, & + ' WRITE = ',L1,' UNIT =',I3/ & + ' IGRD =',I3,' FEXT = ',A) +#endif -!/T 9001 FORMAT (' TEST W3IOPO : OPENING NEW FILE [',A,']') -!/T 9002 FORMAT (' TEST W3IOPO : TEST PARAMETERS:'/ & -!/T ' IDSTR : ',A/ & -!/T ' VEROPT : ',A/ & -!/T ' NK,NTH :',I5,I8/ & -!/T ' NOPT :',I5) -!/T 9003 FORMAT (' TEST W3IOPO : POINT LOCATION AND ID') -!/T 9004 FORMAT (3X,I4,2F10.2,2X,A) -! -!/T 9010 FORMAT (' TEST W3IOPO : TIME :',I9.8,I7.6) -!/T 9011 FORMAT (' TEST W3IOPO : END OF FILE REACHED') -! -!/T 9020 FORMAT (' TEST W3IOPO : POINT NR.:',I5) -!/T 9021 FORMAT (' TEST W3IOPO :',2I4,2F6.3) -!/T 9022 FORMAT (' TEST W3IOPO :',4I7,2X,4I2,2X,4F5.2) -!/T 9030 FORMAT (' TEST W3IOPO :',F8.1,2(F7.2,F7.1)) +#ifdef W3_T + 9001 FORMAT (' TEST W3IOPO : OPENING NEW FILE [',A,']') + 9002 FORMAT (' TEST W3IOPO : TEST PARAMETERS:'/ & + ' IDSTR : ',A/ & + ' VEROPT : ',A/ & + ' NK,NTH :',I5,I8/ & + ' NOPT :',I5) + 9003 FORMAT (' TEST W3IOPO : POINT LOCATION AND ID') + 9004 FORMAT (3X,I4,2F10.2,2X,A) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3IOPO : TIME :',I9.8,I7.6) + 9011 FORMAT (' TEST W3IOPO : END OF FILE REACHED') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3IOPO : POINT NR.:',I5) + 9021 FORMAT (' TEST W3IOPO :',2I4,2F6.3) + 9022 FORMAT (' TEST W3IOPO :',4I7,2X,4I2,2X,4F5.2) + 9030 FORMAT (' TEST W3IOPO :',F8.1,2(F7.2,F7.1)) +#endif !/ !/ End of W3IOPO ----------------------------------------------------- / !/ diff --git a/model/ftn/w3iorsmd.ftn b/model/src/w3iorsmd.F90 similarity index 73% rename from model/ftn/w3iorsmd.ftn rename to model/src/w3iorsmd.F90 index 1bd628512..4462a6ba6 100644 --- a/model/ftn/w3iorsmd.ftn +++ b/model/src/w3iorsmd.F90 @@ -258,27 +258,39 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) GNAME, FILEXT, GTYPE, UNGTYPE USE W3TRIAMD, ONLY: SETUGIOBP USE W3WDATMD -!/WRST USE W3IDATMD, ONLY: WXN, WYN, W3SETI -!/WRST USE W3IDATMD, ONLY: WXNwrst, WYNwrst +#ifdef W3_WRST + USE W3IDATMD, ONLY: WXN, WYN, W3SETI + USE W3IDATMD, ONLY: WXNwrst, WYNwrst +#endif USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & FLOGRR, NOGRP, NGRPP, SCREEN -!/MPI USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & -!/MPI VAAUX -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WCMP +#ifdef W3_MPI + USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & + VAAUX + USE W3ADATMD, ONLY: MPI_COMM_WCMP +#endif !/ USE W3SERVMD, ONLY: EXTCDE USE CONSTANTS, only: LPDLIB USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC USE W3GDATMD, ONLY: NK, NTH -!/TIMINGS USE W3PARALL, ONLY: PRINT_MY_TIME +#ifdef W3_TIMINGS + USE W3PARALL, ONLY: PRINT_MY_TIME +#endif !!!!!/PDLIB USE PDLIB_FIELD_VEC!, only : UNST_PDLIB_READ_FROM_FILE, UNST_PDLIB_WRITE_TO_FILE -!/PDLIB USE PDLIB_FIELD_VEC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_PDLIB + USE PDLIB_FIELD_VEC +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -300,12 +312,18 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) NREC, NPART, IPART, IX, IY, IXL, IP, & NPRTX2, NPRTY2, IYL, ITMP INTEGER, ALLOCATABLE :: MAPTMP(:,:) -!/S INTEGER, SAVE :: IENT = 0 -!/MPI INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & -!/MPI NRQ, NSEAL_MIN +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & + NRQ, NSEAL_MIN +#endif INTEGER(KIND=8) :: RPOS -!/MPI INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) -!/MPI REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) +#ifdef W3_MPI + INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) + REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) +#endif REAL(KIND=LRB), ALLOCATABLE :: WRITEBUFF(:), TMP(:), TMP2(:) LOGICAL :: WRITE, IOSFLG @@ -320,7 +338,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IORS') +#ifdef W3_S + CALL STRACE (IENT, 'W3IORS') +#endif ! ! ! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing @@ -328,9 +348,11 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! UNFORMATTED files in OPEN ! ! NDSR = 525 -!/DEBUGIO WRITE(740+IAPROC,*) 'Beginning of W3IORS subroutine' -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 1' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'Beginning of W3IORS subroutine' + WRITE(740+IAPROC,*) 'W3IORS, step 1' + FLUSH(740+IAPROC) +#endif IOSFLG = IOSTYP .GT. 0 ! @@ -345,7 +367,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) CALL W3SETO ( IGRD, NDSE, NDST ) CALL W3SETG ( IGRD, NDSE, NDST ) CALL W3SETW ( IGRD, NDSE, NDST ) -!/WRST CALL W3SETI ( IGRD, NDSE, NDST ) +#ifdef W3_WRST + CALL W3SETI ( IGRD, NDSE, NDST ) +#endif ! IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT' .AND. & INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND. & @@ -361,12 +385,16 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) TYPE = INXOUT END IF ! -!/T WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST +#ifdef W3_T + WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST +#endif ! ! initializations ---------------------------------------------------- * ! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 2' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 2' + FLUSH(740+IAPROC) +#endif IF ( .NOT.DINIT ) THEN IF ( IAPROC .LE. NAPROC ) THEN CALL W3DIMW ( IMOD, NDSE, NDST ) @@ -374,16 +402,20 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) END IF END IF -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 3' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 3' + FLUSH(740+IAPROC) +#endif ! IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0. ! LRECL = MAX ( LRB*NSPEC , & LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) NSIZE = LRECL / LRB -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, LRECL=', LRECL, ' NSIZE=', NSIZE -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, LRECL=', LRECL, ' NSIZE=', NSIZE + FLUSH(740+IAPROC) +#endif ! --- Allocate buffer array with zeros (used to ! fill bytes up to size LRECL). --- ALLOCATE(WRITEBUFF(NSIZE)) @@ -421,7 +453,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IFILE = IFILE + 1 ! -!/T WRITE (NDST,9001) FNAME, LRECL +#ifdef W3_T + WRITE (NDST,9001) FNAME, LRECL +#endif ! IF(NDST.EQ.NDSR)THEN @@ -430,8 +464,10 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) //'TEST OUTPUT ARE THE SAME : ',NDST CALL EXTCDE ( 15 ) ENDIF -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 4' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 4' + FLUSH(740+IAPROC) +#endif IF ( WRITE ) THEN IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & @@ -512,13 +548,17 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! 100 CONTINUE ! -!/T WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & -!/T NSEA, NSEAL, NSPEC +#ifdef W3_T + WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & + NSEA, NSEAL, NSPEC +#endif ! ! TIME if required --------------------------------------------------- * ! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 5' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 5' + FLUSH(740+IAPROC) +#endif IF (TYPE.EQ.'FULL') THEN RPOS = 1_8 + LRECL*(2-1_8) IF ( WRITE ) THEN @@ -536,38 +576,50 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) END IF END IF ! -!/T WRITE (NDST,9003) TIME -!/T ELSE -!/T WRITE (NDST,9004) +#ifdef W3_T + WRITE (NDST,9003) TIME + ELSE + WRITE (NDST,9004) +#endif ! END IF ! ! Spectra ------------------------------------------------------------ * ! ( Bail out if write for TYPE.EQ.'WIND' ) ! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 6' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 6' + FLUSH(740+IAPROC) +#endif IF ( WRITE ) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, Matching WRITE statement' -!/DEBUGIO FLUSH(740+IAPROC) -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, TYPE=', TYPE, ' IOSFLG=', IOSFLG -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, NAPROC=', NAPROC, ' NAPRST=', NAPRST -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, Matching WRITE statement' + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, TYPE=', TYPE, ' IOSFLG=', IOSFLG + WRITE(740+IAPROC,*) 'W3IORS, NAPROC=', NAPROC, ' NAPRST=', NAPRST + FLUSH(740+IAPROC) +#endif IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN CLOSE ( NDSR ) END IF -!/T WRITE (NDST,9005) TYPE +#ifdef W3_T + WRITE (NDST,9005) TYPE +#endif RETURN ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, Need to match 1' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, Need to match 1' + FLUSH(740+IAPROC) +#endif ! ! Original non-server version writing of spectra ! IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, Need to match 2' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, Need to match 2' + FLUSH(740+IAPROC) +#endif DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) NREC = ISEA + 2 @@ -579,147 +631,203 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! ! I/O server version writing of spectra ( !/MPI ) ! -!/MPI ELSE -! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, Before test for UNST_PDLIB_WRITE_TO_FILE' -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, GTPYPE=', GTYPE, ' UNGTYPE=', UNGTYPE -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, PDLIB=', LPDLIB -!/DEBUGIO FLUSH(740+IAPROC) -!/MPI IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, Directly before call for UNST_PDLIB_WRITE_TO_FILE, NDSR=', NDSR -!/DEBUGIO FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") -!/PDLIB CALL UNST_PDLIB_WRITE_TO_FILE(NDSR) -!/TIMINGS CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") -!/MPI ELSE +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, Before test for UNST_PDLIB_WRITE_TO_FILE' + WRITE(740+IAPROC,*) 'W3IORS, GTPYPE=', GTYPE, ' UNGTYPE=', UNGTYPE + WRITE(740+IAPROC,*) 'W3IORS, PDLIB=', LPDLIB + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN +#endif +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, Directly before call for UNST_PDLIB_WRITE_TO_FILE, NDSR=', NDSR + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") +#endif +#ifdef W3_PDLIB + CALL UNST_PDLIB_WRITE_TO_FILE(NDSR) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") +#endif +#ifdef W3_MPI + ELSE +#endif -!/MPI IF ( IAPROC .NE. NAPRST ) THEN -!/MPI NRQ = 1 -!/MPI ELSE IF ( NAPRST .LE. NAPROC ) THEN -!/MPI NRQ = NAPROC - 1 -!/MPI ELSE -!/MPI NRQ = NAPROC -!/MPI END IF -! -!/MPI ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) -!/MPI IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & -!/MPI ( NRQ, IRQRSS, IERR_MPI ) -! -!/MPI DO IB=1, NBLKRS -!/MPI ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC -!/MPI ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) -! -!/MPI IF ( IAPROC .EQ. NAPRST ) THEN -! -!/MPI IH = 1 + NRQ * (IB-1) -!/MPI CALL MPI_WAITALL & -!/MPI ( NRQ, IRQRSS(IH), STAT1, IERR_MPI ) -!/MPI IF ( IB .LT. NBLKRS ) THEN -!/MPI IH = 1 + NRQ * IB -!/MPI CALL MPI_STARTALL & -!/MPI ( NRQ, IRQRSS(IH), IERR_MPI ) -!/MPI END IF -! -!/MPI DO ISEA=ISEA0, ISEAN -!/MPI NREC = ISEA + 2 -!/MPI CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) -!/MPI RPOS = 1_8 + LRECL*(NREC-1_8) -!/MPI WRITEBUFF(:) = 0. -!/MPI IF ( IP .EQ. NAPRST ) THEN -!/MPI WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) -!/MPI ELSE -!/MPI JSEA = JSEA - 2*((IB-1)/2)*RSBLKS -!/MPI WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) -!/MPI END IF -!/MPI WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & -!/MPI WRITEBUFF -!/MPI END DO -! -!/MPI ELSE -! -!/MPI CALL MPI_STARTALL & -!/MPI ( 1, IRQRSS(IB), IERR_MPI ) -!/MPI CALL MPI_WAITALL & -!/MPI ( 1, IRQRSS(IB), STAT1, IERR_MPI ) -! -!/MPI END IF -!/MPI END DO -! -!/MPI DEALLOCATE ( STAT1 ) -!/MPI END IF +#ifdef W3_MPI + IF ( IAPROC .NE. NAPRST ) THEN + NRQ = 1 + ELSE IF ( NAPRST .LE. NAPROC ) THEN + NRQ = NAPROC - 1 + ELSE + NRQ = NAPROC + END IF +#endif +! +#ifdef W3_MPI + ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) + IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & + ( NRQ, IRQRSS, IERR_MPI ) +#endif +! +#ifdef W3_MPI + DO IB=1, NBLKRS + ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC + ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) +#endif +! +#ifdef W3_MPI + IF ( IAPROC .EQ. NAPRST ) THEN +#endif +! +#ifdef W3_MPI + IH = 1 + NRQ * (IB-1) + CALL MPI_WAITALL & + ( NRQ, IRQRSS(IH), STAT1, IERR_MPI ) + IF ( IB .LT. NBLKRS ) THEN + IH = 1 + NRQ * IB + CALL MPI_STARTALL & + ( NRQ, IRQRSS(IH), IERR_MPI ) + END IF +#endif +! +#ifdef W3_MPI + DO ISEA=ISEA0, ISEAN + NREC = ISEA + 2 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + IF ( IP .EQ. NAPRST ) THEN + WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) + ELSE + JSEA = JSEA - 2*((IB-1)/2)*RSBLKS + WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) + END IF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + WRITEBUFF + END DO +#endif +! +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPI + CALL MPI_STARTALL & + ( 1, IRQRSS(IB), IERR_MPI ) + CALL MPI_WAITALL & + ( 1, IRQRSS(IB), STAT1, IERR_MPI ) +#endif +! +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + DEALLOCATE ( STAT1 ) + END IF +#endif ! END IF ! END IF ELSE -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 7' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 7' + FLUSH(740+IAPROC) +#endif ! ! Reading spectra ! IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN -!/T WRITE (NDST,9020) TYPE +#ifdef W3_T + WRITE (NDST,9020) TYPE +#endif ELSE IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) 'Before call to UNST_PDLIB_READ_FROM_FILE' -!/PDLIB!/DEBUGINIT FLUSH(740+IAPROC) -!/TIMINGS CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") -!/PDLIB CALL UNST_PDLIB_READ_FROM_FILE(NDSR) -!/TIMINGS CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) ' After call to UNST_PDLIB_READ_FROM_FILE' -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA), maxval(VA) -!/PDLIB!/DEBUGINIT DO JSEA=1,NSEAL -!/PDLIB!/DEBUGINIT WRITE(740+IAPROC,*) ' JSEA=', JSEA, ' sum(VA)=', sum(VA(:,JSEA)) -!/PDLIB!/DEBUGINIT END DO -!/PDLIB!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before call to UNST_PDLIB_READ_FROM_FILE' + FLUSH(740+IAPROC) +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") +#endif +#ifdef W3_PDLIB + CALL UNST_PDLIB_READ_FROM_FILE(NDSR) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' After call to UNST_PDLIB_READ_FROM_FILE' + WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA), maxval(VA) + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) ' JSEA=', JSEA, ' sum(VA)=', sum(VA(:,JSEA)) + END DO + FLUSH(740+IAPROC) +#endif +#endif + ELSE +#ifdef W3_MPI + NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC + IF ( NAPROC.GT.1 ) THEN +!/ ----------- Large number of small-sized record reads will tend ---- * +!/ to perform badly on most file systems. We read this part +!/ using streams and scatter the results using MPI. +!/ ( M. WARD, NCI ) +! +! Begin computational proc. only section ---------------- * + IF ( IAPROC.LE.NAPROC ) THEN +! +! Main loop --------------------------------------------- * + ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) + ALLOCATE( VLBUFF( NSIZE ) ) +! + DO JSEA = 1, NSEAL_MIN +! Read NAPROC records into buffer VGBUFF. ------------- * + IF ( IAPROC .EQ. NAPROC ) THEN + RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL + READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) + ELSE + VGBUFF(:) = 0. + END IF +! Distribute one record to each rank. + CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & + VLBUFF, NSIZE, MPI_REAL, & + NAPROC-1, MPI_COMM_WCMP, IERR ) +! Transfer the spectral content of VLBUFF to VA. ------ * + VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) + END DO +! +! Include remainder values (switch to record format) ---- * + JSEA = NSEAL_MIN + 1 + IF ( JSEA.EQ.NSEAL ) THEN + ISEA = IAPROC + (JSEA - 1) * NAPROC + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & + (VA(I,JSEA), I=1,NSPEC) + END IF +! + DEALLOCATE( VGBUFF ) + DEALLOCATE( VLBUFF ) +! +! End computational proc. only section ------------------ * + END IF +! ELSE -!/MPI NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC -!/MPI IF ( NAPROC.GT.1 ) THEN -!/MPI!/ ----------- Large number of small-sized record reads will tend ---- * -!/MPI!/ to perform badly on most file systems. We read this part -!/MPI!/ using streams and scatter the results using MPI. -!/MPI!/ ( M. WARD, NCI ) -!/MPI! -!/MPI! Begin computational proc. only section ---------------- * -!/MPI IF ( IAPROC.LE.NAPROC ) THEN -!/MPI! -!/MPI! Main loop --------------------------------------------- * -!/MPI ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) -!/MPI ALLOCATE( VLBUFF( NSIZE ) ) -!/MPI! -!/MPI DO JSEA = 1, NSEAL_MIN -!/MPI! Read NAPROC records into buffer VGBUFF. ------------- * -!/MPI IF ( IAPROC .EQ. NAPROC ) THEN -!/MPI RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL -!/MPI READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) -!/MPI ELSE -!/MPI VGBUFF(:) = 0. -!/MPI END IF -!/MPI! Distribute one record to each rank. -!/MPI CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & -!/MPI VLBUFF, NSIZE, MPI_REAL, & -!/MPI NAPROC-1, MPI_COMM_WCMP, IERR ) -!/MPI! Transfer the spectral content of VLBUFF to VA. ------ * -!/MPI VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) -!/MPI END DO -!/MPI! -!/MPI! Include remainder values (switch to record format) ---- * -!/MPI JSEA = NSEAL_MIN + 1 -!/MPI IF ( JSEA.EQ.NSEAL ) THEN -!/MPI ISEA = IAPROC + (JSEA - 1) * NAPROC -!/MPI NREC = ISEA + 2 -!/MPI RPOS = 1_8 + LRECL*(NREC-1_8) -!/MPI READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & -!/MPI (VA(I,JSEA), I=1,NSPEC) -!/MPI END IF -!/MPI! -!/MPI DEALLOCATE( VGBUFF ) -!/MPI DEALLOCATE( VLBUFF ) -!/MPI! -!/MPI! End computational proc. only section ------------------ * -!/MPI END IF -!/MPI! -!/MPI ELSE +#endif VA = 0. DO JSEA=1, NSEAL CALL INIT_GET_ISEA(ISEA, JSEA) @@ -728,7 +836,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & (VA(I,JSEA),I=1,NSPEC) ENDDO -!/MPI END IF +#ifdef W3_MPI + END IF +#endif END IF END IF END IF @@ -736,7 +846,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) !AR: Must be checked better ... will do that when cleaning debugging switches! VA = MAX(0.,VA) ! -!/T WRITE (NDST,9006) +#ifdef W3_T + WRITE (NDST,9006) +#endif ! ! Water level etc. if required --------------------------------------- * ! ( For cold start write test output and cold start initialize @@ -748,18 +860,22 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) NPRTX2 = 1 + (NX-1)/NSIZE NPRTY2 = 1 + (NY-1)/NSIZE ! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 8' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 8' + FLUSH(740+IAPROC) +#endif IF ( WRITE ) THEN ! IF (TYPE.EQ.'FULL') THEN ! IF ( IAPROC .EQ. NAPRST ) THEN ! -!/MPI ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) -!/MPI CALL MPI_WAITALL & -!/MPI ( NRQRS, IRQRS , STAT2, IERR_MPI ) -!/MPI DEALLOCATE ( STAT2 ) +#ifdef W3_MPI + ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) + CALL MPI_WAITALL & + ( NRQRS, IRQRS , STAT2, IERR_MPI ) + DEALLOCATE ( STAT2 ) +#endif ! RPOS = 1_8 + LRECL*(NREC-1_8) WRITEBUFF(:) = 0. @@ -783,32 +899,36 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) MIN(NSEA,IPART*NSIZE)) END DO -!/WRST ! The WRST switch saves the values of wind in the -!/WRST ! restart file and then uses the wind for the first -!/WRST ! time step here. This is needed when coupling with -!/WRST ! an atm model that does not have 10m wind speeds at -!/WRST ! initialization. If there is no restart, wind is zero +#ifdef W3_WRST + ! The WRST switch saves the values of wind in the + ! restart file and then uses the wind for the first + ! time step here. This is needed when coupling with + ! an atm model that does not have 10m wind speeds at + ! initialization. If there is no restart, wind is zero +#endif -!/WRST DO IX=1, NX -!/WRST DO IPART=1,NPRTY2 -!/WRST NREC = NREC + 1 -!/WRST RPOS = 1_8 + LRECL*(NREC-1_8) -!/WRST WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF -!/WRST WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & -!/WRST (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & -!/WRST MIN(NY,IPART*NSIZE)) -!/WRST END DO -!/WRST END DO -!/WRST DO IX=1, NX -!/WRST DO IPART=1,NPRTY2 -!/WRST NREC = NREC + 1 -!/WRST RPOS = 1_8 + LRECL*(NREC-1_8) -!/WRST WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF -!/WRST WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & -!/WRST (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & -!/WRST MIN(NY,IPART*NSIZE)) -!/WRST END DO -!/WRST END DO +#ifdef W3_WRST + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO +#endif ALLOCATE ( MAPTMP(NY,NX) ) MAPTMP = MAPSTA + 8*MAPST2 DO IY=1, NY @@ -856,7 +976,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) MIN(NSEA,IPART*NSIZE)) END DO IF (OARST) THEN -!/MPI CALL W3XETA ( IGRD, NDSE, NDST ) +#ifdef W3_MPI + CALL W3XETA ( IGRD, NDSE, NDST ) +#endif ! IF ( FLOGRR(1,2) ) THEN WRITE(NDSR,ERR=803,IOSTAT=IERR) CX(1:NSEA) @@ -921,15 +1043,19 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,2) ENDIF ! -!/MPI CALL W3SETA ( IGRD, NDSE, NDST ) +#ifdef W3_MPI + CALL W3SETA ( IGRD, NDSE, NDST ) +#endif ENDIF -!/T WRITE (NDST,9007) -!/T ELSE -!/T DO ISEA=1, NSEA -!/T WLV(ISEA) = 0. -!/T ICE(ISEA) = 0. -!/T END DO -!/T WRITE (NDST,9008) +#ifdef W3_T + WRITE (NDST,9007) + ELSE + DO ISEA=1, NSEA + WLV(ISEA) = 0. + ICE(ISEA) = 0. + END DO + WRITE (NDST,9008) +#endif END IF END IF ELSE @@ -937,7 +1063,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) RPOS = 1_8 + LRECL*(NREC-1_8) READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & TLEV, TICE, TRHO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading WLV' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading WLV' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -945,7 +1073,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & MIN(NSEA,IPART*NSIZE)) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading ICE' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading ICE' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -953,26 +1083,30 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & MIN(NSEA,IPART*NSIZE)) END DO -!/WRST DO IX=1, NX -!/WRST DO IPART=1,NPRTY2 -!/WRST NREC = NREC + 1 -!/WRST RPOS = 1_8 + LRECL*(NREC-1_8) -!/WRST READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & -!/WRST (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & -!/WRST MIN(NY,IPART*NSIZE)) -!/WRST END DO -!/WRST END DO -!/WRST DO IX=1, NX -!/WRST DO IPART=1,NPRTY2 -!/WRST NREC = NREC + 1 -!/WRST RPOS = 1_8 + LRECL*(NREC-1_8) -!/WRST READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & -!/WRST (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & -!/WRST MIN(NY,IPART*NSIZE)) -!/WRST END DO -!/WRST END DO +#ifdef W3_WRST + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO +#endif ALLOCATE ( MAPTMP(NY,NX) ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading MAPTMP' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading MAPTMP' +#endif DO IY=1, NY DO IPART=1,NPRTX2 NREC = NREC + 1 @@ -990,11 +1124,15 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! IF (GTYPE.EQ.UNGTYPE) THEN CALL SETUGIOBP -!/REF1 ELSE -!/REF1 CALL W3SETREF +#ifdef W3_REF1 + ELSE + CALL W3SETREF +#endif ENDIF ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading UST' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading UST' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -1002,7 +1140,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & MIN(NSEA,IPART*NSIZE)) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading USTDIR' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading USTDIR' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -1010,7 +1150,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & MIN(NSEA,IPART*NSIZE)) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading ASF' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading ASF' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -1018,7 +1160,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & MIN(NSEA,IPART*NSIZE)) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading FPIS' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading FPIS' +#endif DO IPART=1,NPART NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) @@ -1027,16 +1171,22 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) MIN(NSEA,IPART*NSIZE)) END DO IF (OARST) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading CUR' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading CUR' +#endif IF ( FLOGOA(1,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) CX(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) CY(1:NSEA) ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading ICEF' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading ICEF' +#endif IF ( FLOGOA(1,9) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading HS' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading HS' +#endif IF ( FLOGOA(2,1) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1044,7 +1194,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) HS(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading WLM' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading WLM' +#endif IF ( FLOGOA(2,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1052,7 +1204,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) WLM(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading T0M1' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading T0M1' +#endif IF ( FLOGOA(2,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1060,7 +1214,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) T0M1(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading T01' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading T01' +#endif IF ( FLOGOA(2,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1068,7 +1224,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) T01(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading FP0' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading FP0' +#endif IF ( FLOGOA(2,6) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1076,7 +1234,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) FP0(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading THM' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading THM' +#endif IF ( FLOGOA(2,7) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1084,7 +1244,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) THM(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading WNMEAN' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading WNMEAN' +#endif IF ( FLOGOA(2,19) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1092,7 +1254,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) WNMEAN(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading CHARN' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading CHARN' +#endif IF ( FLOGOA(5,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1100,7 +1264,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) CHARN(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TAUWI' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TAUWI' +#endif IF ( FLOGOA(5,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1112,7 +1278,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TWS' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TWS' +#endif IF ( FLOGOA(5,11) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1120,7 +1288,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) TWS(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TAUO' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TAUO' +#endif IF ( FLOGOA(6,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1132,7 +1302,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading BHD' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading BHD' +#endif IF ( FLOGOA(6,3) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1140,7 +1312,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) BHD(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading PHIOC' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading PHIOC' +#endif IF ( FLOGOA(6,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1148,7 +1322,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) PHIOC(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TUS' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TUS' +#endif IF ( FLOGOA(6,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1160,7 +1336,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading USS' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading USS' +#endif IF ( FLOGOA(6,6) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1172,7 +1350,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TAUICE' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TAUICE' +#endif IF ( FLOGOA(6,10) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1184,7 +1364,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TAUOC' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TAUOC' +#endif IF ( FLOGOA(6,13) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1196,7 +1378,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading UB' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading UB' +#endif IF ( FLOGOA(7,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1208,7 +1392,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDIF ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading PHIBBL' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading PHIBBL' +#endif IF ( FLOGOA(7,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM @@ -1216,7 +1402,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) IF (J .LE. NSEA) PHIBBL(I) = TMP(J) ENDDO ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before reading TAUBBL' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before reading TAUBBL' +#endif IF ( FLOGOA(7,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) @@ -1229,7 +1417,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ENDDO ENDIF ENDIF -!/T WRITE (NDST,9007) +#ifdef W3_T + WRITE (NDST,9007) +#endif ELSE TLEV(1) = -1 TLEV(2) = 0 @@ -1240,8 +1430,10 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) TIC1(2) = 0 TIC5(1) = -1 TIC5(2) = 0 -!/WRST WXNwrst = 0. -!/WRST WYNwrst = 0. +#ifdef W3_WRST + WXNwrst = 0. + WYNwrst = 0. +#endif WLV = 0. ICE = 0. ASF = 1. @@ -1279,7 +1471,9 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) PHIBBL = 0. TAUBBL = 0. ENDIF -!/T WRITE (NDST,9008) +#ifdef W3_T + WRITE (NDST,9008) +#endif END IF END IF ! @@ -1289,8 +1483,10 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) CLOSE ( NDSR ) END IF ! -!/DEBUGIO WRITE(740+IAPROC,*) 'W3IORS, step 9' -!/DEBUGIO FLUSH(740+IAPROC) +#ifdef W3_DEBUGIO + WRITE(740+IAPROC,*) 'W3IORS, step 9' + FLUSH(740+IAPROC) +#endif ! IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) IF (ALLOCATED(TMP)) DEALLOCATE(TMP) @@ -1301,12 +1497,18 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! Escape locations read errors : ! 800 CONTINUE -!/LN0 TYPE = 'WIND' -!/LN0 RSTYPE = 1 -!/SEED TYPE = 'CALM' -!/SEED RSTYPE = 4 -!/LN1 TYPE = 'CALM' -!/LN1 RSTYPE = 4 +#ifdef W3_LN0 + TYPE = 'WIND' + RSTYPE = 1 +#endif +#ifdef W3_SEED + TYPE = 'CALM' + RSTYPE = 4 +#endif +#ifdef W3_LN1 + TYPE = 'CALM' + RSTYPE = 4 +#endif IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR GOTO 100 ! @@ -1363,30 +1565,34 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ' THIS MAY CAUSE INSTABILITIES IN COUPLED CONFIGURATIONS') ! ! -!/T 9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & -!/T ' INXOUT : ',A,/ & -!/T ' WRITE : ',L10/ & -!/T ' NTPROC : ',I10/ & -!/T ' NAPROC : ',I10/ & -!/T ' IAPROC : ',I10/ & -!/T ' NAPRST : ',I10) -!/T 9001 FORMAT (' FNAME : ',A/ & -!/T ' LRECL : ',I10) -!/T 9002 FORMAT (' IDSTR : ',A/ & -!/T ' VERINI : ',A/ & -!/T ' GNAME : ',A/ & -!/T ' TYPE : ',A/ & -!/T ' NSEA : ',I10/ & -!/T ' NSEAL : ',I10/ & -!/T ' NSPEC : ',I10) -!/T 9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') -!/T 9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') -!/T 9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') -!/T 9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') -!/T 9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') -!/T 9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') -! -!/T 9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') +#ifdef W3_T + 9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & + ' INXOUT : ',A,/ & + ' WRITE : ',L10/ & + ' NTPROC : ',I10/ & + ' NAPROC : ',I10/ & + ' IAPROC : ',I10/ & + ' NAPRST : ',I10) + 9001 FORMAT (' FNAME : ',A/ & + ' LRECL : ',I10) + 9002 FORMAT (' IDSTR : ',A/ & + ' VERINI : ',A/ & + ' GNAME : ',A/ & + ' TYPE : ',A/ & + ' NSEA : ',I10/ & + ' NSEAL : ',I10/ & + ' NSPEC : ',I10) + 9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') + 9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') + 9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') + 9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') + 9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') + 9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') +#endif !/ !/ End of W3IORS ----------------------------------------------------- / !/ diff --git a/model/ftn/w3iosfmd.ftn b/model/src/w3iosfmd.F90 similarity index 83% rename from model/ftn/w3iosfmd.ftn rename to model/src/w3iosfmd.F90 index d0a8e8553..1edfaffc5 100644 --- a/model/ftn/w3iosfmd.ftn +++ b/model/src/w3iosfmd.F90 @@ -148,7 +148,9 @@ SUBROUTINE W3CPRT ( IMOD ) USE CONSTANTS ! USE W3PARTMD, ONLY: W3PART -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, MAPSTA, NK, NTH, SIG USE W3ADATMD, ONLY: WN, CG, U10, U10D, DW @@ -157,7 +159,9 @@ SUBROUTINE W3CPRT ( IMOD ) USE W3WDATMD, ONLY: VA, ASF USE W3ADATMD, ONLY: NSEALM USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif ! IMPLICIT NONE !/ @@ -172,11 +176,15 @@ SUBROUTINE W3CPRT ( IMOD ) INTEGER :: DIMXP, JSEA, ISEA, IX, IY, & IK, ITH, NP, TMPSIZ, OLDSIZ, FINSIZ INTEGER, SAVE :: TSFAC = 7 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: UABS, UDIR, DEPTH, FACT, E2(NK,NTH) REAL, ALLOCATABLE :: XP(:,:), TMP(:,:), TMP2(:,:) !/ -!/S CALL STRACE (IENT, 'W3CPRT') +#ifdef W3_S + CALL STRACE (IENT, 'W3CPRT') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -204,7 +212,9 @@ SUBROUTINE W3CPRT ( IMOD ) TMPSIZ = TSFAC * NSEAL ALLOCATE ( TMP(DIMP,TMPSIZ) ) ! -!/T WRITE (NDST,9000) DIMP, DIMXP, TMPSIZ +#ifdef W3_T + WRITE (NDST,9000) DIMP, DIMXP, TMPSIZ +#endif ! ! -------------------------------------------------------------------- / ! 1. Loop over sea points @@ -264,7 +274,9 @@ SUBROUTINE W3CPRT ( IMOD ) TMP(:,1:OLDSIZ) = TMP2(:,1:OLDSIZ) TMP(:,OLDSIZ+1:) = 0. DEALLOCATE ( TMP2 ) -!/T WRITE (NDST,9050) JSEA, OLDSIZ, TMPSIZ +#ifdef W3_T + WRITE (NDST,9050) JSEA, OLDSIZ, TMPSIZ +#endif END IF ! TMP(:,ICPRT(JSEA,2):ICPRT(JSEA,2)+NP) = XP(:,0:NP) @@ -278,9 +290,11 @@ SUBROUTINE W3CPRT ( IMOD ) ! FINSIZ = ICPRT(NSEAL+1,2) - 1 ! -!/T WRITE (NDST,9060) -!/T WRITE (NDST,9061) (CMPLX(JSEA,ICPRT(JSEA,:)),JSEA=1,MIN(100,NSEAL)) -!/T WRITE (NDST,9062) FINSIZ +#ifdef W3_T + WRITE (NDST,9060) + WRITE (NDST,9061) (CMPLX(JSEA,ICPRT(JSEA,:)),JSEA=1,MIN(100,NSEAL)) + WRITE (NDST,9062) FINSIZ +#endif ! ALLOCATE ( OUTPTS(IMOD)%OUT6%DTPRT(DIMP,MAX(1,FINSIZ)) ) DTPRT => OUTPTS(IMOD)%OUT6%DTPRT @@ -296,11 +310,13 @@ SUBROUTINE W3CPRT ( IMOD ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3CPRT : DIMP, DIMXP, TMPSIZ :',I2,2I6) -!/T 9050 FORMAT (' TEST W3CPRT : POINT',I4,', STORAGE',2I6) -!/T 9060 FORMAT (' TEST W3CPRT : COUNTERS FOR STORAGE (JSEA,NP,ST):') -!/T 9061 FORMAT (100(' ',5(2F9.0)/)) -!/T 9062 FORMAT (' TEST W3CPRT : FINAL STORAGE SIZE :',I6) +#ifdef W3_T + 9000 FORMAT (' TEST W3CPRT : DIMP, DIMXP, TMPSIZ :',I2,2I6) + 9050 FORMAT (' TEST W3CPRT : POINT',I4,', STORAGE',2I6) + 9060 FORMAT (' TEST W3CPRT : COUNTERS FOR STORAGE (JSEA,NP,ST):') + 9061 FORMAT (100(' ',5(2F9.0)/)) + 9062 FORMAT (' TEST W3CPRT : FINAL STORAGE SIZE :',I6) +#endif !/ !/ End of W3CPRT ----------------------------------------------------- / !/ @@ -378,10 +394,14 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) !/ USE CONSTANTS USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: FILEXT, NSEA, XGRD, YGRD, MAPSF, FLAGLL -!/MPI USE W3GDATMD, ONLY: NSEAL +#ifdef W3_MPI + USE W3GDATMD, ONLY: NSEAL +#endif USE W3WDATMD, ONLY: TIME, ASF USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPPRT, NAPERR, & IPASS => IPASS6, FLFORM, FNMPRE, OUTPTS, & @@ -389,13 +409,19 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) USE W3ADATMD, ONLY: DW, U10, U10D, CX, CY USE W3ADATMD, ONLY: NSEALM USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE -!/MPI USE W3ODATMD, ONLY: ICPRT, DTPRT, IT0PRT -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE W3ODATMD, ONLY: ICPRT, DTPRT, IT0PRT +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -407,9 +433,13 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) !/ INTEGER :: I, J, IERR, ISEA, JSEA, JAPROC, & IX, IY, IP, IOFF, DTSIZ=0 -!/MPI INTEGER :: ICSIZ, IERR_MPI, IT, & -!/MPI STATUS(MPI_STATUS_SIZE,1), JSLM -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: ICSIZ, IERR_MPI, IT, & + STATUS(MPI_STATUS_SIZE,1), JSLM +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, POINTER :: ICP(:,:) REAL :: X, Y, DEPTH, UABS, UDIR, CABS, CDIR REAL, POINTER :: DTP(:,:) @@ -424,12 +454,18 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/S CALL STRACE (IENT, 'W3IOSF') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOSF') +#endif ! IPASS = IPASS + 1 -!/MPI ICSIZ = 2 * ( NSEALM + 1 ) +#ifdef W3_MPI + ICSIZ = 2 * ( NSEALM + 1 ) +#endif ! -!/T WRITE (NDST,9000) IPASS, FLFORM, NDSPT, IMOD, IAPROC, NAPPRT +#ifdef W3_T + WRITE (NDST,9000) IPASS, FLFORM, NDSPT, IMOD, IAPROC, NAPPRT +#endif ! ! -------------------------------------------------------------------- / ! 1. Set up file ( IPASS = 1 and proper processor ) @@ -441,7 +477,9 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) I = LEN_TRIM(FILEXT) J = LEN_TRIM(FNMPRE) ! -!/T WRITE (NDST,9010) FNMPRE(:J)//'partition.'//FILEXT(:I) +#ifdef W3_T + WRITE (NDST,9010) FNMPRE(:J)//'partition.'//FILEXT(:I) +#endif ! IF ( FLFORM ) THEN OPEN (NDSPT,FILE=FNMPRE(:J)//'partition.'//FILEXT(:I), & @@ -491,19 +529,27 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) ! IF ( IAPROC.NE.NAPPRT .AND. IAPROC.LE.NAPROC ) THEN ! -!/T WRITE (NDST,9020) IAPROC, NAPPRT, NSEALM+1 +#ifdef W3_T + WRITE (NDST,9020) IAPROC, NAPPRT, NSEALM+1 +#endif ! -!/MPI IT = IT0PRT + IAPROC - 1 -!/MPI CALL MPI_SEND ( ICPRT, ICSIZ, MPI_REAL, NAPPRT-1, IT, & -!/MPI MPI_COMM_WAVE, IERR_MPI ) -!/MPI DTSIZ = ICPRT(NSEAL+1,2) - 1 +#ifdef W3_MPI + IT = IT0PRT + IAPROC - 1 + CALL MPI_SEND ( ICPRT, ICSIZ, MPI_REAL, NAPPRT-1, IT, & + MPI_COMM_WAVE, IERR_MPI ) + DTSIZ = ICPRT(NSEAL+1,2) - 1 +#endif ! -!/T WRITE (NDST,9021) IAPROC, NAPPRT, DTSIZ +#ifdef W3_T + WRITE (NDST,9021) IAPROC, NAPPRT, DTSIZ +#endif ! -!/MPI IT = IT0PRT + NAPROC + IAPROC - 1 -!/MPI IF ( DTSIZ .GT. 0 ) CALL MPI_SEND & -!/MPI ( DTPRT, 6*DTSIZ, MPI_REAL, NAPPRT-1, & -!/MPI IT, MPI_COMM_WAVE, IERR_MPI ) +#ifdef W3_MPI + IT = IT0PRT + NAPROC + IAPROC - 1 + IF ( DTSIZ .GT. 0 ) CALL MPI_SEND & + ( DTPRT, 6*DTSIZ, MPI_REAL, NAPPRT-1, & + IT, MPI_COMM_WAVE, IERR_MPI ) +#endif ! END IF ! @@ -527,24 +573,32 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) DO JAPROC=1, NAPROC IF ( IAPROC .EQ. JAPROC ) CYCLE ! -!/T WRITE (NDST,9030) JAPROC, NSEALM+1 -! -!/MPI ALLOCATE ( PROC(JAPROC)%ICPRT(NSEALM+1,2) ) -!/MPI ICP => PROC(JAPROC)%ICPRT -!/MPI IT = IT0PRT + JAPROC - 1 -!/MPI CALL MPI_RECV ( ICP, ICSIZ, MPI_REAL, JAPROC-1, IT, & -!/MPI MPI_COMM_WAVE, STATUS, IERR_MPI ) -!/MPI JSLM = 1 + (NSEA-JAPROC)/NAPROC -!/MPI DTSIZ = ICP(JSLM+1,2) - 1 -! -!/T WRITE (NDST,9031) JAPROC, DTSIZ -! -!/MPI ALLOCATE ( PROC(JAPROC)%DTPRT(DIMP,MAX(1,DTSIZ)) ) -!/MPI DTP => PROC(JAPROC)%DTPRT -!/MPI IT = IT0PRT + NAPROC + JAPROC - 1 -!/MPI IF ( DTSIZ .GT. 0 ) CALL MPI_RECV & -!/MPI ( DTP, DIMP*DTSIZ, MPI_REAL, JAPROC-1, & -!/MPI IT, MPI_COMM_WAVE, STATUS, IERR_MPI ) +#ifdef W3_T + WRITE (NDST,9030) JAPROC, NSEALM+1 +#endif +! +#ifdef W3_MPI + ALLOCATE ( PROC(JAPROC)%ICPRT(NSEALM+1,2) ) + ICP => PROC(JAPROC)%ICPRT + IT = IT0PRT + JAPROC - 1 + CALL MPI_RECV ( ICP, ICSIZ, MPI_REAL, JAPROC-1, IT, & + MPI_COMM_WAVE, STATUS, IERR_MPI ) + JSLM = 1 + (NSEA-JAPROC)/NAPROC + DTSIZ = ICP(JSLM+1,2) - 1 +#endif +! +#ifdef W3_T + WRITE (NDST,9031) JAPROC, DTSIZ +#endif +! +#ifdef W3_MPI + ALLOCATE ( PROC(JAPROC)%DTPRT(DIMP,MAX(1,DTSIZ)) ) + DTP => PROC(JAPROC)%DTPRT + IT = IT0PRT + NAPROC + JAPROC - 1 + IF ( DTSIZ .GT. 0 ) CALL MPI_RECV & + ( DTP, DIMP*DTSIZ, MPI_REAL, JAPROC-1, & + IT, MPI_COMM_WAVE, STATUS, IERR_MPI ) +#endif ! END DO ! @@ -623,10 +677,12 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) ! -------------------------------------------------------------------- / ! 5. Clean up data structure ! -!/MPI DO JAPROC=1, NAPROC -!/MPI IF ( IAPROC .EQ. JAPROC ) CYCLE -!/MPI DEALLOCATE ( PROC(JAPROC)%ICPRT, PROC(JAPROC)%DTPRT ) -!/MPI END DO +#ifdef W3_MPI + DO JAPROC=1, NAPROC + IF ( IAPROC .EQ. JAPROC ) CYCLE + DEALLOCATE ( PROC(JAPROC)%ICPRT, PROC(JAPROC)%DTPRT ) + END DO +#endif ! DEALLOCATE ( PROC ) ! @@ -653,18 +709,26 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) ' ERROR IN OPENING FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST W3IOSF : IPASS =',I4,', FLFROM = ',L1, & -!/T ', NDSPT =',I3,', IMOD =',I3,','/ & -!/T ' IAPROC, NAPPRT =',2I4) -!/T 9010 FORMAT (' TEST W3IOSF : OPENING NEW FILE [',A,']') -!/T 9020 FORMAT (' TEST W3IOSF : SENDING ICPRT FROM',I3,' TO',I3, & -!/T ' WITH SIZE :',I6) -!/MPIT 9021 FORMAT (' TEST W3IOSF : SENDING DTPRT FROM',I3,' TO',I3, & -!/MPIT ' WITH SIZE :',I6) -!/T 9030 FORMAT (' TEST W3IOSF : RECEIVING ICPRT FROM',I3, & -!/T ' WITH SIZE :',I6) -!/MPIT 9031 FORMAT (' TEST W3IOSF : RECEIVING DTPRT FROM',I3, & -!/MPIT ' WITH SIZE :',I6) +#ifdef W3_T + 9000 FORMAT (' TEST W3IOSF : IPASS =',I4,', FLFROM = ',L1, & + ', NDSPT =',I3,', IMOD =',I3,','/ & + ' IAPROC, NAPPRT =',2I4) + 9010 FORMAT (' TEST W3IOSF : OPENING NEW FILE [',A,']') + 9020 FORMAT (' TEST W3IOSF : SENDING ICPRT FROM',I3,' TO',I3, & + ' WITH SIZE :',I6) +#endif +#ifdef W3_MPIT + 9021 FORMAT (' TEST W3IOSF : SENDING DTPRT FROM',I3,' TO',I3, & + ' WITH SIZE :',I6) +#endif +#ifdef W3_T + 9030 FORMAT (' TEST W3IOSF : RECEIVING ICPRT FROM',I3, & + ' WITH SIZE :',I6) +#endif +#ifdef W3_MPIT + 9031 FORMAT (' TEST W3IOSF : RECEIVING DTPRT FROM',I3, & + ' WITH SIZE :',I6) +#endif !/ !/ End of W3IOSF ----------------------------------------------------- / !/ diff --git a/model/ftn/w3iotrmd.ftn b/model/src/w3iotrmd.F90 similarity index 76% rename from model/ftn/w3iotrmd.ftn rename to model/src/w3iotrmd.F90 index 78d4e989f..b9d80d1b4 100644 --- a/model/ftn/w3iotrmd.ftn +++ b/model/src/w3iotrmd.F90 @@ -190,25 +190,35 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) DPDX, DPDY, DQDX, DQDY, MAPSTA, MAPST2, & MAPFS, TH, DTH, SIG, DSIP, XFR, FILEXT USE W3GSRUMD, ONLY: W3GFCL -!/T USE W3GSRUMD, ONLY: W3GSUP +#ifdef W3_T + USE W3GSRUMD, ONLY: W3GSUP +#endif USE W3GDATMD, ONLY: XYB, MAXX, MAXY, GTYPE, UNGTYPE USE W3WDATMD, ONLY: TIME, UST USE W3ADATMD, ONLY: CG, DW, CX, CY, UA, UD, AS -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE +#endif USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPTRK, NAPERR, & IPASS => IPASS3, ATOLAST => TOLAST, & ADTOUT => DTOUT, O3INIT, STOP, MASK1, & MASK2, TRCKID, FNMPRE -!/MPI USE W3ODATMD, ONLY: IT0TRK, NRQTR, IRQTR +#ifdef W3_MPI + USE W3ODATMD, ONLY: IT0TRK, NRQTR, IRQTR +#endif !/ USE W3TIMEMD USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC USE w3SERVMD, ONLY : STRSPLIT -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -225,11 +235,19 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) TTIME(2), IX1, IX2, IY1, IY2, & IXX(4), IYY(4), I, J, ISEA, JSEA, & TOLAST(2) -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: NREAD, NTRACK, NSPECO, NLOCO -!/T3 INTEGER :: ISPT -!/MPI INTEGER :: IT, IROOT, IFROM, IERR_MPI -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: NREAD, NTRACK, NSPECO, NLOCO +#endif +#ifdef W3_T3 + INTEGER :: ISPT +#endif +#ifdef W3_MPI + INTEGER :: IT, IROOT, IFROM, IERR_MPI + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif REAL :: XN, YN, XT, YT, RD, X, Y, WX, WY, & SPEC(NK,NTH), FACTOR, ASPTRK(NTH,NK),& DTOUT, XX(4), YY(4) @@ -237,15 +255,21 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) LOGICAL :: FORMI, FLAG1, FLAG2, INGRID CHARACTER :: TRCKT*32, LINE*1024, TSTSTR*3, IDTST*34 CHARACTER(LEN=100) :: LIST(5) -!/T1 CHARACTER(LEN=17), SAVE :: TSTLOC = ' ' -!/T2 CHARACTER(LEN=1) :: MAPSTR(NX) +#ifdef W3_T1 + CHARACTER(LEN=17), SAVE :: TSTLOC = ' ' +#endif +#ifdef W3_T2 + CHARACTER(LEN=1) :: MAPSTR(NX) +#endif ! EQUIVALENCE (IXX(1),IX1) , (IXX(2),IX2) , & (IYY(1),IY1) , (IYY(3),IY2) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IOTR') +#ifdef W3_S + CALL STRACE (IENT, 'W3IOTR') +#endif ! CALL W3SETO ( IMOD, NDSE, NDST ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -277,20 +301,26 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! ASPTRK = 0. ! -!/T WRITE (NDST,9000) TIME +#ifdef W3_T + WRITE (NDST,9000) TIME +#endif ! -!/MPI IF ( NRQTR .NE. 0 ) THEN -!/MPI CALL MPI_STARTALL ( NRQTR, IRQTR, IERR_MPI ) -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQTR) ) -!/MPI CALL MPI_WAITALL ( NRQTR, IRQTR , STATUS, IERR_MPI ) -!/MPI DEALLOCATE ( STATUS ) -!/MPI END IF +#ifdef W3_MPI + IF ( NRQTR .NE. 0 ) THEN + CALL MPI_STARTALL ( NRQTR, IRQTR, IERR_MPI ) + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQTR) ) + CALL MPI_WAITALL ( NRQTR, IRQTR , STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) + END IF +#endif ! ! 1. First pass through routine ------------------------------------- * ! IF ( IPASS .EQ. 1 ) THEN ! -!/T WRITE (NDST,9010) TOLAST, DTOUT, NDSTI, NDSTO, FORMI +#ifdef W3_T + WRITE (NDST,9010) TOLAST, DTOUT, NDSTI, NDSTO, FORMI +#endif ! Removed by F.A. 2010/12/24 /T CALL W3GSUP ( GSU, NDST ) ! I = LEN_TRIM(FILEXT) @@ -299,14 +329,18 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! 1.a Open input file ! IF ( FORMI ) THEN -!/T WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & -!/T 'FORMATTED' +#ifdef W3_T + WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & + 'FORMATTED' +#endif OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & STATUS='OLD',ERR=800,FORM='FORMATTED',IOSTAT=IERR) READ (NDSTI,'(A)',ERR=801,END=802,IOSTAT=IERR) IDTST ELSE -!/T WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & -!/T 'UNFORMATTED' +#ifdef W3_T + WRITE (NDST,9011) FNMPRE(:J)//'track_i.'//FILEXT(:I), & + 'UNFORMATTED' +#endif OPEN (NDSTI,FILE=FNMPRE(:J)//'track_i.'//FILEXT(:I), & STATUS='OLD',ERR=800,FORM='UNFORMATTED',IOSTAT=IERR) READ (NDSTI,ERR=801,END=802,IOSTAT=IERR) IDTST @@ -317,8 +351,10 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! 1.b Open output file ! IF ( IAPROC .EQ. NAPTRK ) THEN -!/T WRITE (NDST,9012) FNMPRE(:J)//'track_o.'//FILEXT(:I), & -!/T 'UNFORMATTED' +#ifdef W3_T + WRITE (NDST,9012) FNMPRE(:J)//'track_o.'//FILEXT(:I), & + 'UNFORMATTED' +#endif OPEN (NDSTO,FILE=FNMPRE(:J)//'track_o.'//FILEXT(:I), & FORM='UNFORMATTED',ERR=810,IOSTAT=IERR) WRITE (NDSTO,ERR=811,IOSTAT=IERR) IDSTRO, FLAGLL, NK, & @@ -330,7 +366,9 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! ! 1.c Initialize maps ! -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif ! MASK2 = .FALSE. TRCKID = '' @@ -340,7 +378,9 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! 2. Preparations --------------------------------------------------- * ! 2.a Shift mask arrays ! -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif ! MASK1 = MASK2 MASK2 = .FALSE. @@ -353,25 +393,35 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! IF ( DSEC21(TIMEE,TOLAST) .LT. 0. ) THEN TIMEE = TOLAST -!/T WRITE (NDST,9022) +#ifdef W3_T + WRITE (NDST,9022) +#endif END IF ! -!/T WRITE (NDST,9021) TIMEB, TIMEE +#ifdef W3_T + WRITE (NDST,9021) TIMEB, TIMEE +#endif ! ! 3. Loop over input points ----------------------------------------- * ! -!/T NREAD = 0 -!/T NTRACK = 0 +#ifdef W3_T + NREAD = 0 + NTRACK = 0 +#endif ! ! 3.a Read new track point (infinite loop) ! IF ( STOP ) THEN TOLAST = TIME -!/T WRITE (NDST,9034) +#ifdef W3_T + WRITE (NDST,9034) +#endif GOTO 399 END IF ! -!/T1 WRITE (NDST,9030) +#ifdef W3_T1 + WRITE (NDST,9030) +#endif ! DO ! @@ -387,12 +437,16 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ELSE READ (NDSTI, ERR=801,END=390,IOSTAT=IERR) TTIME, XT, YT, TRCKT END IF -!/T NREAD = NREAD + 1 +#ifdef W3_T + NREAD = NREAD + 1 +#endif ! ! 3.b Point before time interval ! IF ( DSEC21(TIMEB,TTIME) .LT. 0. ) THEN -!/T1 WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO EARLY' +#ifdef W3_T1 + WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO EARLY' +#endif CYCLE END IF ! @@ -400,8 +454,12 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! IF ( DSEC21(TIMEE,TTIME) .GT. 0. ) THEN BACKSPACE (NDSTI) -!/T NREAD = NREAD - 1 -!/T1 WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO LATE' +#ifdef W3_T + NREAD = NREAD - 1 +#endif +#ifdef W3_T1 + WRITE (NDST,9031) TTIME,FACTOR*XT,FACTOR*YT,'TOO LATE' +#endif GOTO 399 END IF ! @@ -420,8 +478,10 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! coordinates are adjusted to avoid branch cut crossings) INGRID = W3GFCL( GSU, XT, YT, IXX, IYY, XX, YY ) IF ( .NOT. INGRID ) THEN -!/T1 WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, & -!/T1 'OUT OF GRID' +#ifdef W3_T1 + WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, & + 'OUT OF GRID' +#endif CYCLE END IF ! @@ -477,37 +537,45 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) MASK2(IY,IX) = MASK2(IY,IX) .OR. FLAG2 TRCKID(IY,IX) = TRCKT ! -!/T1 IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN -!/T1 IF ( MAPST2(IY,IX) .EQ. 0 ) THEN -!/T1 TSTLOC(4*J-3:4*J-1) = 'LND' -!/T1 ELSE -!/T1 TSTLOC(4*J-3:4*J-1) = 'XCL' -!/T1 END IF -!/T1 ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN -!/T1 IF ( MAPST2(IY,IX) .EQ. 1 ) THEN -!/T1 TSTLOC(4*J-3:4*J-1) = 'ICE' -!/T1 ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN -!/T1 TSTLOC(4*J-3:4*J-1) = 'DRY' -!/T1 ELSE -!/T1 TSTLOC(4*J-3:4*J-1) = 'DIS' -!/T1 END IF -!/T1 ELSE IF ( MAPSTA(IY,IX) .GT. 0 ) THEN -!/T1 TSTLOC(4*J-3:4*J-1) = 'SEA' -!/T1 END IF +#ifdef W3_T1 + IF ( MAPSTA(IY,IX) .EQ. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + TSTLOC(4*J-3:4*J-1) = 'LND' + ELSE + TSTLOC(4*J-3:4*J-1) = 'XCL' + END IF + ELSE IF ( MAPSTA(IY,IX) .LT. 0 ) THEN + IF ( MAPST2(IY,IX) .EQ. 1 ) THEN + TSTLOC(4*J-3:4*J-1) = 'ICE' + ELSE IF ( MAPST2(IY,IX) .EQ. 2 ) THEN + TSTLOC(4*J-3:4*J-1) = 'DRY' + ELSE + TSTLOC(4*J-3:4*J-1) = 'DIS' + END IF + ELSE IF ( MAPSTA(IY,IX) .GT. 0 ) THEN + TSTLOC(4*J-3:4*J-1) = 'SEA' + END IF +#endif ! END DO ! -!/T1 WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, TSTLOC, & -!/T1 IXX(1), IXX(2), IYY(1), IYY(3), FLAG1, FLAG2 +#ifdef W3_T1 + WRITE (NDST,9031) TTIME, FACTOR*XT, FACTOR*YT, TSTLOC, & + IXX(1), IXX(2), IYY(1), IYY(3), FLAG1, FLAG2 +#endif ! -!/T NTRACK = NTRACK + 1 +#ifdef W3_T + NTRACK = NTRACK + 1 +#endif ! END DO ! ! 3.g End of input file escape location ! 390 CONTINUE -!/T WRITE (NDST,9033) +#ifdef W3_T + WRITE (NDST,9033) +#endif STOP = .TRUE. ! ! 3.h Read end escape location @@ -516,27 +584,33 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! ! 3.h Mask test output ! -!/T2 WRITE (NDST,9035) -!/T2 DO IY=NY,1,-1 -!/T2 DO IX=1, NX -!/T2 IF ( MASK1(IY,IX) ) THEN -!/T2 MAPSTR(IX) = 'X' -!/T2 ELSE IF ( MASK2(IY,IX) ) THEN -!/T2 MAPSTR(IX) = 'x' -!/T2 ELSE -!/T2 MAPSTR(IX) = '.' -!/T2 END IF -!/T2 END DO -!/T2 WRITE (NDST,9036) MAPSTR -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9035) + DO IY=NY,1,-1 + DO IX=1, NX + IF ( MASK1(IY,IX) ) THEN + MAPSTR(IX) = 'X' + ELSE IF ( MASK2(IY,IX) ) THEN + MAPSTR(IX) = 'x' + ELSE + MAPSTR(IX) = '.' + END IF + END DO + WRITE (NDST,9036) MAPSTR + END DO +#endif ! ! 4. Write data for flagged locations ------------------------------- * ! -!/T NLOCO = 0 -!/T NSPECO = 0 -!/MPI IT = IT0TRK -!/MPI IROOT = NAPTRK - 1 -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,1) ) +#ifdef W3_T + NLOCO = 0 + NSPECO = 0 +#endif +#ifdef W3_MPI + IT = IT0TRK + IROOT = NAPTRK - 1 + ALLOCATE ( STATUS(MPI_STATUS_SIZE,1) ) +#endif ! DO IY=1, NY DO IX=1, NX @@ -549,8 +623,12 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) X = XGRD(IY,IX) Y = YGRD(IY,IX) ENDIF -!/MPI IT = IT + 1 -!/T NLOCO = NLOCO + 1 +#ifdef W3_MPI + IT = IT + 1 +#endif +#ifdef W3_T + NLOCO = NLOCO + 1 +#endif ! ! 4.a Status of point ! @@ -572,7 +650,9 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) TSTSTR = 'SEA' END IF ! -!/T IF ( TSTSTR .EQ. 'SEA' ) NSPECO = NSPECO + 1 +#ifdef W3_T + IF ( TSTSTR .EQ. 'SEA' ) NSPECO = NSPECO + 1 +#endif ! ! 4.b Determine where point is stored ! ( land point assumed stored on IAPROC = NAPTRK @@ -581,19 +661,29 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ISEA = MAPFS(IY,IX) IF ( ISEA .EQ. 0 ) THEN ISPROC = NAPTRK -!/T3 ISPT = -99 +#ifdef W3_T3 + ISPT = -99 +#endif ELSE CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/T3 ISPT = ISPROC +#ifdef W3_T3 + ISPT = ISPROC +#endif END IF -!/MPI IFROM = ISPROC - 1 +#ifdef W3_MPI + IFROM = ISPROC - 1 +#endif ! 4.c Spectrum is at local processor, but this is not the NAPTRK ! Send the spectrum to NAPTRK IF ( ISPROC.EQ.IAPROC .AND. IAPROC.NE.NAPTRK ) THEN -!/T3 WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'SENDING' -!/MPI CALL MPI_SEND ( A(1,1,JSEA), NSPEC, MPI_REAL, & -!/MPI IROOT, IT, MPI_COMM_WAVE, IERR_MPI ) +#ifdef W3_T3 + WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'SENDING' +#endif +#ifdef W3_MPI + CALL MPI_SEND ( A(1,1,JSEA), NSPEC, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IERR_MPI ) +#endif END IF ! ! 4.d This is NAPTRK, perform all output @@ -620,11 +710,15 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! ..... Non-local spectra ! ELSE -!/T3 WRITE (NDST,9040) IX, IY, ISEA, ISPT, & -!/T3 'RECEIVING' -!/MPI CALL MPI_RECV (ASPTRK, NSPEC, MPI_REAL,& -!/MPI IFROM, IT, MPI_COMM_WAVE, & -!/MPI STATUS, IERR_MPI ) +#ifdef W3_T3 + WRITE (NDST,9040) IX, IY, ISEA, ISPT, & + 'RECEIVING' +#endif +#ifdef W3_MPI + CALL MPI_RECV (ASPTRK, NSPEC, MPI_REAL,& + IFROM, IT, MPI_COMM_WAVE, & + STATUS, IERR_MPI ) +#endif ! DO IK=1, NK DO ITH=1, NTH @@ -654,7 +748,9 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! ! ..... End of action at NAPTRK ! -!/T3 WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'WRITTEN', time +#ifdef W3_T3 + WRITE (NDST,9040) IX, IY, ISEA, ISPT, 'WRITTEN', time +#endif END IF ! ! ..... Close IF for mask flag (top section 4) @@ -666,9 +762,13 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) END DO END DO ! -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + DEALLOCATE ( STATUS ) +#endif ! -!/T WRITE (NDST,9090) NTRACK, NREAD, NSPECO, NLOCO +#ifdef W3_T + WRITE (NDST,9090) NTRACK, NREAD, NSPECO, NLOCO +#endif ! GOTO 888 ! @@ -701,7 +801,9 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ! 880 CONTINUE ATOLAST(:,3) = TIME -!/T WRITE (NDST,9080) +#ifdef W3_T + WRITE (NDST,9080) +#endif ! 888 CONTINUE ! @@ -732,35 +834,51 @@ SUBROUTINE W3IOTR ( NDSINP, NDSOUT, A, IMOD ) ' ERROR IN WRITING TO FILE track_o.',A,' IOSTAT =',I6/ & ' (ADITIONAL) TRACK OUTPUT DISABLED '/) ! -!/T 9000 FORMAT (' TEST W3IOTR : MODEL TIME : ',I8.8,I7.6) -!/T 9010 FORMAT (' LAST OUTPUT TIME : ',I8.8,I7.6/ & -!/T ' OUTPUT TIME INC, : ',F6.0/ & -!/T ' UNIT NUMBERS : ',2I4/ & -!/T ' FORMAT FLAGS : ',L4) -!/T 9011 FORMAT (' TEST W3IOTR : OPENING INPUT : ',A,' [',A,']') -!/T 9012 FORMAT (' TEST W3IOTR : OPENING OUTPUT : ',A,' [',A,']') -!/T 9015 FORMAT (' TEST W3IOTR : PREPARING MASKS') -! -!/T 9020 FORMAT (' TEST W3IOTR : SHIFTING MASKS') -!/T 9021 FORMAT (' TEST W3IOTR : OUTPUT TIME FRAME: ',I8.8,I7.6/ & -!/T ' ',I8.8,I7.6) -!/T 9022 FORMAT (' TEST W3IOTR : ENDING TIME REACHED') -! -!/T1 9030 FORMAT (' TEST W3IOTR : POINT-BY-POINT STATUS') -!/T1 9031 FORMAT (' ',I8.8,I7.6,2F9.2,1X,A,1X,4I4,2L3) -!/T 9033 FORMAT (' TEST W3IOTR : END OF INPUT FILE') -!/T 9034 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED') -!/T2 9035 FORMAT (' TEST W3IOTR : DUMP OF MAPS : ') -!/T2 9036 FORMAT (132A1) -! -!/T3 9040 FORMAT (' TEST W3IOTR : POINT',2I4,' (',I6,')', & -!/T3 ' ON PROCESS',I4,2X,A,I10.8,I7.6) -!/T 9090 FORMAT (' TEST W3IOTR : NUMBER OF TRACK P: ',I10, & -!/T ' (OUT OF',I10,')'/ & -!/T ' NUMBER OF SPECTRA: ',I10, & -!/T ' (OUT OF',I10,')') -! -!/T 9080 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED.') +#ifdef W3_T + 9000 FORMAT (' TEST W3IOTR : MODEL TIME : ',I8.8,I7.6) + 9010 FORMAT (' LAST OUTPUT TIME : ',I8.8,I7.6/ & + ' OUTPUT TIME INC, : ',F6.0/ & + ' UNIT NUMBERS : ',2I4/ & + ' FORMAT FLAGS : ',L4) + 9011 FORMAT (' TEST W3IOTR : OPENING INPUT : ',A,' [',A,']') + 9012 FORMAT (' TEST W3IOTR : OPENING OUTPUT : ',A,' [',A,']') + 9015 FORMAT (' TEST W3IOTR : PREPARING MASKS') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3IOTR : SHIFTING MASKS') + 9021 FORMAT (' TEST W3IOTR : OUTPUT TIME FRAME: ',I8.8,I7.6/ & + ' ',I8.8,I7.6) + 9022 FORMAT (' TEST W3IOTR : ENDING TIME REACHED') +#endif +! +#ifdef W3_T1 + 9030 FORMAT (' TEST W3IOTR : POINT-BY-POINT STATUS') + 9031 FORMAT (' ',I8.8,I7.6,2F9.2,1X,A,1X,4I4,2L3) +#endif +#ifdef W3_T + 9033 FORMAT (' TEST W3IOTR : END OF INPUT FILE') + 9034 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED') +#endif +#ifdef W3_T2 + 9035 FORMAT (' TEST W3IOTR : DUMP OF MAPS : ') + 9036 FORMAT (132A1) +#endif +! +#ifdef W3_T3 + 9040 FORMAT (' TEST W3IOTR : POINT',2I4,' (',I6,')', & + ' ON PROCESS',I4,2X,A,I10.8,I7.6) +#endif +#ifdef W3_T + 9090 FORMAT (' TEST W3IOTR : NUMBER OF TRACK P: ',I10, & + ' (OUT OF',I10,')'/ & + ' NUMBER OF SPECTRA: ',I10, & + ' (OUT OF',I10,')') +#endif +! +#ifdef W3_T + 9080 FORMAT (' TEST W3IOTR : OUTPUT TYPE DISABLED.') +#endif !/ !/ End of W3IOTR ----------------------------------------------------- / !/ diff --git a/model/ftn/w3macros.h b/model/src/w3macros.h similarity index 100% rename from model/ftn/w3macros.h rename to model/src/w3macros.h diff --git a/model/ftn/w3meminfo.ftn b/model/src/w3meminfo.F90 similarity index 94% rename from model/ftn/w3meminfo.ftn rename to model/src/w3meminfo.F90 index 443d2d598..6f4a0fdc6 100644 --- a/model/ftn/w3meminfo.ftn +++ b/model/src/w3meminfo.F90 @@ -43,7 +43,9 @@ module MallocInfo_m ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use :: iso_c_binding implicit none @@ -54,11 +56,15 @@ module MallocInfo_m !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XXXX') +#ifdef W3_S + CALL STRACE (IENT, 'W3XXXX') +#endif !> This structure type is used to return information about the dynamic memory allocator. type, bind(c) :: MallInfo_t @@ -152,7 +158,9 @@ subroutine getMallocInfo(malinfo) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! implicit none !/ @@ -162,11 +170,15 @@ subroutine getMallocInfo(malinfo) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XXXX') +#ifdef W3_S + CALL STRACE (IENT, 'W3XXXX') +#endif type(MallInfo_t), intent(out) :: malinfo malinfo = mallinfo() end subroutine @@ -216,7 +228,9 @@ subroutine printMallInfo(ihdnl,malinfo) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! implicit none !/ @@ -226,11 +240,15 @@ subroutine printMallInfo(ihdnl,malinfo) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XXXX') +#ifdef W3_S + CALL STRACE (IENT, 'W3XXXX') +#endif real :: ib2m integer(8) :: vmsize, vmRSS integer, intent(in) :: ihdnl @@ -307,7 +325,9 @@ function getVmSize() result(vmsize) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! implicit none !/ @@ -317,11 +337,15 @@ function getVmSize() result(vmsize) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XXXX') +#ifdef W3_S + CALL STRACE (IENT, 'W3XXXX') +#endif integer(8) :: vmsize character(len=80) :: stat_key, stat_value ! @@ -387,7 +411,9 @@ function getVmRSS() result(vmRSS) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! implicit none !/ @@ -397,11 +423,15 @@ function getVmRSS() result(vmRSS) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XXXX') +#ifdef W3_S + CALL STRACE (IENT, 'W3XXXX') +#endif integer(8) :: vmRSS character(len=80) :: stat_key, stat_value ! diff --git a/model/ftn/w3metamd.ftn b/model/src/w3metamd.F90 similarity index 100% rename from model/ftn/w3metamd.ftn rename to model/src/w3metamd.F90 diff --git a/model/ftn/w3netcdf.ftn b/model/src/w3netcdf.F90 similarity index 89% rename from model/ftn/w3netcdf.ftn rename to model/src/w3netcdf.F90 index 8489f47d9..84cd70344 100644 --- a/model/ftn/w3netcdf.ftn +++ b/model/src/w3netcdf.F90 @@ -44,7 +44,9 @@ MODULE W3NETCDF ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -52,7 +54,9 @@ MODULE W3NETCDF !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ INTEGER TIME0_NETCDF_QAD(2) INTEGER TIMEN_NETCDF_QAD(2) @@ -103,7 +107,9 @@ SUBROUTINE DATE2JD(year, month, day, hour, min, sec, eJD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -114,11 +120,15 @@ SUBROUTINE DATE2JD(year, month, day, hour, min, sec, eJD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: year, month, day, hour, min, sec @@ -189,7 +199,9 @@ SUBROUTINE DATE_ConvertSix2mjd(year, month, day, hour, min, sec, eMJD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -200,11 +212,15 @@ SUBROUTINE DATE_ConvertSix2mjd(year, month, day, hour, min, sec, eMJD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: year, month, day, hour, min, sec @@ -263,7 +279,9 @@ SUBROUTINE DATE_ConvertString2six(year, month, day, hour, min, sec, eTimeStr) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -274,11 +292,15 @@ SUBROUTINE DATE_ConvertString2six(year, month, day, hour, min, sec, eTimeStr) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(out) :: year, month, day, hour, min, sec @@ -354,7 +376,9 @@ SUBROUTINE DATE_ConvertSix2string(year, month, day, hour, min, sec, eTimeStr) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -365,11 +389,15 @@ SUBROUTINE DATE_ConvertSix2string(year, month, day, hour, min, sec, eTimeStr) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: year, month, day, hour, min, sec @@ -425,7 +453,9 @@ SUBROUTINE MONTH_LEN(year, month, lenmonth) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -436,11 +466,15 @@ SUBROUTINE MONTH_LEN(year, month, lenmonth) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: year, month @@ -518,7 +552,9 @@ SUBROUTINE WW3_TO_SIX(TIME, year, month, day, hour, min, sec) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -529,11 +565,15 @@ SUBROUTINE WW3_TO_SIX(TIME, year, month, day, hour, min, sec) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER, intent(in) :: TIME(2) @@ -597,7 +637,9 @@ SUBROUTINE WW3_TO_JD(TIME, eJD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, only : IAPROC @@ -609,11 +651,15 @@ SUBROUTINE WW3_TO_JD(TIME, eJD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER, intent(in) :: TIME(2) @@ -673,7 +719,9 @@ SUBROUTINE WW3_TO_string(TIME, eTimeStr) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -683,11 +731,15 @@ SUBROUTINE WW3_TO_string(TIME, eTimeStr) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER, intent(in) :: TIME(2) @@ -744,7 +796,9 @@ SUBROUTINE JD2DATE(year, month, day, hour, min, sec, eJD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -754,11 +808,15 @@ SUBROUTINE JD2DATE(year, month, day, hour, min, sec, eJD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(out) :: year, month, day, hour, min, sec real(8), intent(in) :: eJD @@ -859,7 +917,9 @@ SUBROUTINE CT2MJD(STIME,XMJD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -870,11 +930,15 @@ SUBROUTINE CT2MJD(STIME,XMJD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! CHARACTER(LEN=15), INTENT(IN) :: STIME @@ -932,7 +996,9 @@ SUBROUTINE MJD2CT(XMJD,STIME) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -942,11 +1008,15 @@ SUBROUTINE MJD2CT(XMJD,STIME) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! CHARACTER(LEN=15), INTENT(OUT) :: STIME real(8), INTENT(IN) :: XMJD @@ -1005,7 +1075,9 @@ SUBROUTINE IsFullHour(XMJD,result) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1015,11 +1087,15 @@ SUBROUTINE IsFullHour(XMJD,result) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), INTENT(IN) :: XMJD LOGICAL, INTENT(OUT) :: result @@ -1082,7 +1158,9 @@ SUBROUTINE GENERIC_NETCDF_ERROR(CallFct, idx, iret) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE NETCDF implicit none @@ -1093,11 +1171,15 @@ SUBROUTINE GENERIC_NETCDF_ERROR(CallFct, idx, iret) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: iret, idx character(*), intent(in) :: CallFct @@ -1157,11 +1239,15 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/PDLIB use yowElementpool, only: ne_global, INE_global -!/PDLIB use yowNodepool, only: np_global +#ifdef W3_PDLIB + use yowElementpool, only: ne_global, INE_global + use yowNodepool, only: np_global +#endif implicit none !/ !/ ------------------------------------------------------------------- / @@ -1170,11 +1256,15 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(inout) :: STATUS(np_global) @@ -1296,7 +1386,9 @@ SUBROUTINE NETCDF_QAD_DEFINE_VAR(VarName, nx_dims, ny_dims, ntime_dims, ncid) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : GTYPE, UNGTYPE @@ -1309,11 +1401,15 @@ SUBROUTINE NETCDF_QAD_DEFINE_VAR(VarName, nx_dims, ny_dims, ntime_dims, ncid) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: nx_dims, ny_dims, ntime_dims, ncid @@ -1376,7 +1472,9 @@ SUBROUTINE NETCDF_QAD_PUT_VAR(VarName, fid, nVar, VAR_TOT, ncid, pos) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : GTYPE, UNGTYPE @@ -1390,11 +1488,15 @@ SUBROUTINE NETCDF_QAD_PUT_VAR(VarName, fid, nVar, VAR_TOT, ncid, pos) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL, intent(in) :: VAR_TOT(nVar, NSEA) @@ -1476,7 +1578,9 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY(IMOD, DTG) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE @@ -1487,11 +1591,15 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY(IMOD, DTG) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: IMOD @@ -1555,7 +1663,9 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3WDATMD, ONLY : WLV @@ -1566,13 +1676,19 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) USE W3GDATMD, ONLY : MAPSTA, XGRD, YGRD, NX, NY, DDEN, FLAGLL USE W3GDATMD, ONLY : ECOS, ESIN, SIG, DTH, XFR, IOBP, IOBPD USE W3GDATMD, ONLY : NK, NTH, NSEA, NSEAL, NTRI, XYB, TRIGP, GRIDS -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WCMP +#ifdef W3_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP +#endif +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WCMP +#endif USE W3ODATMD, only : IAPROC, NAPROC, NTPROC -!/PDLIB USE yowNodepool, only: ListIPLG, ListNP, ListNPA -!/PDLIB USE yowNodepool, only: np, iplg -!/PDLIB use yowDatapool, only: rtype -!/PDLIB USE yowRankModule, only : IPGL_TO_PROC +#ifdef W3_PDLIB + USE yowNodepool, only: ListIPLG, ListNP, ListNPA + USE yowNodepool, only: np, iplg + use yowDatapool, only: rtype + USE yowRankModule, only : IPGL_TO_PROC +#endif USE W3PARALL, only: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC USE W3GDATMD, only : MAPFS USE NETCDF @@ -1585,15 +1701,21 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! -!/MPI INCLUDE "mpif.h" -!/MPI integer :: istatus(MPI_STATUS_SIZE) +#ifdef W3_MPI + INCLUDE "mpif.h" + integer :: istatus(MPI_STATUS_SIZE) +#endif integer, intent(in) :: IMOD real, intent(in) :: DTG real(8), intent(in) :: eTime @@ -1648,12 +1770,16 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) REAL, PARAMETER :: THR_FP0 = 0.00000001 DOPEAK = .true. IF (GRIDS(IMOD)%GTYPE .ne. UNGTYPE) THEN -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Exiting because the grid is not unstructured' -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Exiting because the grid is not unstructured' + FLUSH(740+IAPROC) +#endif RETURN END IF -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Entering the NETCDF output routine' -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Entering the NETCDF output routine' + FLUSH(740+IAPROC) +#endif ! ! There are several arrays in WW3 for handling boundary condition ! One is the MAPSTA array which is defined in ww3_grid (see computation @@ -1677,7 +1803,9 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) ISEA=MAPFS(1,IX) eMap=MAPSTA(1,IX) eIOBP=IOBP(IX) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'IX=', IX, ' IOBP/MAP=', eIOBP, eMap +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'IX=', IX, ' IOBP/MAP=', eIOBP, eMap +#endif IF (ISEA .eq. 0) THEN nbBound_ISEA=nbBound_ISEA+1 END IF @@ -1704,14 +1832,16 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) sumIOBP_NX = sumIOBP_NX + 1 - eIOBP_NX sumIOBP_relevant = sumIOBP_relevant + 1 - eIOBPrel END DO -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'nbIOBP0=', nbIOBP0 -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'nbIOBP1=', nbIOBP1 -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'nbMAP2_IOBP0=', nbMAP2_IOBP0 -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'nbBound_ISEA=', nbBound_ISEA -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'nbBound_IOBP=', nbBound_IOBP -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'sumIOBP_NX=', sumIOBP_NX -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'sumIOBP_relevant=', sumIOBP_relevant -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'nbIOBP0=', nbIOBP0 + WRITE(740+IAPROC,*) 'nbIOBP1=', nbIOBP1 + WRITE(740+IAPROC,*) 'nbMAP2_IOBP0=', nbMAP2_IOBP0 + WRITE(740+IAPROC,*) 'nbBound_ISEA=', nbBound_ISEA + WRITE(740+IAPROC,*) 'nbBound_IOBP=', nbBound_IOBP + WRITE(740+IAPROC,*) 'sumIOBP_NX=', sumIOBP_NX + WRITE(740+IAPROC,*) 'sumIOBP_relevant=', sumIOBP_relevant + FLUSH(740+IAPROC) +#endif allocate(ListIdx(IWBMNPGL), SPPARM(8,IWBMNPGL), stat=istat) idx=0 DO IX=1,NX @@ -1815,27 +1945,31 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) VAR_TOT_NSEA(11, ISEA)=U10(ISEA) VAR_TOT_NSEA(12, ISEA)=ETX VAR_TOT_NSEA(13, ISEA)=ETY -!/SETUP VAR_TOT_NSEA(14, ISEA)=ZETA_SETUP(ISEA) +#ifdef W3_SETUP + VAR_TOT_NSEA(14, ISEA)=ZETA_SETUP(ISEA) +#endif Status(ISEA)=1 END DO ! ! Now find global arrays ! -!/MPI IF (IAPROC .eq. 1) THEN -!/MPI DO iProc=2,NAPROC -!/MPI CALL MPI_RECV(rVect,NSEA*nVar,MPI_REAL, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) -!/MPI CALL MPI_RECV(rStatus,NSEA,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) -!/MPI DO I=1,NSEA -!/MPI IF (rStatus(I) .eq. 1) THEN -!/MPI VAR_TOT_NSEA(:,I)=rVect(:,I) -!/MPI Status(I)=1 -!/MPI END IF -!/MPI END DO -!/MPI END DO -!/MPI ELSE -!/MPI CALL MPI_SEND(VAR_TOT_NSEA,NSEA*nVar,MPI_REAL, 0, 19, MPI_COMM_WCMP, ierr) -!/MPI CALL MPI_SEND(Status,NSEA,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) -!/MPI END IF +#ifdef W3_MPI + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect,NSEA*nVar,MPI_REAL, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(rStatus,NSEA,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) + DO I=1,NSEA + IF (rStatus(I) .eq. 1) THEN + VAR_TOT_NSEA(:,I)=rVect(:,I) + Status(I)=1 + END IF + END DO + END DO + ELSE + CALL MPI_SEND(VAR_TOT_NSEA,NSEA*nVar,MPI_REAL, 0, 19, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status,NSEA,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) + END IF +#endif allocate(WBACbound(NK, NTH, IWBMNPGL), stat=istat) nbexport=0 DO IP=1,NP @@ -1862,66 +1996,78 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) END DO END IF END DO -!/MPI!/DEBUGNETCDF WRITE(740+IAPROC,*) 'NAPROC=', NAPROC -!/MPI!/DEBUGNETCDF FLUSH(740+IAPROC) -!/MPI IF (GTYPE .eq. UNGTYPE) THEN -!/MPI allocate(iVect(1), stat=istat) -!/MPI ListFirst=0 -!/MPI DO IPROC=2,NAPROC -!/MPI ListFirst(IPROC) = ListFirst(IPROC-1) + ListNPA(IPROC-1) -!/MPI END DO -!/MPI IF (IAPROC .eq. 1) THEN -!/MPI DO IPROC=2,NAPROC -!/MPI CALL MPI_RECV(iVect,1,MPI_INT, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) -!/MPI IF (iVect(1) .gt. 0) THEN -!/MPI allocate(WBACexch(NK,NTH,iVect(1)), stat=istat) -!/MPI!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Before MPI_RECV, tag 21' -!/MPI!/DEBUGNETCDF FLUSH(740+IAPROC) -!/MPI CALL MPI_RECV(WBACexch,NK*NTH*iVect(1),MPI_REAL, iProc-1, 21, MPI_COMM_WCMP, istatus, ierr) -!/MPI!/DEBUGNETCDF WRITE(740+IAPROC,*) 'After MPI_RECV, tag 21' -!/MPI!/DEBUGNETCDF FLUSH(740+IAPROC) -!/MPI NPloc=ListNP(IPROC) -!/MPI idx=0 -!/MPI DO IP=1,NPloc -!/MPI IP_glob=ListIPLG(IP + ListFirst(IPROC)) -!/MPI IF (IOBP_relevant(IP_glob) .eq. 2) THEN -!/MPI idx=idx + 1 -!/MPI idxbnd=ListIndexes(IP_glob) -!/MPI WBACbound(:,:,idxbnd)=WBACexch(:,:,idx) -!/MPI END IF -!/MPI END DO -!/MPI deallocate(WBACexch) -!/MPI END IF -!/MPI END DO -!/MPI ELSE -!/MPI iVect(1)=nbexport -!/MPI CALL MPI_SEND(iVect,1,MPI_INT, 0, 19, MPI_COMM_WCMP, ierr) -!/MPI IF (nbexport .gt. 0) THEN -!/MPI allocate(WBACexch(NK,NTH,nbexport), stat=istat) -!/MPI idx=0 -!/MPI DO IP=1,NP -!/MPI IP_glob=iplg(IP) -!/MPI IF (IOBP_relevant(IP_glob) .eq. 2) THEN -!/MPI ISEA=MAPFS(1,IP_glob) -!/MPI CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/MPI idx=idx+1 -!/MPI DO IK=1,NK -!/MPI DO ITH=1,NTH -!/MPI ISP = ITH + (IK-1)*NTH -!/MPI WBACexch(IK,ITH,idx) = VA(ISP,JSEA) -!/MPI END DO -!/MPI END DO -!/MPI END IF -!/MPI END DO -!/MPI!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Before MPI_SEND, tag 21' -!/MPI!/DEBUGNETCDF FLUSH(740+IAPROC) -!/MPI CALL MPI_SEND(WBACexch,NSPEC*nbexport,MPI_REAL, 0, 21, MPI_COMM_WCMP, ierr) -!/MPI!/DEBUGNETCDF WRITE(740+IAPROC,*) 'After MPI_SEND, tag 21' -!/MPI!/DEBUGNETCDF FLUSH(740+IAPROC) -!/MPI deallocate(WBACexch) -!/MPI END IF -!/MPI END IF -!/MPI END IF +#ifdef W3_MPI +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + FLUSH(740+IAPROC) +#endif + IF (GTYPE .eq. UNGTYPE) THEN + allocate(iVect(1), stat=istat) + ListFirst=0 + DO IPROC=2,NAPROC + ListFirst(IPROC) = ListFirst(IPROC-1) + ListNPA(IPROC-1) + END DO + IF (IAPROC .eq. 1) THEN + DO IPROC=2,NAPROC + CALL MPI_RECV(iVect,1,MPI_INT, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) + IF (iVect(1) .gt. 0) THEN + allocate(WBACexch(NK,NTH,iVect(1)), stat=istat) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Before MPI_RECV, tag 21' + FLUSH(740+IAPROC) +#endif + CALL MPI_RECV(WBACexch,NK*NTH*iVect(1),MPI_REAL, iProc-1, 21, MPI_COMM_WCMP, istatus, ierr) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'After MPI_RECV, tag 21' + FLUSH(740+IAPROC) +#endif + NPloc=ListNP(IPROC) + idx=0 + DO IP=1,NPloc + IP_glob=ListIPLG(IP + ListFirst(IPROC)) + IF (IOBP_relevant(IP_glob) .eq. 2) THEN + idx=idx + 1 + idxbnd=ListIndexes(IP_glob) + WBACbound(:,:,idxbnd)=WBACexch(:,:,idx) + END IF + END DO + deallocate(WBACexch) + END IF + END DO + ELSE + iVect(1)=nbexport + CALL MPI_SEND(iVect,1,MPI_INT, 0, 19, MPI_COMM_WCMP, ierr) + IF (nbexport .gt. 0) THEN + allocate(WBACexch(NK,NTH,nbexport), stat=istat) + idx=0 + DO IP=1,NP + IP_glob=iplg(IP) + IF (IOBP_relevant(IP_glob) .eq. 2) THEN + ISEA=MAPFS(1,IP_glob) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + idx=idx+1 + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + WBACexch(IK,ITH,idx) = VA(ISP,JSEA) + END DO + END DO + END IF + END DO +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Before MPI_SEND, tag 21' + FLUSH(740+IAPROC) +#endif + CALL MPI_SEND(WBACexch,NSPEC*nbexport,MPI_REAL, 0, 21, MPI_COMM_WCMP, ierr) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'After MPI_SEND, tag 21' + FLUSH(740+IAPROC) +#endif + deallocate(WBACexch) + END IF + END IF + END IF +#endif IF (IAPROC .eq. 1) THEN nbIncorr=0 DO I=1,NSEA @@ -2047,7 +2193,9 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) CALL NETCDF_QAD_DEFINE_VAR("DM", nx_dims, ny_dims, ntime_dims, ncid) CALL NETCDF_QAD_DEFINE_VAR("ETOTC", nx_dims, ny_dims, ntime_dims, ncid) CALL NETCDF_QAD_DEFINE_VAR("ETOTS", nx_dims, ny_dims, ntime_dims, ncid) -!/SETUP CALL NETCDF_QAD_DEFINE_VAR("ZETA_SETUP", nx_dims, ny_dims, ntime_dims, ncid) +#ifdef W3_SETUP + CALL NETCDF_QAD_DEFINE_VAR("ZETA_SETUP", nx_dims, ny_dims, ntime_dims, ncid) +#endif ! IF ((GTYPE .eq. UNGTYPE).and.(IWBMNPGL.gt.0)) THEN iret=nf90_def_var(ncid,"SPPARM",NF90_REAL,(/ eight_dims, iwbmnpgl_dims, ntime_dims /),var_id) @@ -2156,14 +2304,18 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) CALL GENERIC_NETCDF_ERROR(CallFct, 58, iret) ! CALL WW3_TO_JD(TIME0_NETCDF_QAD, eJD) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'OUTPUT_NETCDF_QUICK_AND_DIRTY' -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'QAD: eJD=', eJD -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'QAD: DTG=', DTG -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'QAD: recs_his=', recs_his +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'OUTPUT_NETCDF_QUICK_AND_DIRTY' + WRITE(740+IAPROC,*) 'QAD: eJD=', eJD + WRITE(740+IAPROC,*) 'QAD: DTG=', DTG + WRITE(740+IAPROC,*) 'QAD: recs_his=', recs_his +#endif ! pos=recs_his+1 -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'pos=', pos -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'pos=', pos + FLUSH(740+IAPROC) +#endif eVar(1)=eTime iret=nf90_inq_varid(ncid, "ocean_time", var_id) CALL GENERIC_NETCDF_ERROR(CallFct, 59, iret) @@ -2204,8 +2356,10 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) CALL GENERIC_NETCDF_ERROR(CallFct, 65, iret) iret=nf90_put_var(ncid,var_id,IOBP,start = (/1, pos/), count = (/ NX, 1 /)) CALL GENERIC_NETCDF_ERROR(CallFct, 66, iret) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'sum(IOBP)=', sum(IOBP) -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'sum(IOBP)=', sum(IOBP) + FLUSH(740+IAPROC) +#endif ! iret=nf90_inq_varid(ncid, "IOBPD", var_id) CALL GENERIC_NETCDF_ERROR(CallFct, 67, iret) @@ -2226,7 +2380,9 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) CALL NETCDF_QAD_PUT_VAR("WINDMAG", 11, nVar, VAR_TOT_NSEA, ncid, pos) CALL NETCDF_QAD_PUT_VAR("ETOTC", 12, nVar, VAR_TOT_NSEA, ncid, pos) CALL NETCDF_QAD_PUT_VAR("ETOTS", 13, nVar, VAR_TOT_NSEA, ncid, pos) -!/SETUP CALL NETCDF_QAD_PUT_VAR("ZETA_SETUP", 14, nVar, VAR_TOT_NSEA, ncid, pos) +#ifdef W3_SETUP + CALL NETCDF_QAD_PUT_VAR("ZETA_SETUP", 14, nVar, VAR_TOT_NSEA, ncid, pos) +#endif IF (GTYPE .eq. UNGTYPE) THEN DO IWB=1,IWBMNPGL IX=ListIdx(IWB) @@ -2246,17 +2402,21 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) END IF END DO ! -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Before writing of SPPARM' -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'pos=', pos -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'IWBMNPGL=', IWBMNPGL -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Before writing of SPPARM' + WRITE(740+IAPROC,*) 'pos=', pos + WRITE(740+IAPROC,*) 'IWBMNPGL=', IWBMNPGL + FLUSH(740+IAPROC) +#endif IF (IWBMNPGL .gt. 0) THEN iret=nf90_inq_varid(ncid, "SPPARM", var_id) CALL GENERIC_NETCDF_ERROR(CallFct, 69, iret) iret=nf90_put_var(ncid,var_id,SPPARM,start = (/1,1,pos/), count = (/ 8,IWBMNPGL /)) CALL GENERIC_NETCDF_ERROR(CallFct, 70, iret) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'After writing of SPPARM' -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'After writing of SPPARM' + FLUSH(740+IAPROC) +#endif ! iret=nf90_inq_varid(ncid, "WBAC", var_id) CALL GENERIC_NETCDF_ERROR(CallFct, 71, iret) @@ -2265,19 +2425,23 @@ SUBROUTINE OUTPUT_NETCDF_QUICK_AND_DIRTY_KERNEL(IMOD, DTG, eTime) END IF END IF ! -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'HS values' -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'HS(min/max)=', minval(VAR_TOT_NSEA(1,:)), maxval(VAR_TOT_NSEA(1,:)) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Ucurr(min/max)=', minval(VAR_TOT_NSEA(2,:)), maxval(VAR_TOT_NSEA(2,:)) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Vcurr(min/max)=', minval(VAR_TOT_NSEA(3,:)), maxval(VAR_TOT_NSEA(3,:)) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'sum(varWrite)=', sum(varWrite) -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'HS values' + WRITE(740+IAPROC,*) 'HS(min/max)=', minval(VAR_TOT_NSEA(1,:)), maxval(VAR_TOT_NSEA(1,:)) + WRITE(740+IAPROC,*) 'Ucurr(min/max)=', minval(VAR_TOT_NSEA(2,:)), maxval(VAR_TOT_NSEA(2,:)) + WRITE(740+IAPROC,*) 'Vcurr(min/max)=', minval(VAR_TOT_NSEA(3,:)), maxval(VAR_TOT_NSEA(3,:)) + WRITE(740+IAPROC,*) 'sum(varWrite)=', sum(varWrite) + FLUSH(740+IAPROC) +#endif ! iret=nf90_close(ncid) CALL GENERIC_NETCDF_ERROR(CallFct, 73, iret) END IF deallocate(ListIdx, SPPARM) -!/DEBUGNETCDF WRITE(740+IAPROC,*) 'Leaving the NETCDF output routine' -!/DEBUGNETCDF FLUSH(740+IAPROC) +#ifdef W3_DEBUGNETCDF + WRITE(740+IAPROC,*) 'Leaving the NETCDF output routine' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !********************************************************************** !* * diff --git a/model/ftn/w3nmlbouncmd.ftn b/model/src/w3nmlbouncmd.F90 similarity index 93% rename from model/ftn/w3nmlbouncmd.ftn rename to model/src/w3nmlbouncmd.F90 index 6101dc209..9e803188b 100644 --- a/model/ftn/w3nmlbouncmd.ftn +++ b/model/src/w3nmlbouncmd.F90 @@ -102,7 +102,9 @@ SUBROUTINE W3NMLBOUNC (NDSI, INFILE, NML_BOUND, IERR) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -110,10 +112,14 @@ SUBROUTINE W3NMLBOUNC (NDSI, INFILE, NML_BOUND, IERR) CHARACTER*(*), INTENT(IN) :: INFILE TYPE(NML_BOUND_T), INTENT(INOUT) :: NML_BOUND INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLBOUNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLBOUNC') +#endif ! open namelist log file NDSN = 3 @@ -207,7 +213,9 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -218,10 +226,14 @@ SUBROUTINE READ_BOUND_NML (NDSI, NML_BOUND) INTEGER :: IERR TYPE(NML_BOUND_T) :: BOUND NAMELIST /BOUND_NML/ BOUND -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_BOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_BOUND_NML') +#endif ! set default values for track structure BOUND%MODE = 'WRITE' @@ -309,14 +321,20 @@ SUBROUTINE REPORT_BOUND_NML (NML_BOUND) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_BOUND_T), INTENT(IN) :: NML_BOUND -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_BOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_BOUND_NML') +#endif WRITE (MSG,'(A)') 'BOUND % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlgridmd.ftn b/model/src/w3nmlgridmd.F90 similarity index 94% rename from model/ftn/w3nmlgridmd.ftn rename to model/src/w3nmlgridmd.F90 index fd8f2bede..305ccef37 100644 --- a/model/ftn/w3nmlgridmd.ftn +++ b/model/src/w3nmlgridmd.F90 @@ -362,7 +362,9 @@ SUBROUTINE W3NMLGRID (NDSI, INFILE, NML_SPECTRUM, NML_RUN, & !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -389,10 +391,14 @@ SUBROUTINE W3NMLGRID (NDSI, INFILE, NML_SPECTRUM, NML_RUN, & TYPE(NML_OUTBND_COUNT_T), INTENT(INOUT) :: NML_OUTBND_COUNT TYPE(NML_OUTBND_LINE_T), ALLOCATABLE, INTENT(INOUT) :: NML_OUTBND_LINE(:) INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLGRID') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLGRID') +#endif ! open namelist log file NDSN = 3 @@ -546,7 +552,9 @@ SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -557,10 +565,14 @@ SUBROUTINE READ_SPECTRUM_NML (NDSI, NML_SPECTRUM) INTEGER :: IERR TYPE(NML_SPECTRUM_T) :: SPECTRUM NAMELIST /SPECTRUM_NML/ SPECTRUM -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SPECTRUM_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SPECTRUM_NML') +#endif ! set default values for spectrum structure SPECTRUM%XFR = 0. @@ -647,7 +659,9 @@ SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -658,10 +672,14 @@ SUBROUTINE READ_RUN_NML (NDSI, NML_RUN) INTEGER :: IERR TYPE(NML_RUN_T) :: RUN NAMELIST /RUN_NML/ RUN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_RUN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_RUN_NML') +#endif ! set default values for run structure RUN%FLDRY = .FALSE. @@ -749,7 +767,9 @@ SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -760,10 +780,14 @@ SUBROUTINE READ_TIMESTEPS_NML (NDSI, NML_TIMESTEPS) INTEGER :: IERR TYPE(NML_TIMESTEPS_T) :: TIMESTEPS NAMELIST /TIMESTEPS_NML/ TIMESTEPS -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_TIMESTEPS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_TIMESTEPS_NML') +#endif ! set default values for timesteps structure TIMESTEPS%DTMAX = 0. @@ -850,7 +874,9 @@ SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -861,10 +887,14 @@ SUBROUTINE READ_GRID_NML (NDSI, NML_GRID) INTEGER :: IERR TYPE(NML_GRID_T) :: GRID NAMELIST /GRID_NML/ GRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_GRID_NML') +#endif ! set default values for grid structure GRID%NAME = 'unset' @@ -953,7 +983,9 @@ SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -964,10 +996,14 @@ SUBROUTINE READ_RECT_NML (NDSI, NML_RECT) INTEGER :: IERR TYPE(NML_RECT_T) :: RECT NAMELIST /RECT_NML/ RECT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_RECT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_RECT_NML') +#endif ! set default values for rect structure RECT%NX = 0 @@ -1057,7 +1093,9 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1068,10 +1106,14 @@ SUBROUTINE READ_CURV_NML (NDSI, NML_CURV) INTEGER :: IERR TYPE(NML_CURV_T) :: CURV NAMELIST /CURV_NML/ CURV -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_CURV_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_CURV_NML') +#endif ! set default values for curv structure CURV%NX = 0 @@ -1173,7 +1215,9 @@ SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1184,10 +1228,14 @@ SUBROUTINE READ_UNST_NML (NDSI, NML_UNST) INTEGER :: IERR TYPE(NML_UNST_T) :: UNST NAMELIST /UNST_NML/ UNST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_UNST_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_UNST_NML') +#endif ! set default values for unst structure UNST%SF = 0 @@ -1277,7 +1325,9 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1288,10 +1338,14 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) INTEGER :: IERR TYPE(NML_SMC_T) :: SMC NAMELIST /SMC_NML/ SMC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SMC_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SMC_NML') +#endif ! set default values for smc structure SMC%MCELS%FILENAME = 'unset' @@ -1421,7 +1475,9 @@ SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1432,10 +1488,14 @@ SUBROUTINE READ_DEPTH_NML (NDSI, NML_DEPTH) INTEGER :: IERR TYPE(NML_DEPTH_T) :: DEPTH NAMELIST /DEPTH_NML/ DEPTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_DEPTH_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_DEPTH_NML') +#endif ! set default values for depth structure DEPTH%SF = 1. @@ -1524,7 +1584,9 @@ SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1535,10 +1597,14 @@ SUBROUTINE READ_MASK_NML (NDSI, NML_MASK) INTEGER :: IERR TYPE(NML_MASK_T) :: MASK NAMELIST /MASK_NML/ MASK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_MASK_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_MASK_NML') +#endif ! set default values for mask structure MASK%SF = 1. @@ -1628,7 +1694,9 @@ SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1639,10 +1707,14 @@ SUBROUTINE READ_OBST_NML (NDSI, NML_OBST) INTEGER :: IERR TYPE(NML_OBST_T) :: OBST NAMELIST /OBST_NML/ OBST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OBST_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OBST_NML') +#endif ! set default values for obst structure OBST%SF = 1. @@ -1732,7 +1804,9 @@ SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1743,10 +1817,14 @@ SUBROUTINE READ_SLOPE_NML (NDSI, NML_SLOPE) INTEGER :: IERR TYPE(NML_SLOPE_T) :: SLOPE NAMELIST /SLOPE_NML/ SLOPE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SLOPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SLOPE_NML') +#endif ! set default values for slope structure SLOPE%SF = 1. @@ -1837,7 +1915,9 @@ SUBROUTINE READ_SED_NML (NDSI, NML_SED) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1848,10 +1928,14 @@ SUBROUTINE READ_SED_NML (NDSI, NML_SED) INTEGER :: IERR TYPE(NML_SED_T) :: SED NAMELIST /SED_NML/ SED -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SED_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SED_NML') +#endif ! set default values for sed structure SED%SF = 1. @@ -1943,7 +2027,9 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1957,10 +2043,14 @@ SUBROUTINE READ_INBOUND_NML (NDSI, NML_INBND_COUNT, NML_INBND_POINT) NAMELIST /INBND_COUNT_NML/ INBND_COUNT TYPE(NML_INBND_POINT_T), ALLOCATABLE :: INBND_POINT(:) NAMELIST /INBND_POINT_NML/ INBND_POINT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_INBOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_INBOUND_NML') +#endif ! set default values for inbnd count structure INBND_COUNT%N_POINT = 0 @@ -2071,7 +2161,9 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -2088,10 +2180,14 @@ SUBROUTINE READ_EXCLUDED_NML (NDSI, NML_EXCL_COUNT, NML_EXCL_POINT, & NAMELIST /EXCL_POINT_NML/ EXCL_POINT TYPE(NML_EXCL_BODY_T), ALLOCATABLE :: EXCL_BODY(:) NAMELIST /EXCL_BODY_NML/ EXCL_BODY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_EXCLUDED_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_EXCLUDED_NML') +#endif ! set default values for excl count structure EXCL_COUNT%N_POINT = 0 @@ -2224,7 +2320,9 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -2239,10 +2337,14 @@ SUBROUTINE READ_OUTBOUND_NML (NDSI, NML_OUTBND_COUNT, NML_OUTBND_LINE) TYPE(NML_OUTBND_LINE_T), ALLOCATABLE :: OUTBND_LINE(:) NAMELIST /OUTBND_LINE_NML/ OUTBND_LINE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OUTBOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OUTBOUND_NML') +#endif ! set default values for outbnd count structure OUTBND_COUNT%N_LINE = 0 @@ -2350,14 +2452,20 @@ SUBROUTINE REPORT_SPECTRUM_NML (NML_SPECTRUM) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SPECTRUM_T), INTENT(IN) :: NML_SPECTRUM -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SPECTRUM_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SPECTRUM_NML') +#endif WRITE (MSG,'(A)') 'SPECTRUM % ' WRITE (NDSN,'(A)') @@ -2434,14 +2542,20 @@ SUBROUTINE REPORT_RUN_NML (NML_RUN) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_RUN_T), INTENT(IN) :: NML_RUN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_RUN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_RUN_NML') +#endif WRITE (MSG,'(A)') 'RUN % ' WRITE (NDSN,'(A)') @@ -2519,14 +2633,20 @@ SUBROUTINE REPORT_TIMESTEPS_NML (NML_TIMESTEPS) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_TIMESTEPS_T), INTENT(IN) :: NML_TIMESTEPS -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_TIMESTEPS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_TIMESTEPS_NML') +#endif WRITE (MSG,'(A)') 'TIMESTEPS % ' WRITE (NDSN,'(A)') @@ -2602,14 +2722,20 @@ SUBROUTINE REPORT_GRID_NML (NML_GRID) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_GRID_T), INTENT(IN) :: NML_GRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_GRID_NML') +#endif WRITE (MSG,'(A)') 'GRID % ' WRITE (NDSN,'(A)') @@ -2687,14 +2813,20 @@ SUBROUTINE REPORT_RECT_NML (NML_RECT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_RECT_T), INTENT(IN) :: NML_RECT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_RECT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_RECT_NML') +#endif WRITE (MSG,'(A)') 'RECT % ' WRITE (NDSN,'(A)') @@ -2774,14 +2906,20 @@ SUBROUTINE REPORT_CURV_NML (NML_CURV) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_CURV_T), INTENT(IN) :: NML_CURV -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_CURV_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_CURV_NML') +#endif WRITE (MSG,'(A)') 'CURV % ' WRITE (NDSN,'(A)') @@ -2874,14 +3012,20 @@ SUBROUTINE REPORT_UNST_NML (NML_UNST) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_UNST_T), INTENT(IN) :: NML_UNST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_UNST_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_UNST_NML') +#endif WRITE (MSG,'(A)') 'UNST % ' WRITE (NDSN,'(A)') @@ -2962,14 +3106,20 @@ SUBROUTINE REPORT_SMC_NML (NML_SMC) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SMC_T), INTENT(IN) :: NML_SMC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SMC_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SMC_NML') +#endif WRITE (MSG,'(A)') 'SMC % ' WRITE (NDSN,'(A)') @@ -3093,14 +3243,20 @@ SUBROUTINE REPORT_DEPTH_NML (NML_DEPTH) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_DEPTH_T), INTENT(IN) :: NML_DEPTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_DEPTH_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_DEPTH_NML') +#endif WRITE (MSG,'(A)') 'DEPTH % ' WRITE (NDSN,'(A)') @@ -3181,14 +3337,20 @@ SUBROUTINE REPORT_MASK_NML (NML_MASK) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_MASK_T), INTENT(IN) :: NML_MASK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_MASK_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_MASK_NML') +#endif WRITE (MSG,'(A)') 'MASK % ' WRITE (NDSN,'(A)') @@ -3270,14 +3432,20 @@ SUBROUTINE REPORT_OBST_NML (NML_OBST) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_OBST_T), INTENT(IN) :: NML_OBST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OBST_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OBST_NML') +#endif WRITE (MSG,'(A)') 'OBST % ' WRITE (NDSN,'(A)') @@ -3361,14 +3529,20 @@ SUBROUTINE REPORT_SLOPE_NML (NML_SLOPE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SLOPE_T), INTENT(IN) :: NML_SLOPE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SLOPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SLOPE_NML') +#endif WRITE (MSG,'(A)') 'SLOPE % ' WRITE (NDSN,'(A)') @@ -3453,14 +3627,20 @@ SUBROUTINE REPORT_SED_NML (NML_SED) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SED_T), INTENT(IN) :: NML_SED -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SED_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SED_NML') +#endif WRITE (MSG,'(A)') 'SED % ' WRITE (NDSN,'(A)') @@ -3544,7 +3724,9 @@ SUBROUTINE REPORT_INBOUND_NML (NML_INBND_COUNT, NML_INBND_POINT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -3553,9 +3735,13 @@ SUBROUTINE REPORT_INBOUND_NML (NML_INBND_COUNT, NML_INBND_POINT) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_INBOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_INBOUND_NML') +#endif WRITE (MSG,'(A)') 'INBND_COUNT % ' WRITE (NDSN,'(A)') @@ -3642,7 +3828,9 @@ SUBROUTINE REPORT_EXCLUDED_NML (NML_EXCL_COUNT, NML_EXCL_POINT, NML_EXCL_BODY) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -3652,9 +3840,13 @@ SUBROUTINE REPORT_EXCLUDED_NML (NML_EXCL_COUNT, NML_EXCL_POINT, NML_EXCL_BODY) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_EXCLUDED_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_EXCLUDED_NML') +#endif WRITE (MSG,'(A)') 'EXCL_COUNT % ' WRITE (NDSN,'(A)') @@ -3751,7 +3943,9 @@ SUBROUTINE REPORT_OUTBOUND_NML (NML_OUTBND_COUNT, NML_OUTBND_LINE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -3760,9 +3954,13 @@ SUBROUTINE REPORT_OUTBOUND_NML (NML_OUTBND_COUNT, NML_OUTBND_LINE) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OUTBOUND_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OUTBOUND_NML') +#endif WRITE (MSG,'(A)') 'OUTBND_COUNT % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlmultimd.ftn b/model/src/w3nmlmultimd.F90 similarity index 92% rename from model/ftn/w3nmlmultimd.ftn rename to model/src/w3nmlmultimd.F90 index 356ca4a4e..b0208096c 100644 --- a/model/ftn/w3nmlmultimd.ftn +++ b/model/src/w3nmlmultimd.F90 @@ -135,11 +135,13 @@ MODULE W3NMLMULTIMD LOGICAL :: FORMAT END TYPE NML_PARTITION_T ! -!/COU TYPE NML_COUPLING_T -!/COU CHARACTER(1024) :: SENT -!/COU CHARACTER(1024) :: RECEIVED -!/COU LOGICAL :: COUPLET0 -!/COU END TYPE NML_COUPLING_T +#ifdef W3_COU + TYPE NML_COUPLING_T + CHARACTER(1024) :: SENT + CHARACTER(1024) :: RECEIVED + LOGICAL :: COUPLET0 + END TYPE NML_COUPLING_T +#endif ! TYPE NML_RESTART_T CHARACTER(1024) :: EXTRA @@ -150,7 +152,9 @@ MODULE W3NMLMULTIMD TYPE(NML_FIELD_T) :: FIELD TYPE(NML_TRACK_T) :: TRACK TYPE(NML_PARTITION_T) :: PARTITION -!/COU TYPE(NML_COUPLING_T) :: COUPLING +#ifdef W3_COU + TYPE(NML_COUPLING_T) :: COUPLING +#endif TYPE(NML_RESTART_T) :: RESTART END TYPE NML_OUTPUT_TYPE_T @@ -173,7 +177,9 @@ MODULE W3NMLMULTIMD TYPE(NML_OUTPUT_TIME_T) :: RESTART2 TYPE(NML_OUTPUT_TIME_T) :: BOUNDARY TYPE(NML_OUTPUT_TIME_T) :: PARTITION -!/COU TYPE(NML_OUTPUT_TIME_T) :: COUPLING +#ifdef W3_COU + TYPE(NML_OUTPUT_TIME_T) :: COUPLING +#endif END TYPE NML_OUTPUT_DATE_T @@ -267,8 +273,12 @@ SUBROUTINE W3NMLMULTIDEF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, IERR) ! !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -278,15 +288,23 @@ SUBROUTINE W3NMLMULTIDEF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, IERR) INTEGER, INTENT(OUT) :: IERR ! locals -!/MPI INTEGER :: IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLMULTIDEF') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLMULTIDEF') +#endif -!/MPI MPI_COMM_MWAVE = MPI_COMM -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! open namelist log file IF ( NMPLOG .EQ. IMPROC ) THEN @@ -408,8 +426,12 @@ SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -425,15 +447,23 @@ SUBROUTINE W3NMLMULTICONF (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & INTEGER, INTENT(OUT) :: IERR ! locals -!/MPI INTEGER :: IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLMULTICONF') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLMULTICONF') +#endif -!/MPI MPI_COMM_MWAVE = MPI_COMM -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! open namelist log file IF ( NMPLOG .EQ. IMPROC ) THEN @@ -550,7 +580,9 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -561,10 +593,14 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) INTEGER :: IERR TYPE(NML_DOMAIN_T) :: DOMAIN NAMELIST /DOMAIN_NML/ DOMAIN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_DOMAIN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_DOMAIN_NML') +#endif ! set default values for model definition data DOMAIN%NRINP = 0 @@ -679,7 +715,9 @@ SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -691,10 +729,14 @@ SUBROUTINE READ_INPUT_GRID_NML (NDSI, NRINP, NML_INPUT_GRID) INTEGER, PARAMETER :: MAX_NRINP = 99 TYPE(NML_INPUT_GRID_T) :: INPUT(MAX_NRINP) NAMELIST /INPUT_GRID_NML/ INPUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_INPUT_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_INPUT_GRID_NML') +#endif ! test NRINP IF (NRINP.GT.MAX_NRINP) THEN @@ -827,7 +869,9 @@ SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -839,10 +883,14 @@ SUBROUTINE READ_MODEL_GRID_NML (NDSI, NRGRD, NML_MODEL_GRID) INTEGER, PARAMETER :: MAX_NRGRD = 99 TYPE(NML_MODEL_GRID_T) :: MODEL(MAX_NRGRD) NAMELIST /MODEL_GRID_NML/ MODEL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_MODEL_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_MODEL_GRID_NML') +#endif ! test NRGRD IF (NRGRD.GT.MAX_NRGRD) THEN @@ -979,7 +1027,9 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -992,10 +1042,14 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) TYPE(NML_OUTPUT_TYPE_T) :: ALLTYPE TYPE(NML_OUTPUT_TYPE_T) :: ITYPE(MAX_NRGRD) NAMELIST /OUTPUT_TYPE_NML/ ALLTYPE, ITYPE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') +#endif ! if no model grids, then exit IF (NRGRD.EQ.0) RETURN @@ -1013,9 +1067,11 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) ITYPE(I)%PARTITION%YN = 0 ITYPE(I)%PARTITION%NY = 0 ITYPE(I)%PARTITION%FORMAT = .TRUE. -!/COU ITYPE(I)%COUPLING%SENT = 'unset' -!/COU ITYPE(I)%COUPLING%RECEIVED = 'unset' -!/COU ITYPE(I)%COUPLING%COUPLET0 = .FALSE. +#ifdef W3_COU + ITYPE(I)%COUPLING%SENT = 'unset' + ITYPE(I)%COUPLING%RECEIVED = 'unset' + ITYPE(I)%COUPLING%COUPLET0 = .FALSE. +#endif ITYPE(I)%RESTART%EXTRA = 'unset' END DO ALLTYPE%FIELD%LIST = 'unset' @@ -1029,9 +1085,11 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NRGRD, NML_OUTPUT_TYPE) ALLTYPE%PARTITION%YN = 0 ALLTYPE%PARTITION%NY = 0 ALLTYPE%PARTITION%FORMAT = .TRUE. -!/COU ALLTYPE%COUPLING%SENT = 'unset' -!/COU ALLTYPE%COUPLING%RECEIVED = 'unset' -!/COU ALLTYPE%COUPLING%COUPLET0 = .FALSE. +#ifdef W3_COU + ALLTYPE%COUPLING%SENT = 'unset' + ALLTYPE%COUPLING%RECEIVED = 'unset' + ALLTYPE%COUPLING%COUPLET0 = .FALSE. +#endif ALLTYPE%RESTART%EXTRA = 'unset' @@ -1137,7 +1195,9 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1150,10 +1210,14 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) TYPE(NML_OUTPUT_DATE_T) :: ALLDATE TYPE(NML_OUTPUT_DATE_T) :: IDATE(MAX_NRGRD) NAMELIST /OUTPUT_DATE_NML/ ALLDATE, IDATE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') +#endif ! if no model grids, then exit IF (NRGRD.EQ.0) RETURN @@ -1183,9 +1247,11 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) IDATE(I)%PARTITION%START = '19680606 000000' IDATE(I)%PARTITION%STRIDE = '0' IDATE(I)%PARTITION%STOP = '19680607 000000' -!/COU IDATE(I)%COUPLING%START = '19680606 000000' -!/COU IDATE(I)%COUPLING%STRIDE = '0' -!/COU IDATE(I)%COUPLING%STOP = '19680607 000000' +#ifdef W3_COU + IDATE(I)%COUPLING%START = '19680606 000000' + IDATE(I)%COUPLING%STRIDE = '0' + IDATE(I)%COUPLING%STOP = '19680607 000000' +#endif END DO ALLDATE%FIELD%START = '19680606 000000' ALLDATE%FIELD%STRIDE = '0' @@ -1210,9 +1276,11 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NRGRD, NML_OUTPUT_DATE) ALLDATE%PARTITION%START = '19680606 000000' ALLDATE%PARTITION%STRIDE = '0' ALLDATE%PARTITION%STOP = '19680607 000000' -!/COU ALLDATE%COUPLING%START = '19680606 000000' -!/COU ALLDATE%COUPLING%STRIDE = '0' -!/COU ALLDATE%COUPLING%STOP = '19680607 000000' +#ifdef W3_COU + ALLDATE%COUPLING%START = '19680606 000000' + ALLDATE%COUPLING%STRIDE = '0' + ALLDATE%COUPLING%STOP = '19680607 000000' +#endif ! read OUTPUT_DATE namelist @@ -1317,7 +1385,9 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1331,10 +1401,14 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) NAMELIST /HOMOG_COUNT_NML/ HOMOG_COUNT TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: HOMOG_INPUT(:) NAMELIST /HOMOG_INPUT_NML/ HOMOG_INPUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') +#endif ! set default values for homogeneous number structure @@ -1455,14 +1529,20 @@ SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_DOMAIN_T), INTENT(IN) :: NML_DOMAIN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_DOMAIN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_DOMAIN_NML') +#endif WRITE (MSG,'(A)') 'DOMAIN % ' WRITE (NDSN,'(A)') @@ -1552,7 +1632,9 @@ SUBROUTINE REPORT_INPUT_GRID_NML (NRINP, NML_INPUT_GRID) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1561,9 +1643,13 @@ SUBROUTINE REPORT_INPUT_GRID_NML (NRINP, NML_INPUT_GRID) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_INPUT_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_INPUT_GRID_NML') +#endif DO I = 1,NRINP WRITE (MSG,'(A,I0.2,A)') 'INPUT GRID ',I,' % ' @@ -1663,7 +1749,9 @@ SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1672,9 +1760,13 @@ SUBROUTINE REPORT_MODEL_GRID_NML (NRGRD, NML_MODEL_GRID) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_MODEL_GRID_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_MODEL_GRID_NML') +#endif DO I = 1,NRGRD WRITE (MSG,'(A,I0.4,A)') 'MODEL GRID ',I,' % ' @@ -1781,7 +1873,9 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1790,9 +1884,13 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') +#endif DO I=1,NRGRD WRITE (MSG,'(A,I1,A)') 'OUTPUT TYPE MODEL GRID',I, ' % ' @@ -1808,9 +1906,11 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NRGRD, NML_OUTPUT_TYPE) WRITE (NDSN,11) TRIM(MSG),'PARTITION % YN = ', NML_OUTPUT_TYPE(I)%PARTITION%YN WRITE (NDSN,11) TRIM(MSG),'PARTITION % NY = ', NML_OUTPUT_TYPE(I)%PARTITION%NY WRITE (NDSN,13) TRIM(MSG),'PARTITION % FORMAT = ', NML_OUTPUT_TYPE(I)%PARTITION%FORMAT -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % SENT = ', TRIM(NML_OUTPUT_TYPE(I)%COUPLING%SENT) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % RECEIVED = ', TRIM(NML_OUTPUT_TYPE(I)%COUPLING%RECEIVED) -!/COU WRITE (NDSN,13) TRIM(MSG),'COUPLING % COUPLET0 = ', NML_OUTPUT_TYPE(I)%COUPLING%COUPLET0 +#ifdef W3_COU + WRITE (NDSN,10) TRIM(MSG),'COUPLING % SENT = ', TRIM(NML_OUTPUT_TYPE(I)%COUPLING%SENT) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % RECEIVED = ', TRIM(NML_OUTPUT_TYPE(I)%COUPLING%RECEIVED) + WRITE (NDSN,13) TRIM(MSG),'COUPLING % COUPLET0 = ', NML_OUTPUT_TYPE(I)%COUPLING%COUPLET0 +#endif WRITE (NDSN,10) TRIM(MSG),'RESTART % EXTRA = ', TRIM(NML_OUTPUT_TYPE(I)%RESTART%EXTRA) END DO WRITE (NDSN,'(A)') @@ -1889,7 +1989,9 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1898,9 +2000,13 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') +#endif DO I=1,NRGRD WRITE (MSG,'(A,I1,A)') 'OUTPUT DATE MODEL GRID',I, ' % ' @@ -1926,9 +2032,11 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NRGRD, NML_OUTPUT_DATE) WRITE (NDSN,10) TRIM(MSG),'PARTITION % START = ', TRIM(NML_OUTPUT_DATE(I)%PARTITION%START) WRITE (NDSN,10) TRIM(MSG),'PARTITION % STRIDE = ', TRIM(NML_OUTPUT_DATE(I)%PARTITION%STRIDE) WRITE (NDSN,10) TRIM(MSG),'PARTITION % STOP = ', TRIM(NML_OUTPUT_DATE(I)%PARTITION%STOP) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % START = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%START) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % STRIDE = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%STRIDE) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % STOP = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%STOP) +#ifdef W3_COU + WRITE (NDSN,10) TRIM(MSG),'COUPLING % START = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%START) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % STRIDE = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%STRIDE) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % STOP = ', TRIM(NML_OUTPUT_DATE(I)%COUPLING%STOP) +#endif END DO WRITE (NDSN,'(A)') @@ -2004,7 +2112,9 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -2013,9 +2123,13 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') +#endif WRITE (MSG,'(A)') 'HOMOG_COUNT % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlounfmd.ftn b/model/src/w3nmlounfmd.F90 similarity index 93% rename from model/ftn/w3nmlounfmd.ftn rename to model/src/w3nmlounfmd.F90 index a2dceb33e..1ff1b254c 100644 --- a/model/ftn/w3nmlounfmd.ftn +++ b/model/src/w3nmlounfmd.F90 @@ -135,7 +135,9 @@ SUBROUTINE W3NMLOUNF (NDSI, INFILE, NML_FIELD, NML_FILE, NML_SMC, IERR) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -145,10 +147,14 @@ SUBROUTINE W3NMLOUNF (NDSI, INFILE, NML_FIELD, NML_FILE, NML_SMC, IERR) TYPE(NML_FILE_T), INTENT(INOUT) :: NML_FILE TYPE(NML_SMC_T), INTENT(INOUT) :: NML_SMC INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLOUNF') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLOUNF') +#endif ! open namelist log file NDSN = 3 @@ -250,7 +256,9 @@ SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY: UNDEF IMPLICIT NONE @@ -262,10 +270,14 @@ SUBROUTINE READ_FIELD_NML (NDSI, NML_FIELD) INTEGER :: IERR TYPE(NML_FIELD_T) :: FIELD NAMELIST /FIELD_NML/ FIELD -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FIELD_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FIELD_NML') +#endif ! set default values for field structure FIELD%TIMESTART = '19000101 000000' @@ -366,7 +378,9 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -377,10 +391,14 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) INTEGER :: IERR TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FILE_NML') +#endif ! set default values for file structure FILE%PREFIX = 'ww3.' @@ -468,7 +486,9 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -479,10 +499,14 @@ SUBROUTINE READ_SMC_NML (NDSI, NML_SMC) INTEGER :: IERR TYPE(NML_SMC_T) :: SMC NAMELIST /SMC_NML/ SMC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SMC_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SMC_NML') +#endif ! set default values for smc structure SMC%SXO = -999.9 @@ -569,14 +593,20 @@ SUBROUTINE REPORT_FIELD_NML (NML_FIELD) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FIELD_T), INTENT(IN) :: NML_FIELD -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FIELD_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FIELD_NML') +#endif WRITE (MSG,'(A)') 'FIELD % ' WRITE (NDSN,'(A)') @@ -665,14 +695,20 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FILE_NML') +#endif WRITE (MSG,'(A)') 'FILE % ' WRITE (NDSN,'(A)') @@ -747,14 +783,20 @@ SUBROUTINE REPORT_SMC_NML (NML_SMC) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SMC_T), INTENT(IN) :: NML_SMC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SMC_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SMC_NML') +#endif WRITE (MSG,'(A)') 'SMC % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlounpmd.ftn b/model/src/w3nmlounpmd.F90 similarity index 93% rename from model/ftn/w3nmlounpmd.ftn rename to model/src/w3nmlounpmd.F90 index 0858c6ec2..fe3417fcc 100644 --- a/model/ftn/w3nmlounpmd.ftn +++ b/model/src/w3nmlounpmd.F90 @@ -146,7 +146,9 @@ SUBROUTINE W3NMLOUNP (NDSI, INFILE, NML_POINT, NML_FILE, & !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -158,10 +160,14 @@ SUBROUTINE W3NMLOUNP (NDSI, INFILE, NML_POINT, NML_FILE, & TYPE(NML_PARAM_T), INTENT(INOUT) :: NML_PARAM TYPE(NML_SOURCE_T), INTENT(INOUT) :: NML_SOURCE INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLOUNP') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLOUNP') +#endif ! open namelist log file NDSN = 3 @@ -271,7 +277,9 @@ SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -282,10 +290,14 @@ SUBROUTINE READ_POINT_NML (NDSI, NML_POINT) INTEGER :: IERR TYPE(NML_POINT_T) :: POINT NAMELIST /POINT_NML/ POINT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_POINT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_POINT_NML') +#endif ! set default values for point structure POINT%TIMESTART = '19000101 000000' @@ -376,7 +388,9 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -387,10 +401,14 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) INTEGER :: IERR TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FILE_NML') +#endif ! set default values for file structure FILE%PREFIX = 'ww3.' @@ -475,7 +493,9 @@ SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -486,10 +506,14 @@ SUBROUTINE READ_SPECTRA_NML (NDSI, NML_SPECTRA) INTEGER :: IERR TYPE(NML_SPECTRA_T) :: SPECTRA NAMELIST /SPECTRA_NML/ SPECTRA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SPECTRA_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SPECTRA_NML') +#endif ! set default values for spectra structure SPECTRA%OUTPUT = 3 @@ -575,7 +599,9 @@ SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -586,10 +612,14 @@ SUBROUTINE READ_PARAM_NML (NDSI, NML_PARAM) INTEGER :: IERR TYPE(NML_PARAM_T) :: PARAM NAMELIST /PARAM_NML/ PARAM -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_PARAM_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_PARAM_NML') +#endif ! set default values for param structure PARAM%OUTPUT = 3 @@ -670,7 +700,9 @@ SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -681,10 +713,14 @@ SUBROUTINE READ_SOURCE_NML (NDSI, NML_SOURCE) INTEGER :: IERR TYPE(NML_SOURCE_T) :: SOURCE NAMELIST /SOURCE_NML/ SOURCE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_SOURCE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_SOURCE_NML') +#endif ! set default values for source structure SOURCE%OUTPUT = 4 @@ -778,14 +814,20 @@ SUBROUTINE REPORT_POINT_NML (NML_POINT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_POINT_T), INTENT(IN) :: NML_POINT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_POINT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_POINT_NML') +#endif WRITE (MSG,'(A)') 'POINT % ' WRITE (NDSN,'(A)') @@ -869,14 +911,20 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FILE_NML') +#endif WRITE (MSG,'(A)') 'FILE % ' WRITE (NDSN,'(A)') @@ -948,14 +996,20 @@ SUBROUTINE REPORT_SPECTRA_NML (NML_SPECTRA) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SPECTRA_T), INTENT(IN) :: NML_SPECTRA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SPECTRA_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SPECTRA_NML') +#endif WRITE (MSG,'(A)') 'SPECTRA % ' WRITE (NDSN,'(A)') @@ -1029,14 +1083,20 @@ SUBROUTINE REPORT_PARAM_NML (NML_PARAM) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_PARAM_T), INTENT(IN) :: NML_PARAM -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_PARAM_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_PARAM_NML') +#endif WRITE (MSG,'(A)') 'PARAM % ' WRITE (NDSN,'(A)') @@ -1104,14 +1164,20 @@ SUBROUTINE REPORT_SOURCE_NML (NML_SOURCE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_SOURCE_T), INTENT(IN) :: NML_SOURCE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_SOURCE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_SOURCE_NML') +#endif WRITE (MSG,'(A)') 'SOURCE % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlprncmd.ftn b/model/src/w3nmlprncmd.F90 similarity index 94% rename from model/ftn/w3nmlprncmd.ftn rename to model/src/w3nmlprncmd.F90 index 18952d8ff..e9b447051 100644 --- a/model/ftn/w3nmlprncmd.ftn +++ b/model/src/w3nmlprncmd.F90 @@ -140,7 +140,9 @@ SUBROUTINE W3NMLPRNC (NDSI, INFILE, NML_FORCING, NML_FILE, IERR) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -149,10 +151,14 @@ SUBROUTINE W3NMLPRNC (NDSI, INFILE, NML_FORCING, NML_FILE, IERR) TYPE(NML_FORCING_T), INTENT(INOUT) :: NML_FORCING TYPE(NML_FILE_T), INTENT(INOUT) :: NML_FILE INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLPRNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLPRNC') +#endif ! open namelist log file NDSN = 3 @@ -250,7 +256,9 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -261,10 +269,14 @@ SUBROUTINE READ_FORCING_NML (NDSI, NML_FORCING) INTEGER :: IERR TYPE(NML_FORCING_T) :: FORCING NAMELIST /FORCING_NML/ FORCING -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FORCING_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FORCING_NML') +#endif ! set default values for forcing structure FORCING%TIMESTART = '19000101 000000' @@ -383,7 +395,9 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -394,10 +408,14 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) INTEGER :: IERR TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FILE_NML') +#endif ! set default values for file structure FILE%FILENAME = 'unset' @@ -487,14 +505,20 @@ SUBROUTINE REPORT_FORCING_NML (NML_FORCING) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FORCING_T), INTENT(IN) :: NML_FORCING -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FORCING_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FORCING_NML') +#endif WRITE (MSG,'(A)') 'FORCING % ' WRITE (NDSN,'(A)') @@ -593,14 +617,20 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FILE_NML') +#endif WRITE (MSG,'(A)') 'FILE % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmlshelmd.ftn b/model/src/w3nmlshelmd.F90 similarity index 92% rename from model/ftn/w3nmlshelmd.ftn rename to model/src/w3nmlshelmd.F90 index 44d7cf6bb..91df4b683 100644 --- a/model/ftn/w3nmlshelmd.ftn +++ b/model/src/w3nmlshelmd.F90 @@ -85,11 +85,13 @@ MODULE W3NMLSHELMD LOGICAL :: FORMAT END TYPE NML_PARTITION_T ! -!/COU TYPE NML_COUPLING_T -!/COU CHARACTER(1024) :: SENT -!/COU CHARACTER(1024) :: RECEIVED -!/COU LOGICAL :: COUPLET0 -!/COU END TYPE NML_COUPLING_T +#ifdef W3_COU + TYPE NML_COUPLING_T + CHARACTER(1024) :: SENT + CHARACTER(1024) :: RECEIVED + LOGICAL :: COUPLET0 + END TYPE NML_COUPLING_T +#endif ! TYPE NML_RESTART_T CHARACTER(1024) :: EXTRA @@ -100,7 +102,9 @@ MODULE W3NMLSHELMD TYPE(NML_FIELD_T) :: FIELD TYPE(NML_TRACK_T) :: TRACK TYPE(NML_PARTITION_T) :: PARTITION -!/COU TYPE(NML_COUPLING_T) :: COUPLING +#ifdef W3_COU + TYPE(NML_COUPLING_T) :: COUPLING +#endif TYPE(NML_RESTART_T) :: RESTART END TYPE NML_OUTPUT_TYPE_T @@ -244,8 +248,12 @@ SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & !/ ------------------------------------------------------------------- / USE WMMDATMD, ONLY: MDSE, IMPROC, NMPLOG -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -260,15 +268,23 @@ SUBROUTINE W3NMLSHEL (MPI_COMM, NDSI, INFILE, NML_DOMAIN, & INTEGER, INTENT(OUT) :: IERR ! locals -!/MPI INTEGER :: IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLSHEL') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLSHEL') +#endif -!/MPI MPI_COMM_MWAVE = MPI_COMM -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! open namelist log file IF ( NMPLOG .EQ. IMPROC ) THEN @@ -380,7 +396,9 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -391,10 +409,14 @@ SUBROUTINE READ_DOMAIN_NML (NDSI, NML_DOMAIN) INTEGER :: IERR TYPE(NML_DOMAIN_T) :: DOMAIN NAMELIST /DOMAIN_NML/ DOMAIN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_DOMAIN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_DOMAIN_NML') +#endif ! set default values for domain structure DOMAIN%IOSTYP = 1 @@ -492,7 +514,9 @@ SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -503,10 +527,14 @@ SUBROUTINE READ_INPUT_NML (NDSI, NML_INPUT) INTEGER :: IERR TYPE(NML_INPUT_T) :: INPUT NAMELIST /INPUT_NML/ INPUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_INPUT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_INPUT_NML') +#endif ! set default values for input structure @@ -612,7 +640,9 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -623,10 +653,14 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) INTEGER :: IERR TYPE(NML_OUTPUT_TYPE_T) :: TYPE NAMELIST /OUTPUT_TYPE_NML/ TYPE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OUTPUT_TYPE_NML') +#endif ! set default values for output type structure TYPE%FIELD%LIST = 'unset' @@ -639,9 +673,11 @@ SUBROUTINE READ_OUTPUT_TYPE_NML (NDSI, NML_OUTPUT_TYPE) TYPE%PARTITION%YN = 0 TYPE%PARTITION%NY = 0 TYPE%PARTITION%FORMAT = .TRUE. -!/COU TYPE%COUPLING%SENT = 'unset' -!/COU TYPE%COUPLING%RECEIVED = 'unset' -!/COU TYPE%COUPLING%COUPLET0 = .FALSE. +#ifdef W3_COU + TYPE%COUPLING%SENT = 'unset' + TYPE%COUPLING%RECEIVED = 'unset' + TYPE%COUPLING%COUPLET0 = .FALSE. +#endif TYPE%RESTART%EXTRA = 'unset' @@ -729,7 +765,9 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -740,10 +778,14 @@ SUBROUTINE READ_OUTPUT_DATE_NML (NDSI, NML_OUTPUT_DATE) INTEGER :: IERR TYPE(NML_OUTPUT_DATE_T) :: DATE NAMELIST /OUTPUT_DATE_NML/ DATE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_OUTPUT_DATE_NML') +#endif ! set default values for output_date structure DATE%FIELD%START = '19680606 000000' @@ -859,7 +901,9 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) USE WMMDATMD, ONLY: MDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -873,10 +917,14 @@ SUBROUTINE READ_HOMOGENEOUS_NML (NDSI, NML_HOMOG_COUNT, NML_HOMOG_INPUT) NAMELIST /HOMOG_COUNT_NML/ HOMOG_COUNT TYPE(NML_HOMOG_INPUT_T), ALLOCATABLE :: HOMOG_INPUT(:) NAMELIST /HOMOG_INPUT_NML/ HOMOG_INPUT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_HOMOGENEOUS_NML') +#endif ! set default values for homogeneous number structure HOMOG_COUNT%N_IC1 = 0 @@ -1010,14 +1058,20 @@ SUBROUTINE REPORT_DOMAIN_NML (NML_DOMAIN) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_DOMAIN_T), INTENT(IN) :: NML_DOMAIN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_DOMAIN_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_DOMAIN_NML') +#endif WRITE (MSG,'(A)') 'DOMAIN % ' WRITE (NDSN,'(A)') @@ -1097,16 +1151,22 @@ SUBROUTINE REPORT_INPUT_NML (NML_INPUT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_INPUT_T), INTENT(IN) :: NML_INPUT ! locals -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_INPUT_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_INPUT_NML') +#endif WRITE (MSG,'(A)') 'INPUT GRID % :' WRITE (NDSN,'(A)') @@ -1200,16 +1260,22 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NML_OUTPUT_TYPE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_OUTPUT_TYPE_T), INTENT(IN) :: NML_OUTPUT_TYPE ! locals -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OUTPUT_TYPE_NML') +#endif WRITE (MSG,'(A)') 'OUTPUT TYPE % ' WRITE (NDSN,'(A)') @@ -1223,9 +1289,11 @@ SUBROUTINE REPORT_OUTPUT_TYPE_NML (NML_OUTPUT_TYPE) WRITE (NDSN,11) TRIM(MSG),'PARTITION % YN = ', NML_OUTPUT_TYPE%PARTITION%YN WRITE (NDSN,11) TRIM(MSG),'PARTITION % NY = ', NML_OUTPUT_TYPE%PARTITION%NY WRITE (NDSN,13) TRIM(MSG),'PARTITION % FORMAT = ', NML_OUTPUT_TYPE%PARTITION%FORMAT -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % SENT = ', TRIM(NML_OUTPUT_TYPE%COUPLING%SENT) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % RECEIVED = ', TRIM(NML_OUTPUT_TYPE%COUPLING%RECEIVED) -!/COU WRITE (NDSN,13) TRIM(MSG),'COUPLING % COUPLET0 = ', NML_OUTPUT_TYPE%COUPLING%COUPLET0 +#ifdef W3_COU + WRITE (NDSN,10) TRIM(MSG),'COUPLING % SENT = ', TRIM(NML_OUTPUT_TYPE%COUPLING%SENT) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % RECEIVED = ', TRIM(NML_OUTPUT_TYPE%COUPLING%RECEIVED) + WRITE (NDSN,13) TRIM(MSG),'COUPLING % COUPLET0 = ', NML_OUTPUT_TYPE%COUPLING%COUPLET0 +#endif WRITE (NDSN,10) TRIM(MSG),'RESTART % EXTRA = ', TRIM(NML_OUTPUT_TYPE%RESTART%EXTRA) 10 FORMAT (A,2X,A,A) @@ -1300,16 +1368,22 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NML_OUTPUT_DATE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_OUTPUT_DATE_T), INTENT(IN) :: NML_OUTPUT_DATE ! locals -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_OUTPUT_DATE_NML') +#endif WRITE (MSG,'(A)') 'OUTPUT DATE MODEL GRID % ' WRITE (NDSN,'(A)') @@ -1334,9 +1408,11 @@ SUBROUTINE REPORT_OUTPUT_DATE_NML (NML_OUTPUT_DATE) WRITE (NDSN,10) TRIM(MSG),'PARTITION % START = ', TRIM(NML_OUTPUT_DATE%PARTITION%START) WRITE (NDSN,10) TRIM(MSG),'PARTITION % STRIDE = ', TRIM(NML_OUTPUT_DATE%PARTITION%STRIDE) WRITE (NDSN,10) TRIM(MSG),'PARTITION % STOP = ', TRIM(NML_OUTPUT_DATE%PARTITION%STOP) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % START = ', TRIM(NML_OUTPUT_DATE%COUPLING%START) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % STRIDE = ', TRIM(NML_OUTPUT_DATE%COUPLING%STRIDE) -!/COU WRITE (NDSN,10) TRIM(MSG),'COUPLING % STOP = ', TRIM(NML_OUTPUT_DATE%COUPLING%STOP) +#ifdef W3_COU + WRITE (NDSN,10) TRIM(MSG),'COUPLING % START = ', TRIM(NML_OUTPUT_DATE%COUPLING%START) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % STRIDE = ', TRIM(NML_OUTPUT_DATE%COUPLING%STRIDE) + WRITE (NDSN,10) TRIM(MSG),'COUPLING % STOP = ', TRIM(NML_OUTPUT_DATE%COUPLING%STOP) +#endif 10 FORMAT (A,2X,A,A) @@ -1410,7 +1486,9 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -1419,9 +1497,13 @@ SUBROUTINE REPORT_HOMOGENEOUS_NML (NML_HOMOG_COUNT, NML_HOMOG_INPUT) ! locals INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_HOMOGENEOUS_NML') +#endif WRITE (MSG,'(A)') 'HOMOG_COUNT % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmltrncmd.ftn b/model/src/w3nmltrncmd.F90 similarity index 93% rename from model/ftn/w3nmltrncmd.ftn rename to model/src/w3nmltrncmd.F90 index 55d43706d..da72a35f8 100644 --- a/model/ftn/w3nmltrncmd.ftn +++ b/model/src/w3nmltrncmd.F90 @@ -108,7 +108,9 @@ SUBROUTINE W3NMLTRNC (NDSI, INFILE, NML_TRACK, NML_FILE, IERR) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -117,10 +119,14 @@ SUBROUTINE W3NMLTRNC (NDSI, INFILE, NML_TRACK, NML_FILE, IERR) TYPE(NML_TRACK_T), INTENT(INOUT) :: NML_TRACK TYPE(NML_FILE_T), INTENT(INOUT) :: NML_FILE INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLTRNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLTRNC') +#endif ! open namelist log file NDSN = 3 @@ -218,7 +224,9 @@ SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -229,10 +237,14 @@ SUBROUTINE READ_TRACK_NML (NDSI, NML_TRACK) ! locals TYPE(NML_TRACK_T) :: TRACK NAMELIST /TRACK_NML/ TRACK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_TRACK_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_TRACK_NML') +#endif ! set default values for track structure TRACK%TIMESTART = '19000101 000000' @@ -318,7 +330,9 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -329,10 +343,14 @@ SUBROUTINE READ_FILE_NML (NDSI, NML_FILE) ! locals TYPE(NML_FILE_T) :: FILE NAMELIST /FILE_NML/ FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_FILE_NML') +#endif ! set default values for file structure FILE%PREFIX = 'ww3.' @@ -417,14 +435,20 @@ SUBROUTINE REPORT_TRACK_NML (NML_TRACK) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_TRACK_T), INTENT(IN) :: NML_TRACK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_TRACK_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_TRACK_NML') +#endif WRITE (MSG,'(A)') 'TRACK % ' WRITE (NDSN,'(A)') @@ -503,14 +527,20 @@ SUBROUTINE REPORT_FILE_NML (NML_FILE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_FILE_T), INTENT(IN) :: NML_FILE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_FILE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_FILE_NML') +#endif WRITE (MSG,'(A)') 'FILE % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3nmluprstrmd.ftn b/model/src/w3nmluprstrmd.F90 similarity index 93% rename from model/ftn/w3nmluprstrmd.ftn rename to model/src/w3nmluprstrmd.F90 index 1c6cd9949..f4504d363 100644 --- a/model/ftn/w3nmluprstrmd.ftn +++ b/model/src/w3nmluprstrmd.F90 @@ -109,7 +109,9 @@ SUBROUTINE W3NMLUPRSTR (NDSI, INFILE, NML_RESTART, NML_UPDATE, IERR) !/ ------------------------------------------------------------------- / USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -118,10 +120,14 @@ SUBROUTINE W3NMLUPRSTR (NDSI, INFILE, NML_RESTART, NML_UPDATE, IERR) TYPE(NML_RESTART_T), INTENT(INOUT) :: NML_RESTART TYPE(NML_UPDATE_T), INTENT(INOUT) :: NML_UPDATE INTEGER, INTENT(OUT) :: IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'W3NMLUPRSTR') +#ifdef W3_S + CALL STRACE (IENT, 'W3NMLUPRSTR') +#endif ! open namelist log file NDSN = 3 @@ -216,7 +222,9 @@ SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -227,10 +235,14 @@ SUBROUTINE READ_RESTART_NML (NDSI, NML_RESTART) INTEGER :: IERR TYPE(NML_RESTART_T) :: RESTART NAMELIST /RESTART_NML/ RESTART -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_RESTART_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_RESTART_NML') +#endif ! set default values RESTART%RESTARTTIME = '19680607 120000' @@ -313,7 +325,9 @@ SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -324,10 +338,14 @@ SUBROUTINE READ_UPDATE_NML (NDSI, NML_UPDATE) INTEGER :: IERR TYPE(NML_UPDATE_T) :: UPDATE NAMELIST /UPDATE_NML/ UPDATE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif IERR = 0 -!/S CALL STRACE (IENT, 'READ_UPDATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'READ_UPDATE_NML') +#endif ! set default values for update approach ! as set, these would run the update but not correct @@ -413,14 +431,20 @@ SUBROUTINE REPORT_RESTART_NML (NML_RESTART) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_RESTART_T), INTENT(IN) :: NML_RESTART -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_RESTART_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_RESTART_NML') +#endif WRITE (MSG,'(A)') 'RESTART % ' WRITE (NDSN,'(A)') @@ -490,14 +514,20 @@ SUBROUTINE REPORT_UPDATE_NML (NML_UPDATE) ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE TYPE(NML_UPDATE_T), INTENT(IN) :: NML_UPDATE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'REPORT_UPDATE_NML') +#ifdef W3_S + CALL STRACE (IENT, 'REPORT_UPDATE_NML') +#endif WRITE (MSG,'(A)') 'UPDATE % ' WRITE (NDSN,'(A)') diff --git a/model/ftn/w3oacpmd.ftn b/model/src/w3oacpmd.F90 similarity index 72% rename from model/ftn/w3oacpmd.ftn rename to model/src/w3oacpmd.F90 index 69082b5b8..d4190384f 100644 --- a/model/ftn/w3oacpmd.ftn +++ b/model/src/w3oacpmd.F90 @@ -199,8 +199,12 @@ SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) USE W3GDATMD, ONLY: NX, NY, FLAGLL, XGRD, YGRD, MAPSTA, & & HPFAC, HQFAC, GTYPE, & & UNGTYPE, RLGTYPE, CLGTYPE, SMCTYPE -!/SMC USE W3GDATMD, ONLY: NSEA, X0, Y0, MRFct, SX, SY, IJKCel -!/MPI INCLUDE "mpif.h" +#ifdef W3_SMC + USE W3GDATMD, ONLY: NSEA, X0, Y0, MRFct, SX, SY, IJKCel +#endif +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif ! !/ ------------------------------------------------------------------- / !/ Parameter list @@ -216,7 +220,9 @@ SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) REAL, ALLOCATABLE :: LON(:,:),LAT(:,:),AREA(:,:), & CORLON(:,:,:),CORLAT(:,:,:) REAL :: FACTOR -!/SMC REAL :: DLON, DLAT +#ifdef W3_SMC + REAL :: DLON, DLAT +#endif !/ ------------------------------------------------------------------- / ! IF (LD_MASTER) THEN @@ -287,37 +293,39 @@ SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) END IF END DO END DO -!/SMC ELSE IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC ! -!/SMC ! 1.2. SMC grids -!/SMC ! ---------------------------------- -!/SMC NNODES = NSEA -!/SMC ! -!/SMC ! Calculate the smallest grid cell increments depending on the number of SMC levels -!/SMC DLON = SX / MRFct -!/SMC DLAT = SY / MRFct -!/SMC ! -!/SMC ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) -!/SMC ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) -!/SMC ALLOCATE ( MASK(NNODES,1) ) -!/SMC DO I=1, NNODES -!/SMC ! lat/lon -!/SMC LON(I,1) = X0 + (IJKCel(1,I) + IJKCel(3,I)*0.5)*DLON -!/SMC LAT(I,1) = Y0 + (IJKCel(2,I) + IJKCel(4,I)*0.5)*DLAT -!/SMC ! corners -!/SMC CORLON(I,1,1) = X0 + IJKCel(1,I)*DLON -!/SMC CORLON(I,1,2) = X0 + (IJKCel(1,I) + IJKCel(3,I))*DLON -!/SMC CORLON(I,1,3) = CORLON(I,1,2) -!/SMC CORLON(I,1,4) = CORLON(I,1,1) -!/SMC CORLAT(I,1,1) = Y0 + IJKCel(2,I)*DLAT -!/SMC CORLAT(I,1,2)=CORLAT(I,1,1) -!/SMC CORLAT(I,1,3) = Y0 + (IJKCel(2,I) + IJKCel(4,I))*DLAT -!/SMC CORLAT(I,1,4)=CORLAT(I,1,3) -!/SMC ! areas -!/SMC AREA(I,1) = 0.25 * IJKCEL(3,I)*DLON * IJKCEL(4,I)*DLAT -!/SMC ! Model grid mask -!/SMC MASK(I,1) = 1 -!/SMC ENDDO +#ifdef W3_SMC + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + ! + ! 1.2. SMC grids + ! ---------------------------------- + NNODES = NSEA + ! + ! Calculate the smallest grid cell increments depending on the number of SMC levels + DLON = SX / MRFct + DLAT = SY / MRFct + ! + ALLOCATE ( LON(NNODES,1), LAT(NNODES,1) ) + ALLOCATE ( AREA(NNODES,1), CORLON(NNODES,1,4), CORLAT(NNODES,1,4) ) + ALLOCATE ( MASK(NNODES,1) ) + DO I=1, NNODES + ! lat/lon + LON(I,1) = X0 + (IJKCel(1,I) + IJKCel(3,I)*0.5)*DLON + LAT(I,1) = Y0 + (IJKCel(2,I) + IJKCel(4,I)*0.5)*DLAT + ! corners + CORLON(I,1,1) = X0 + IJKCel(1,I)*DLON + CORLON(I,1,2) = X0 + (IJKCel(1,I) + IJKCel(3,I))*DLON + CORLON(I,1,3) = CORLON(I,1,2) + CORLON(I,1,4) = CORLON(I,1,1) + CORLAT(I,1,1) = Y0 + IJKCel(2,I)*DLAT + CORLAT(I,1,2)=CORLAT(I,1,1) + CORLAT(I,1,3) = Y0 + (IJKCel(2,I) + IJKCel(4,I))*DLAT + CORLAT(I,1,4)=CORLAT(I,1,3) + ! areas + AREA(I,1) = 0.25 * IJKCEL(3,I)*DLON * IJKCEL(4,I)*DLAT + ! Model grid mask + MASK(I,1) = 1 + ENDDO +#endif ! ELSE ! @@ -345,7 +353,9 @@ SUBROUTINE CPL_OASIS_GRID(LD_MASTER,ID_LCOMM) ! ENDIF ! -!/MPI CALL MPI_BCAST(NNODES,1,MPI_INTEGER,0,ID_LCOMM,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BCAST(NNODES,1,MPI_INTEGER,0,ID_LCOMM,IERR_MPI) +#endif ! !/ ------------------------------------------------------------------- / END SUBROUTINE CPL_OASIS_GRID @@ -456,21 +466,23 @@ SUBROUTINE CPL_OASIS_DEFINE(NDSO,RCV_STR,SND_STR) ILA_PARAL(JSEA*2+1) = (IY - NHYN -1)*(NX - NHXE - NHXW) + (IX - NHXW - 1) ILA_PARAL(JSEA*2+2) = 1 END DO -!/SMC ELSE IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC ! -!/SMC ! 1.2. SMC grids -!/SMC ! ---------------------------------- -!/SMC ALLOCATE(ILA_PARAL(2+NSEAL)) -!/SMC ! -!/SMC ! * Define the partition : OASIS POINTS partition -!/SMC ILA_PARAL(1) = 4 -!/SMC ! -!/SMC ! * total number of segments of the global domain -!/SMC ILA_PARAL(2) = NSEAL -!/SMC ! -!/SMC DO JSEA=1, NSEAL -!/SMC ILA_PARAL(JSEA+2) = IAPROC + (JSEA-1)*NAPROC -!/SMC ENDDO +#ifdef W3_SMC + ELSE IF( GTYPE .EQ. SMCTYPE ) THEN + ! + ! 1.2. SMC grids + ! ---------------------------------- + ALLOCATE(ILA_PARAL(2+NSEAL)) + ! + ! * Define the partition : OASIS POINTS partition + ILA_PARAL(1) = 4 + ! + ! * total number of segments of the global domain + ILA_PARAL(2) = NSEAL + ! + DO JSEA=1, NSEAL + ILA_PARAL(JSEA+2) = IAPROC + (JSEA-1)*NAPROC + ENDDO +#endif ! ELSE ! @@ -824,78 +836,106 @@ SUBROUTINE GET_LIST_EXCH_FIELD(NDSO, RCV, SND, ID_NB_RCV, ID_NB_SND, RCV_STR, SN ! ! OCEAM MODEL VARIABLES ! -!/OASOCM CASE('DRY') -!/OASOCM ! wet-drying at the middle of the cell -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDH' -! -!/OASOCM ! wet-drying at u-location -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDU' +#ifdef W3_OASOCM + CASE('DRY') + ! wet-drying at the middle of the cell + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDH' +#endif +! +#ifdef W3_OASOCM + ! wet-drying at u-location + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDU' +#endif ! -!/OASOCM ! wet-drying at v-location -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDV' -! -!/OASOCM CASE('SSH') -!/OASOCM ! ssh : sea surface height (m) -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__SSH' -! -!/OASOCM CASE('CUR') -!/OASOCM ! uz : sea surface zonal currents (m.s-1) -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSU' -! -!/OASOCM ! vz : sea surface meridional currents (m.s-1) -!/OASOCM ID_NB_RCV=ID_NB_RCV+1 -!/OASOCM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSV' +#ifdef W3_OASOCM + ! wet-drying at v-location + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OWDV' +#endif +! +#ifdef W3_OASOCM + CASE('SSH') + ! ssh : sea surface height (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__SSH' +#endif +! +#ifdef W3_OASOCM + CASE('CUR') + ! uz : sea surface zonal currents (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSU' +#endif +! +#ifdef W3_OASOCM + ! vz : sea surface meridional currents (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_OSSV' +#endif ! ! ! ATMOSPHERE MODEL VARIABLES ! -!/OASACM CASE('WND') -!/OASACM ! U10 : 10m u-wind speed (m.s-1) -!/OASACM ID_NB_RCV=ID_NB_RCV+1 -!/OASACM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__U10' -! -!/OASACM ! V10 : 10m v-wind speed (m.s-1) -!/OASACM ID_NB_RCV=ID_NB_RCV+1 -!/OASACM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__V10' -! -!/OASACM CASE('TAU') -!/OASACM ! UTAUA : u-momentum (m2.s-2) -!/OASACM ID_NB_RCV=ID_NB_RCV+1 -!/OASACM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_UTAU' -! -!/OASACM ! V10 : v-momentum speed (m2.s-2) -!/OASACM ID_NB_RCV=ID_NB_RCV+1 -!/OASACM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_VTAU' -! -!/OASACM CASE('RHO') -!/OASACM ! rhoa : air density (kg.m-3) -!/OASACM ID_NB_RCV=ID_NB_RCV+1 -!/OASACM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_RHOA' +#ifdef W3_OASACM + CASE('WND') + ! U10 : 10m u-wind speed (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__U10' +#endif +! +#ifdef W3_OASACM + ! V10 : 10m v-wind speed (m.s-1) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__V10' +#endif +! +#ifdef W3_OASACM + CASE('TAU') + ! UTAUA : u-momentum (m2.s-2) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_UTAU' +#endif +! +#ifdef W3_OASACM + ! V10 : v-momentum speed (m2.s-2) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_VTAU' +#endif +! +#ifdef W3_OASACM + CASE('RHO') + ! rhoa : air density (kg.m-3) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3_RHOA' +#endif ! ! ! ICE MODEL VARIABLES ! -!/OASICM CASE('IC1') -!/OASICM ! IC1 : ice thickness (m) -!/OASICM ID_NB_RCV=ID_NB_RCV+1 -!/OASICM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC1' -! -!/OASICM CASE('IC5') -!/OASICM ! ICEF : ice floe diameters (m) -!/OASICM ID_NB_RCV=ID_NB_RCV+1 -!/OASICM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC5' -! -!/OASICM CASE('ICE') -!/OASICM ! ICE : ice concentration (n.d) -!/OASICM ID_NB_RCV=ID_NB_RCV+1 -!/OASICM RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__ICE' +#ifdef W3_OASICM + CASE('IC1') + ! IC1 : ice thickness (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC1' +#endif +! +#ifdef W3_OASICM + CASE('IC5') + ! ICEF : ice floe diameters (m) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__IC5' +#endif +! +#ifdef W3_OASICM + CASE('ICE') + ! ICE : ice concentration (n.d) + ID_NB_RCV=ID_NB_RCV+1 + RCV(ID_NB_RCV)%CL_FIELD_NAME='WW3__ICE' +#endif ! CASE DEFAULT @@ -918,188 +958,262 @@ SUBROUTINE GET_LIST_EXCH_FIELD(NDSO, RCV, SND, ID_NB_RCV, ID_NB_SND, RCV_STR, SN ! ! OCEAM MODEL VARIABLES ! -!/OASOCM CASE('OHS') -!/OASOCM ! Significant wave height (m) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__OHS' -! -!/OASOCM CASE('DRY') -!/OASOCM ! mask to manage wet-drying -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ODRY' -! -!/OASOCM CASE('T0M1') -!/OASOCM ! T0M1 / wave_t0m1 : mean period (s) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_T0M1' -! -!/OASOCM CASE('T01') -!/OASOCM ! T01 / wave_t01 : mean period (s) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__T01' -! -!/OASOCM CASE('DIR') -!/OASOCM ! THM / wave_thm : cosinus of mean direction (n/a) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_CDIR' -! -!/OASOCM ! THM / wave_thm : sinus of mean direction (n/a) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_SDIR' -! -!/OASOCM CASE('THM') -!/OASOCM ! THM / wave_thm : mean direction (n/a) -!/OASOCM ! exchange the mean direction instead of cos/sin projection -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__DIR' -! -!/OASOCM CASE('BHD') -!/OASOCM ! BHD / wave_bhd : wave-induced Bernoulli head pressure (bhd in N.m-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__BHD' -! -!/OASOCM CASE('TWO') -!/OASOCM ! tauox / wave_tauox : x-component of the wave-ocean momentum flux (tauox in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOX' -! -!/OASOCM ! tauoy / wave_tauoy : y-component of the wave-ocean momentum flux (tauox in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOY' -! -!/OASOCM CASE('TOC') -!/OASOCM ! tauocx / wave_tauocx : x-component of the total wave-ocean momentum flux (tauocx in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCX' -! -!/OASOCM ! tauocy / wave_tauocy : y-component of the total wave-ocean momentum flux (tauocx in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCY' -! -!/OASOCM CASE('FOC') -!/OASOCM ! phioc / wave_phioc : Wave-to-ocean TKE flux (phioc in W.m-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FOC' -! -!/OASOCM CASE('TBB') -!/OASOCM ! Momentum flux due to bottom friction, u component (m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBX' -! -!/OASOCM ! Momentum flux due to bottom friction, v component (m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBY' -! -!/OASOCM CASE('FBB') -!/OASOCM ! phibbl / wave_phibbl : Energy flux due to bottom friction (phioc in W.m-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FBB' -! -!/OASOCM CASE('UBR') -!/OASOCM ! uba / wave_ubrx : x component of the rms amplitude of orbital velocity of the waves (m/s) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRX' -! -!/OASOCM ! uba / wave_ubry : y component of the rms amplitude of orbital velocity of the waves (m/s) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRY' -! -!/OASOCM CASE('TAW') -!/OASOCM ! tauwix / wave_tauwix : Net wave-supported stress, u component (tauwix in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWX' -! -!/OASOCM ! tauwiy / wave_tauwiy : ! Net wave-supported stress, v component (tauwix in m2.s-2) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWY' -! -!/OASOCM CASE('LM') -!/OASOCM ! wlm / wave_wlm : mean length wave (m) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3___LM' -! -!/OASOCM CASE('WNM') -!/OASOCM ! wnmean / wave_wnmean : mean wave number (m-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__WNM' -! -!/OASOCM CASE('TUS') -!/OASOCM ! Volume transport associated to Stokes drift, u component (m2.s-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSX' -! -!/OASOCM ! Volume transport associated to Stokes drift, v component (m2.s-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSY' -! -!/OASOCM CASE('USS') -!/OASOCM ! Surface Stokes drift, u component (m.s-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSX' -! -!/OASOCM ! Surface Stokes drift, v component (m.s-1) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSY' -! -!/OASOCM CASE('OCHA') -!/OASOCM ! Charnock Coefficient (-) -!/OASOCM ID_NB_SND = ID_NB_SND +1 -!/OASOCM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_OCHA' +#ifdef W3_OASOCM + CASE('OHS') + ! Significant wave height (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__OHS' +#endif +! +#ifdef W3_OASOCM + CASE('DRY') + ! mask to manage wet-drying + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ODRY' +#endif +! +#ifdef W3_OASOCM + CASE('T0M1') + ! T0M1 / wave_t0m1 : mean period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_T0M1' +#endif +! +#ifdef W3_OASOCM + CASE('T01') + ! T01 / wave_t01 : mean period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__T01' +#endif +! +#ifdef W3_OASOCM + CASE('DIR') + ! THM / wave_thm : cosinus of mean direction (n/a) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_CDIR' +#endif +! +#ifdef W3_OASOCM + ! THM / wave_thm : sinus of mean direction (n/a) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_SDIR' +#endif +! +#ifdef W3_OASOCM + CASE('THM') + ! THM / wave_thm : mean direction (n/a) + ! exchange the mean direction instead of cos/sin projection + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__DIR' +#endif +! +#ifdef W3_OASOCM + CASE('BHD') + ! BHD / wave_bhd : wave-induced Bernoulli head pressure (bhd in N.m-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__BHD' +#endif +! +#ifdef W3_OASOCM + CASE('TWO') + ! tauox / wave_tauox : x-component of the wave-ocean momentum flux (tauox in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOX' +#endif +! +#ifdef W3_OASOCM + ! tauoy / wave_tauoy : y-component of the wave-ocean momentum flux (tauox in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWOY' +#endif +! +#ifdef W3_OASOCM + CASE('TOC') + ! tauocx / wave_tauocx : x-component of the total wave-ocean momentum flux (tauocx in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCX' +#endif +! +#ifdef W3_OASOCM + ! tauocy / wave_tauocy : y-component of the total wave-ocean momentum flux (tauocx in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TOCY' +#endif +! +#ifdef W3_OASOCM + CASE('FOC') + ! phioc / wave_phioc : Wave-to-ocean TKE flux (phioc in W.m-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FOC' +#endif +! +#ifdef W3_OASOCM + CASE('TBB') + ! Momentum flux due to bottom friction, u component (m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBX' +#endif +! +#ifdef W3_OASOCM + ! Momentum flux due to bottom friction, v component (m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TBBY' +#endif +! +#ifdef W3_OASOCM + CASE('FBB') + ! phibbl / wave_phibbl : Energy flux due to bottom friction (phioc in W.m-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FBB' +#endif +! +#ifdef W3_OASOCM + CASE('UBR') + ! uba / wave_ubrx : x component of the rms amplitude of orbital velocity of the waves (m/s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRX' +#endif +! +#ifdef W3_OASOCM + ! uba / wave_ubry : y component of the rms amplitude of orbital velocity of the waves (m/s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_UBRY' +#endif +! +#ifdef W3_OASOCM + CASE('TAW') + ! tauwix / wave_tauwix : Net wave-supported stress, u component (tauwix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWX' +#endif +! +#ifdef W3_OASOCM + ! tauwiy / wave_tauwiy : ! Net wave-supported stress, v component (tauwix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TAWY' +#endif +! +#ifdef W3_OASOCM + CASE('LM') + ! wlm / wave_wlm : mean length wave (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___LM' +#endif +! +#ifdef W3_OASOCM + CASE('WNM') + ! wnmean / wave_wnmean : mean wave number (m-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__WNM' +#endif +! +#ifdef W3_OASOCM + CASE('TUS') + ! Volume transport associated to Stokes drift, u component (m2.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSX' +#endif +! +#ifdef W3_OASOCM + ! Volume transport associated to Stokes drift, v component (m2.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TUSY' +#endif +! +#ifdef W3_OASOCM + CASE('USS') + ! Surface Stokes drift, u component (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSX' +#endif +! +#ifdef W3_OASOCM + ! Surface Stokes drift, v component (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_USSY' +#endif +! +#ifdef W3_OASOCM + CASE('OCHA') + ! Charnock Coefficient (-) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_OCHA' +#endif ! ! ATMOSPHERE MODEL VARIABLES ! -!/OASACM CASE('AHS') -!/OASACM ! Significant wave height (m) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__AHS' -! -!/OASACM CASE('CUR') -!/OASACM ! Ocean sea surface current (m.s-1) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSU' -! -!/OASACM ! Ocean sea surface current (m.s-1) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSV' -! -!/OASACM CASE('ACHA') -!/OASACM ! Charnock Coefficient (-) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ACHA' -! -!/OASACM CASE('FP') -!/OASACM ! Peak frequency (s-1) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3___FP' -! -!/OASACM CASE('TP') -!/OASACM ! Peak period (s) -!/OASACM ID_NB_SND = ID_NB_SND +1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3___TP' -! -!/OASACM CASE('FWS') -!/OASACM ! Wind_sea_mean_period_T0M1 (s) -!/OASACM ID_NB_SND=ID_NB_SND+1 -!/OASACM SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FWS' +#ifdef W3_OASACM + CASE('AHS') + ! Significant wave height (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__AHS' +#endif +! +#ifdef W3_OASACM + CASE('CUR') + ! Ocean sea surface current (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSU' +#endif +! +#ifdef W3_OASACM + ! Ocean sea surface current (m.s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_WSSV' +#endif +! +#ifdef W3_OASACM + CASE('ACHA') + ! Charnock Coefficient (-) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ACHA' +#endif +! +#ifdef W3_OASACM + CASE('FP') + ! Peak frequency (s-1) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___FP' +#endif +! +#ifdef W3_OASACM + CASE('TP') + ! Peak period (s) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3___TP' +#endif +! +#ifdef W3_OASACM + CASE('FWS') + ! Wind_sea_mean_period_T0M1 (s) + ID_NB_SND=ID_NB_SND+1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3__FWS' +#endif ! ! ! ICE MODEL VARIABLES ! -!/OASICM CASE('IC5') -!/OASICM ! Ice floe diameters (m) -!/OASICM ID_NB_SND = ID_NB_SND +1 -!/OASICM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ICEF' -! -!/OASICM CASE('TWI') -!/OASICM ! TWIX : x stress to ice , u component (twix in m2.s-2) -!/OASICM ID_NB_SND = ID_NB_SND +1 -!/OASICM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIX' -! -!/OASICM ! TWIY : y stress to ice , v component (twiy in m2.s-2) -!/OASICM ID_NB_SND = ID_NB_SND +1 -!/OASICM SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIY' +#ifdef W3_OASICM + CASE('IC5') + ! Ice floe diameters (m) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_ICEF' +#endif +! +#ifdef W3_OASICM + CASE('TWI') + ! TWIX : x stress to ice , u component (twix in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIX' +#endif +! +#ifdef W3_OASICM + ! TWIY : y stress to ice , v component (twiy in m2.s-2) + ID_NB_SND = ID_NB_SND +1 + SND(ID_NB_SND)%CL_FIELD_NAME='WW3_TWIY' +#endif ! CASE DEFAULT WRITE (NDSO,1002) TRIM(TESTSTR(1:6)) diff --git a/model/ftn/w3odatmd.ftn b/model/src/w3odatmd.F90 similarity index 90% rename from model/ftn/w3odatmd.ftn rename to model/src/w3odatmd.F90 index 71ae28536..a845e8fe2 100644 --- a/model/ftn/w3odatmd.ftn +++ b/model/src/w3odatmd.F90 @@ -338,8 +338,10 @@ MODULE W3ODATMD !/ TYPE OTYPE1 INTEGER :: IPASS1 -!/MPI INTEGER :: NRQGO, NRQGO2 -!/MPI INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#ifdef W3_MPI + INTEGER :: NRQGO, NRQGO2 + INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#endif LOGICAL :: FLOGRD(NOGRP,NGRPP), FLOGD(NOGRP), & FLOGR2(NOGRP,NGRPP), FLOG2(NOGRP), & FLOGRR(NOGRP,NGRPP), FLOGR(NOGRP), & @@ -348,12 +350,18 @@ MODULE W3ODATMD !/ TYPE OTYPE2 INTEGER :: IPASS2, NOPTS -!/MPI INTEGER :: NRQPO, NRQPO2 +#ifdef W3_MPI + INTEGER :: NRQPO, NRQPO2 +#endif INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) -!/MPI INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) +#endif REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & DPO(:), WAO(:), WDO(:), ASO(:), & -!/FLX5 TAUAO(:), TAUDO(:), DAIRO(:), & +#ifdef W3_FLX5 + TAUAO(:), TAUDO(:), DAIRO(:), & +#endif CAO(:), CDO(:), ICEO(:), ICEHO(:), & ICEFO(:), SPCO(:,:) REAL, POINTER :: ZET_SETO(:) ! For the wave setup. @@ -361,13 +369,17 @@ MODULE W3ODATMD CHARACTER(LEN=40), POINTER :: PTNME(:) CHARACTER(LEN=13), POINTER :: GRDID(:) LOGICAL :: O2INIT -!/MPI LOGICAL :: O2IRQI +#ifdef W3_MPI + LOGICAL :: O2IRQI +#endif END TYPE OTYPE2 !/ TYPE OTYPE3 INTEGER :: IPASS3 -!/MPI INTEGER :: IT0PNT, IT0TRK, IT0PRT, NRQTR -!/MPI INTEGER, POINTER :: IRQTR(:) +#ifdef W3_MPI + INTEGER :: IT0PNT, IT0TRK, IT0PRT, NRQTR + INTEGER, POINTER :: IRQTR(:) +#endif LOGICAL :: O3INIT, STOP LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) CHARACTER(LEN=32), POINTER :: TRCKID(:,:) @@ -375,18 +387,24 @@ MODULE W3ODATMD !/ TYPE OTYPE4 INTEGER :: IFILE4 -!/MPI INTEGER :: NRQRS, NBLKRS, RSBLKS -!/MPI INTEGER, POINTER :: IRQRS(:), IRQRSS(:) -!/MPI REAL, POINTER :: VAAUX(:,:,:) +#ifdef W3_MPI + INTEGER :: NRQRS, NBLKRS, RSBLKS + INTEGER, POINTER :: IRQRS(:), IRQRSS(:) + REAL, POINTER :: VAAUX(:,:,:) +#endif END TYPE OTYPE4 !/ TYPE OTYPE5 INTEGER :: NBI, NBI2, NFBPO, NBO(0:9), & NBO2(0:9), NDSL(9), NKI, NTHI -!/MPI INTEGER :: NRQBP = 0, NRQBP2 = 0 +#ifdef W3_MPI + INTEGER :: NRQBP = 0, NRQBP2 = 0 +#endif INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & IPBPO(:,:), ISBPO(:) -!/MPI INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#endif REAL :: XFRI, FR1I, TH1I REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & XBPO(:), YBPO(:), RDBPO(:,:), & @@ -414,7 +432,9 @@ MODULE W3ODATMD NAPOUT, NAPERR, NAPFLD, NAPPNT, & NAPTRK, NAPRST, NAPBPT, NAPPRT INTEGER :: NOSWLL -!/NL5 INTEGER :: TOSNL5(2) +#ifdef W3_NL5 + INTEGER :: TOSNL5(2) +#endif INTEGER :: TOFRST(2), TONEXT(2,8), TOLAST(2,8), & TBPI0(2), TBPIN(2), NDS(13), OFILES(7) REAL :: DTOUT(8) @@ -438,7 +458,9 @@ MODULE W3ODATMD NAPOUT, NAPERR, NAPFLD, NAPPNT, & NAPTRK, NAPRST, NAPBPT, NAPPRT INTEGER, POINTER :: NOSWLL -!/NL5 INTEGER, POINTER :: TOSNL5(:) +#ifdef W3_NL5 + INTEGER, POINTER :: TOSNL5(:) +#endif INTEGER, POINTER :: TOFRST(:), TONEXT(:,:), TOLAST(:,:), & TBPI0(:), TBPIN(:), NDS(:) INTEGER, POINTER :: OFILES(:) @@ -449,8 +471,10 @@ MODULE W3ODATMD !/ Type 1 ... !/ INTEGER, POINTER :: IPASS1 -!/MPI INTEGER, POINTER :: NRQGO, NRQGO2 -!/MPI INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#ifdef W3_MPI + INTEGER, POINTER :: NRQGO, NRQGO2 + INTEGER, POINTER :: IRQGO(:), IRQGO2(:) +#endif LOGICAL, POINTER :: FLOGRD(:,:), FLOGR2(:,:), & FLOGRR(:,:),FLOGD(:), FLOG2(:), & FLOGR(:), WRITE1 @@ -458,12 +482,18 @@ MODULE W3ODATMD !/ Type 2 ... !/ INTEGER, POINTER :: IPASS2, NOPTS -!/MPI INTEGER, POINTER :: NRQPO, NRQPO2 +#ifdef W3_MPI + INTEGER, POINTER :: NRQPO, NRQPO2 +#endif INTEGER, POINTER :: IPTINT(:,:,:), IL(:), IW(:), II(:) -!/MPI INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQPO1(:), IRQPO2(:) +#endif REAL, POINTER :: PTLOC(:,:), PTIFAC(:,:), & DPO(:), WAO(:), WDO(:), ASO(:), & -!/FLX5 TAUAO(:), TAUDO(:), DAIRO(:), & +#ifdef W3_FLX5 + TAUAO(:), TAUDO(:), DAIRO(:), & +#endif CAO(:), CDO(:), ICEO(:), ICEHO(:), & ICEFO(:), SPCO(:,:) REAL, POINTER :: ZET_SETO(:) @@ -471,13 +501,17 @@ MODULE W3ODATMD CHARACTER(LEN=40), POINTER :: PTNME(:) CHARACTER(LEN=13), POINTER :: GRDID(:) LOGICAL, POINTER :: O2INIT -!/MPI LOGICAL, POINTER :: O2IRQI +#ifdef W3_MPI + LOGICAL, POINTER :: O2IRQI +#endif !/ !/ Type 3 ... !/ INTEGER, POINTER :: IPASS3 -!/MPI INTEGER, POINTER :: IT0PNT, IT0TRK, IT0PRT, NRQTR -!/MPI INTEGER, POINTER :: IRQTR(:) +#ifdef W3_MPI + INTEGER, POINTER :: IT0PNT, IT0TRK, IT0PRT, NRQTR + INTEGER, POINTER :: IRQTR(:) +#endif LOGICAL, POINTER :: O3INIT, STOP LOGICAL, POINTER :: MASK1(:,:), MASK2(:,:) CHARACTER(LEN=32), POINTER :: TRCKID(:,:) @@ -485,18 +519,24 @@ MODULE W3ODATMD !/ Type 4 ... !/ INTEGER, POINTER :: IFILE4 -!/MPI INTEGER, POINTER :: NRQRS, NBLKRS, RSBLKS -!/MPI INTEGER, POINTER :: IRQRS(:), IRQRSS(:) -!/MPI REAL, POINTER :: VAAUX(:,:,:) +#ifdef W3_MPI + INTEGER, POINTER :: NRQRS, NBLKRS, RSBLKS + INTEGER, POINTER :: IRQRS(:), IRQRSS(:) + REAL, POINTER :: VAAUX(:,:,:) +#endif !/ !/ Type 5 ... !/ INTEGER, POINTER :: NBI, NBI2, NFBPO, NKI, NTHI INTEGER, POINTER :: NBO(:), NBO2(:), NDSL(:) -!/MPI INTEGER, POINTER :: NRQBP, NRQBP2 +#ifdef W3_MPI + INTEGER, POINTER :: NRQBP, NRQBP2 +#endif INTEGER, POINTER :: IPBPI(:,:), ISBPI(:), & IPBPO(:,:), ISBPO(:) -!/MPI INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQBP1(:), IRQBP2(:) +#endif REAL, POINTER :: XFRI, FR1I, TH1I REAL, POINTER :: XBPI(:), YBPI(:), RDBPI(:,:), & XBPO(:), YBPO(:), RDBPO(:,:), & @@ -580,7 +620,9 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NGRIDS, NAUXGR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -593,10 +635,14 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) !/ Local parameters !/ INTEGER :: I, NLOW, J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif CHARACTER(LEN=20) :: STRING !/ -!/S CALL STRACE (IENT, 'W3NOUT') +#ifdef W3_S + CALL STRACE (IENT, 'W3NOUT') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -643,21 +689,29 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) OUTPTS(I)%TBPIN = (-1,0) ! OUTPTS(I)%OUT1%IPASS1 = 0 -!/MPI OUTPTS(I)%OUT1%NRQGO = 0 -!/MPI OUTPTS(I)%OUT1%NRQGO2 = 0 +#ifdef W3_MPI + OUTPTS(I)%OUT1%NRQGO = 0 + OUTPTS(I)%OUT1%NRQGO2 = 0 +#endif ! OUTPTS(I)%OUT2%IPASS2 = 0 OUTPTS(I)%OUT2%NOPTS = 0 OUTPTS(I)%OUT2%O2INIT = .FALSE. -!/MPI OUTPTS(I)%OUT2%O2IRQI = .FALSE. +#ifdef W3_MPI + OUTPTS(I)%OUT2%O2IRQI = .FALSE. +#endif ! OUTPTS(I)%OUT3%IPASS3 = 0 OUTPTS(I)%OUT3%O3INIT = .FALSE. OUTPTS(I)%OUT3%STOP = .FALSE. -!/MPI OUTPTS(I)%OUT3%NRQTR = 0 +#ifdef W3_MPI + OUTPTS(I)%OUT3%NRQTR = 0 +#endif ! OUTPTS(I)%OUT4%IFILE4 = 0 -!/MPI OUTPTS(I)%OUT4%NRQRS = 0 +#ifdef W3_MPI + OUTPTS(I)%OUT4%NRQRS = 0 +#endif ! OUTPTS(I)%OUT5%O5INI1 = .FALSE. OUTPTS(I)%OUT5%O5INI2 = .FALSE. @@ -684,9 +738,15 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) ! 1) Forcing fields ! NOGE(1) = 9 -!/BT4 NOGE(1) = 10 -!/IS2 NOGE(1) = 12 ! CB -!/SETUP NOGE(1) = 13 ! CB +#ifdef W3_BT4 + NOGE(1) = 10 +#endif +#ifdef W3_IS2 + NOGE(1) = 12 ! CB +#endif +#ifdef W3_SETUP + NOGE(1) = 13 ! CB +#endif ! IDOUT( 1, 1) = 'Water depth ' IDOUT( 1, 2) = 'Current vel. ' @@ -697,15 +757,23 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) IDOUT( 1, 7) = 'Iceberg damp coeffic' IDOUT( 1, 8) = 'Atmospheric momentum' IDOUT( 1, 9) = 'Air density ' -!/BT4 IDOUT( 1, 10) = 'Sediment diam D50 ' -!/IS2 IDOUT( 1, 11) = 'ice thickness ' -!/IS2 IDOUT( 1, 12) = 'Avg. ice floe diam. ' -!/SETUP IDOUT( 1, 13) = 'wave induced setup' +#ifdef W3_BT4 + IDOUT( 1, 10) = 'Sediment diam D50 ' +#endif +#ifdef W3_IS2 + IDOUT( 1, 11) = 'ice thickness ' + IDOUT( 1, 12) = 'Avg. ice floe diam. ' +#endif +#ifdef W3_SETUP + IDOUT( 1, 13) = 'wave induced setup' +#endif ! ! 2) Standard mean wave parameters ! NOGE(2) = 19 -!/OASOCM NOGE(2) = 20 +#ifdef W3_OASOCM + NOGE(2) = 20 +#endif ! IDOUT( 2, 1) = 'Wave height ' IDOUT( 2, 2) = 'Mean wave length ' @@ -726,7 +794,9 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) IDOUT( 2, 17) = 'Dominant wave bT ' IDOUT( 2, 18) = 'Peak prd. (from fp)' IDOUT( 2, 19) = 'Mean wave number ' -!/OASOCM IDOUT( 2, 20) = 'Mean wave dir. norot' +#ifdef W3_OASOCM + IDOUT( 2, 20) = 'Mean wave dir. norot' +#endif ! IDOUT( 2,10) = 'Mean wave dir. a2b2' ! IDOUT( 2,11) = 'Mean dir. spr. a2b2' ! IDOUT( 2,12) = 'Windsea height(Sin)' @@ -854,7 +924,9 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) IDOUT(10, I) = STRING END DO ! -!/T WRITE (NDSTST,9000) NGRIDS +#ifdef W3_T + WRITE (NDSTST,9000) NGRIDS +#endif ! RETURN ! @@ -864,7 +936,9 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) ' NGRIDS = ',I10/ & ' RUN W3NMOD FIRST'/) ! -!/T 9000 FORMAT (' TEST W3NOUT : SETTING UP FOR ',I4,' GRIDS') +#ifdef W3_T + 9000 FORMAT (' TEST W3NOUT : SETTING UP FOR ',I4,' GRIDS') +#endif !/ !/ End of W3NOUT ----------------------------------------------------- / !/ @@ -942,7 +1016,9 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: W3SETG, NGRIDS, NAUXGR, IGRID, NSPEC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -955,9 +1031,13 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) !/ Local parameters !/ INTEGER :: JGRID, NLOW -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DMO2') +#ifdef W3_S + CALL STRACE (IENT, 'W3DMO2') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -978,7 +1058,9 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -998,9 +1080,11 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) OUTPTS(IMOD)%OUT2%ZET_SETO(NPT) , & OUTPTS(IMOD)%OUT2%WDO(NPT) , & OUTPTS(IMOD)%OUT2%ASO(NPT) , & -!/FLX5 OUTPTS(IMOD)%OUT2%TAUAO(NPT) , & -!/FLX5 OUTPTS(IMOD)%OUT2%TAUDO(NPT) , & -!/FLX5 OUTPTS(IMOD)%OUT2%DAIRO(NPT) , & +#ifdef W3_FLX5 + OUTPTS(IMOD)%OUT2%TAUAO(NPT) , & + OUTPTS(IMOD)%OUT2%TAUDO(NPT) , & + OUTPTS(IMOD)%OUT2%DAIRO(NPT) , & +#endif OUTPTS(IMOD)%OUT2%CAO(NPT) , & OUTPTS(IMOD)%OUT2%CDO(NPT) , & OUTPTS(IMOD)%OUT2%ICEO(NPT) , & @@ -1012,21 +1096,27 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) ! OUTPTS(IMOD)%OUT2%O2INIT = .TRUE. ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETO ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid ! NOPTS = NPT ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary @@ -1045,10 +1135,12 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) ' NOUTP = ',I10/) 1003 FORMAT (/' *** ERROR W3DMO2 : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3DMO2 : MODEL ',I4) -!/T 9001 FORMAT (' TEST W3DMO2 : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DMO2 : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DMO2 : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DMO2 : MODEL ',I4) + 9001 FORMAT (' TEST W3DMO2 : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DMO2 : POINTERS RESET') + 9003 FORMAT (' TEST W3DMO2 : DIMENSIONS STORED') +#endif !/ !/ End of W3DMO2 ----------------------------------------------------- / !/ @@ -1122,7 +1214,9 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1135,9 +1229,13 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) !/ Local parameters !/ INTEGER :: JGRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DMO3') +#ifdef W3_S + CALL STRACE (IENT, 'W3DMO3') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1157,7 +1255,9 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -1172,19 +1272,25 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) ! OUTPTS(IMOD)%OUT3%O3INIT = .TRUE. ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETO ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary @@ -1202,10 +1308,12 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) ' NOUTP = ',I10/) 1003 FORMAT (/' *** ERROR W3DMO3 : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3DMO3 : MODEL ',I4) -!/T 9001 FORMAT (' TEST W3DMO3 : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DMO3 : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DMO3 : DIMENSIONS STORED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DMO3 : MODEL ',I4) + 9001 FORMAT (' TEST W3DMO3 : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DMO3 : POINTERS RESET') + 9003 FORMAT (' TEST W3DMO3 : DIMENSIONS STORED') +#endif !/ !/ End of W3DMO3 ----------------------------------------------------- / !/ @@ -1278,7 +1386,9 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: W3SETG, NGRIDS, IGRID, NX, NY, NSPEC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1291,9 +1401,13 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) !/ Local parameters !/ INTEGER :: JGRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3DMO5') +#ifdef W3_S + CALL STRACE (IENT, 'W3DMO5') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1308,7 +1422,9 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD, IBLOCK +#ifdef W3_T + WRITE (NDST,9000) IMOD, IBLOCK +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays and reset pointers @@ -1380,7 +1496,9 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) ! END SELECT ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! @@ -1396,8 +1514,10 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) 1010 FORMAT (/' *** ERROR W3DMO5 : ILLEGAL BLOCK NUMBER *** '/ & ' IBLOCK = ',I10/) ! -!/T 9000 FORMAT (' TEST W3DMO5 : MODEL AND BLOCK ',2I4) -!/T 9001 FORMAT (' TEST W3DMO5 : ARRAYS ALLOCATED') +#ifdef W3_T + 9000 FORMAT (' TEST W3DMO5 : MODEL AND BLOCK ',2I4) + 9001 FORMAT (' TEST W3DMO5 : ARRAYS ALLOCATED') +#endif !/ !/ End of W3DMO5 ----------------------------------------------------- / !/ @@ -1470,7 +1590,9 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NAUXGR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -1485,9 +1607,13 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) !/ INTEGER :: NLOW INTEGER :: J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3SETO') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETO') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -1503,7 +1629,9 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDSTST,9000) IMOD +#ifdef W3_T + WRITE (NDSTST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model number @@ -1533,7 +1661,9 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ! NOSWLL => OUTPTS(IMOD)%NOSWLL ! -!/NL5 TOSNL5 => OUTPTS(IMOD)%TOSNL5 +#ifdef W3_NL5 + TOSNL5 => OUTPTS(IMOD)%TOSNL5 +#endif TOFRST => OUTPTS(IMOD)%TOFRST TONEXT => OUTPTS(IMOD)%TONEXT TOLAST => OUTPTS(IMOD)%TOLAST @@ -1547,10 +1677,12 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ! IPASS1 => OUTPTS(IMOD)%OUT1%IPASS1 WRITE1 => OUTPTS(IMOD)%OUT1%WRITE1 -!/MPI NRQGO => OUTPTS(IMOD)%OUT1%NRQGO -!/MPI NRQGO2 => OUTPTS(IMOD)%OUT1%NRQGO2 -!/MPI IF ( NRQGO .NE. 0 ) IRQGO => OUTPTS(IMOD)%OUT1%IRQGO -!/MPI IF ( NRQGO2 .NE. 0 ) IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 +#ifdef W3_MPI + NRQGO => OUTPTS(IMOD)%OUT1%NRQGO + NRQGO2 => OUTPTS(IMOD)%OUT1%NRQGO2 + IF ( NRQGO .NE. 0 ) IRQGO => OUTPTS(IMOD)%OUT1%IRQGO + IF ( NRQGO2 .NE. 0 ) IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 +#endif FLOGRD => OUTPTS(IMOD)%OUT1%FLOGRD FLOGR2 => OUTPTS(IMOD)%OUT1%FLOGR2 FLOGRR => OUTPTS(IMOD)%OUT1%FLOGRR @@ -1560,10 +1692,14 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ! IPASS2 => OUTPTS(IMOD)%OUT2%IPASS2 NOPTS => OUTPTS(IMOD)%OUT2%NOPTS -!/MPI NRQPO => OUTPTS(IMOD)%OUT2%NRQPO -!/MPI NRQPO2 => OUTPTS(IMOD)%OUT2%NRQPO2 +#ifdef W3_MPI + NRQPO => OUTPTS(IMOD)%OUT2%NRQPO + NRQPO2 => OUTPTS(IMOD)%OUT2%NRQPO2 +#endif O2INIT => OUTPTS(IMOD)%OUT2%O2INIT -!/MPI O2IRQI => OUTPTS(IMOD)%OUT2%O2IRQI +#ifdef W3_MPI + O2IRQI => OUTPTS(IMOD)%OUT2%O2IRQI +#endif ! IF ( O2INIT ) THEN IPTINT => OUTPTS(IMOD)%OUT2%IPTINT @@ -1577,9 +1713,11 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ZET_SETO => OUTPTS(IMOD)%OUT2%ZET_SETO WDO => OUTPTS(IMOD)%OUT2%WDO ASO => OUTPTS(IMOD)%OUT2%ASO -!/FLX5 TAUAO => OUTPTS(IMOD)%OUT2%TAUAO -!/FLX5 TAUDO => OUTPTS(IMOD)%OUT2%TAUDO -!/FLX5 DAIRO => OUTPTS(IMOD)%OUT2%DAIRO +#ifdef W3_FLX5 + TAUAO => OUTPTS(IMOD)%OUT2%TAUAO + TAUDO => OUTPTS(IMOD)%OUT2%TAUDO + DAIRO => OUTPTS(IMOD)%OUT2%DAIRO +#endif CAO => OUTPTS(IMOD)%OUT2%CAO CDO => OUTPTS(IMOD)%OUT2%CDO ICEO => OUTPTS(IMOD)%OUT2%ICEO @@ -1590,17 +1728,21 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) GRDID => OUTPTS(IMOD)%OUT2%GRDID END IF ! -!/MPI IF ( O2IRQI ) THEN -!/MPI IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 -!/MPI IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 -!/MPI END IF +#ifdef W3_MPI + IF ( O2IRQI ) THEN + IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 + IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 + END IF +#endif ! IPASS3 => OUTPTS(IMOD)%OUT3%IPASS3 -!/MPI IT0PNT => OUTPTS(IMOD)%OUT3%IT0PNT -!/MPI IT0TRK => OUTPTS(IMOD)%OUT3%IT0TRK -!/MPI IT0PRT => OUTPTS(IMOD)%OUT3%IT0PRT -!/MPI NRQTR => OUTPTS(IMOD)%OUT3%NRQTR -!/MPI IF ( NRQTR .NE. 0 ) IRQTR => OUTPTS(IMOD)%OUT3%IRQTR +#ifdef W3_MPI + IT0PNT => OUTPTS(IMOD)%OUT3%IT0PNT + IT0TRK => OUTPTS(IMOD)%OUT3%IT0TRK + IT0PRT => OUTPTS(IMOD)%OUT3%IT0PRT + NRQTR => OUTPTS(IMOD)%OUT3%NRQTR + IF ( NRQTR .NE. 0 ) IRQTR => OUTPTS(IMOD)%OUT3%IRQTR +#endif O3INIT => OUTPTS(IMOD)%OUT3%O3INIT STOP => OUTPTS(IMOD)%OUT3%STOP ! @@ -1611,20 +1753,24 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) END IF ! IFILE4 => OUTPTS(IMOD)%OUT4%IFILE4 -!/MPI NRQRS => OUTPTS(IMOD)%OUT4%NRQRS -!/MPI NBLKRS => OUTPTS(IMOD)%OUT4%NBLKRS -!/MPI RSBLKS => OUTPTS(IMOD)%OUT4%RSBLKS -!/MPI IF ( NRQRS .NE. 0 ) THEN -!/MPI IRQRS => OUTPTS(IMOD)%OUT4%IRQRS -!/MPI END IF -!/MPI IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS -!/MPI VAAUX => OUTPTS(IMOD)%OUT4%VAAUX +#ifdef W3_MPI + NRQRS => OUTPTS(IMOD)%OUT4%NRQRS + NBLKRS => OUTPTS(IMOD)%OUT4%NBLKRS + RSBLKS => OUTPTS(IMOD)%OUT4%RSBLKS + IF ( NRQRS .NE. 0 ) THEN + IRQRS => OUTPTS(IMOD)%OUT4%IRQRS + END IF + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + VAAUX => OUTPTS(IMOD)%OUT4%VAAUX +#endif ! NBI => OUTPTS(IMOD)%OUT5%NBI NBI2 => OUTPTS(IMOD)%OUT5%NBI2 NFBPO => OUTPTS(IMOD)%OUT5%NFBPO -!/MPI NRQBP => OUTPTS(IMOD)%OUT5%NRQBP -!/MPI NRQBP2 => OUTPTS(IMOD)%OUT5%NRQBP2 +#ifdef W3_MPI + NRQBP => OUTPTS(IMOD)%OUT5%NRQBP + NRQBP2 => OUTPTS(IMOD)%OUT5%NRQBP2 +#endif NBO => OUTPTS(IMOD)%OUT5%NBO NBO2 => OUTPTS(IMOD)%OUT5%NBO2 NDSL => OUTPTS(IMOD)%OUT5%NDSL @@ -1671,8 +1817,10 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ABPOS => OUTPTS(IMOD)%OUT5%ABPOS END IF ! -!/MPI IF ( NRQBP .NE. 0 ) IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 -!/MPI IF ( NRQBP2 .NE. 0 ) IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 +#ifdef W3_MPI + IF ( NRQBP .NE. 0 ) IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 + IF ( NRQBP2 .NE. 0 ) IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 +#endif ! IPASS6 => OUTPTS(IMOD)%OUT6%IPASS6 IHMAX => OUTPTS(IMOD)%OUT6%IHMAX @@ -1704,7 +1852,9 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) ' NLOW = ',I10/ & ' NOUTP = ',I10/) ! -!/T 9000 FORMAT (' TEST W3SETO : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST W3SETO : MODEL ',I4,' SELECTED') +#endif !/ !/ End of W3SETO ----------------------------------------------------- / !/ diff --git a/model/ftn/w3ogcmmd.ftn b/model/src/w3ogcmmd.F90 similarity index 100% rename from model/ftn/w3ogcmmd.ftn rename to model/src/w3ogcmmd.F90 diff --git a/model/ftn/w3ounfmetamd.ftn b/model/src/w3ounfmetamd.F90 similarity index 98% rename from model/ftn/w3ounfmetamd.ftn rename to model/src/w3ounfmetamd.F90 index c211084ca..4ad4fa887 100644 --- a/model/ftn/w3ounfmetamd.ftn +++ b/model/src/w3ounfmetamd.F90 @@ -166,8 +166,12 @@ MODULE W3OUNFMETAMD USE NETCDF USE CONSTANTS, ONLY: TPIINV USE W3GDATMD, ONLY: SIG, NK, GTYPE, UNGTYPE -!/RTD USE W3GDATMD, ONLY : FLAGUNR, POLAT, POLON -!/SMC USE W3SMCOMD, ONLY : SMCOTYPE +#ifdef W3_RTD + USE W3GDATMD, ONLY : FLAGUNR, POLAT, POLON +#endif +#ifdef W3_SMC + USE W3SMCOMD, ONLY : SMCOTYPE +#endif USE W3ODATMD, ONLY: PTMETH, PTFCUT, NOGRP, NOGE, NGRPP, & NDSE, FNMPRE, NOSWLL USE W3SERVMD, ONLY: EXTCDE, STR_TO_UPPER @@ -280,11 +284,19 @@ SUBROUTINE INIT_META(VEC) VECTOR = .TRUE. IF(PRESENT(VEC)) VECTOR = VEC -!/RTD ! Is the grid really rotated? -!/RTD IF ( POLAT < 90. ) FLRTD = .True. -!/SMC!/RTD ! SMC type 3/4 outputs are currently on standard pole grid only -!/SMC!/RTD IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) FLRTD = .FALSE. -!/RTD ! +#ifdef W3_RTD + ! Is the grid really rotated? + IF ( POLAT < 90. ) FLRTD = .True. +#endif +#ifdef W3_SMC +#ifdef W3_RTD + ! SMC type 3/4 outputs are currently on standard pole grid only + IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) FLRTD = .FALSE. +#endif +#endif +#ifdef W3_RTD + ! +#endif ! 1. Allocate nested GROUP, FIELD structure: ALLOCATE(GROUP(NOGRP)) @@ -300,13 +312,15 @@ SUBROUTINE INIT_META(VEC) ! 2. Set direction convention: DIRCOM = "" -!/RTD IF( FLRTD ) THEN -!/RTD IF ( FLAGUNR ) THEN -!/RTD DIRCOM = 'True North' -!/RTD ELSE IF ( .NOT. FLAGUNR ) THEN -!/RTD DIRCOM = 'Rotated Pole Grid North' -!/RTD ENDIF -!/RTD ENDIF +#ifdef W3_RTD + IF( FLRTD ) THEN + IF ( FLAGUNR ) THEN + DIRCOM = 'True North' + ELSE IF ( .NOT. FLAGUNR ) THEN + DIRCOM = 'Rotated Pole Grid North' + ENDIF + ENDIF +#endif ! Set partitioning method comment and standard name templates: IF( PTMETH .LE. 3 ) THEN @@ -1373,15 +1387,17 @@ SUBROUTINE DEFAULT_CRS_META() TYPE(META_PAIR_T) :: META IF(FLRTD) THEN -!/RTD ! Rotated pole location -!/RTD CRS_NAME = 'rotated_pole' -!/RTD CALL META_LIST_APPEND(CRS_META, & -!/RTD 'grid_mapping_name', 'rotated_latitude_longitude') -!/RTD CALL META_LIST_APPEND(CRS_META, & -!/RTD 'grid_north_pole_latitude', POLAT) -!/RTD CALL META_LIST_APPEND(CRS_META, & -!/RTD 'grid_north_pole_longitude', POLON) -!/RTD CRS_IS_DEFAULT = .TRUE. +#ifdef W3_RTD + ! Rotated pole location + CRS_NAME = 'rotated_pole' + CALL META_LIST_APPEND(CRS_META, & + 'grid_mapping_name', 'rotated_latitude_longitude') + CALL META_LIST_APPEND(CRS_META, & + 'grid_north_pole_latitude', POLAT) + CALL META_LIST_APPEND(CRS_META, & + 'grid_north_pole_longitude', POLON) + CRS_IS_DEFAULT = .TRUE. +#endif ELSE IF(GTYPE .EQ. UNGTYPE) THEN ! ! What do we want for unstructure grids? ELSE @@ -2383,40 +2399,46 @@ SUBROUTINE DEFAULT_META() META(1)%VMIN = 0 META(1)%VMAX = 2 ! IFI=1, IFJ=10, D50 -!/BT4 META => GROUP(1)%FIELD(10)%META -!/BT4 META(1)%FSC = 0.001 -!/BT4 META(1)%UNITS = 'Krumbein phi scale' -!/BT4 META(1)%ENAME = '.d50' -!/BT4 META(1)%VARNM='d50' -!/BT4 META(1)%VARNL='grain_size' -!/BT4 !META(1)%VARNS='sediment_grain_size' -!/BT4 META(1)%VARNS='' -!/BT4 META(1)%VARNG='sediment_grain_size' -!/BT4 META(1)%VMIN = -10.0 -!/BT4 META(1)%VMAX = 32.0 +#ifdef W3_BT4 + META => GROUP(1)%FIELD(10)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'Krumbein phi scale' + META(1)%ENAME = '.d50' + META(1)%VARNM='d50' + META(1)%VARNL='grain_size' + !META(1)%VARNS='sediment_grain_size' + META(1)%VARNS='' + META(1)%VARNG='sediment_grain_size' + META(1)%VMIN = -10.0 + META(1)%VMAX = 32.0 +#endif ! IFI=1, IFJ=11, IC1 -!/IS2 META => GROUP(1)%FIELD(11)%META -!/IS2 META(1)%FSC = 0.001 -!/IS2 META(1)%UNITS = 'm' -!/IS2 META(1)%ENAME = '.ic1' -!/IS2 META(1)%VARNM='ic1' -!/IS2 META(1)%VARNL='ice thickness' -!/IS2 META(1)%VARNS='sea_ice_thickness' -!/IS2 META(1)%VARNG='ice_thickness' -!/IS2 META(1)%VMIN = 0 -!/IS2 META(1)%VMAX = 30 +#ifdef W3_IS2 + META => GROUP(1)%FIELD(11)%META + META(1)%FSC = 0.001 + META(1)%UNITS = 'm' + META(1)%ENAME = '.ic1' + META(1)%VARNM='ic1' + META(1)%VARNL='ice thickness' + META(1)%VARNS='sea_ice_thickness' + META(1)%VARNG='ice_thickness' + META(1)%VMIN = 0 + META(1)%VMAX = 30 +#endif ! IFI=1, IFJ=12, IC5 -!/IS2 META => GROUP(1)%FIELD(12)%META -!/IS2 META(1)%FSC = 0.05 -!/IS2 META(1)%UNITS = 'm' -!/IS2 META(1)%ENAME = '.ic5' -!/IS2 META(1)%VARNM='ic5' -!/IS2 META(1)%VARNL='maximum floe diameter' -!/IS2 !META(1)%VARNS='maximum_ice_floe_diameter' -!/IS2 META(1)%VARNS='' -!/IS2 META(1)%VARNG='maximum_ice_floe_diameter' -!/IS2 META(1)%VMIN = 0 -!/IS2 META(1)%VMAX = 1500 +#ifdef W3_IS2 + META => GROUP(1)%FIELD(12)%META + META(1)%FSC = 0.05 + META(1)%UNITS = 'm' + META(1)%ENAME = '.ic5' + META(1)%VARNM='ic5' + META(1)%VARNL='maximum floe diameter' + !META(1)%VARNS='maximum_ice_floe_diameter' + META(1)%VARNS='' + META(1)%VARNG='maximum_ice_floe_diameter' + META(1)%VMIN = 0 + META(1)%VMAX = 1500 +#endif ! !----------GROUP 2 ---------------- ! diff --git a/model/ftn/w3parall.ftn b/model/src/w3parall.F90 similarity index 77% rename from model/ftn/w3parall.ftn rename to model/src/w3parall.F90 index 3a679f67e..087195cc8 100644 --- a/model/ftn/w3parall.ftn +++ b/model/src/w3parall.F90 @@ -43,7 +43,9 @@ MODULE W3PARALL ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -51,10 +53,14 @@ MODULE W3PARALL !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/PDLIB INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM -!/PDLIB INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) +#ifdef W3_PDLIB + INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM + INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) +#endif REAL, ALLOCATABLE :: AC_tot(:,:) INTEGER, ALLOCATABLE :: ListISPnextDir(:), ListISPprevDir(:) @@ -116,7 +122,9 @@ SUBROUTINE WAV_MY_WTIME(eTime) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -125,14 +133,22 @@ SUBROUTINE WAV_MY_WTIME(eTime) !/ Local parameters !/ IMPLICIT NONE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER mpimode REAL(8), intent(out) :: eTime -!/MPI REAL(8) mpi_wtime +#ifdef W3_MPI + REAL(8) mpi_wtime +#endif mpimode=0 -!/MPI mpimode=1 -!/MPI eTime=mpi_wtime() -!/S CALL STRACE (IENT, 'WAV_MY_WTIME') +#ifdef W3_MPI + mpimode=1 + eTime=mpi_wtime() +#endif +#ifdef W3_S + CALL STRACE (IENT, 'WAV_MY_WTIME') +#endif IF (mpimode .eq. 0) THEN CALL CPU_TIME(eTime) END IF @@ -186,7 +202,9 @@ SUBROUTINE PRINT_MY_TIME(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY : IAPROC IMPLICIT NONE !/ @@ -196,13 +214,17 @@ SUBROUTINE PRINT_MY_TIME(string) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / ! character(*), intent(in) :: string REAL(8) :: eTime -!/S CALL STRACE (IENT, 'PRINT_MY_TIME') +#ifdef W3_S + CALL STRACE (IENT, 'PRINT_MY_TIME') +#endif CALL WAV_MY_WTIME(eTime) WRITE(740+IAPROC,*) 'TIMING time=', eTime, ' at step ', string !/ @@ -255,13 +277,17 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & CTMAX, DMIN, DTH, CTHG0S, MAPSF USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & DDDY, DW -!/REFRX USE W3ADATMD, ONLY: DCDX, DCDY +#ifdef W3_REFRX + USE W3ADATMD, ONLY: DCDX, DCDY +#endif USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, only : IAPROC IMPLICIT NONE @@ -272,7 +298,9 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -286,7 +314,9 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 REAL :: VCFLT(NSPEC), DEPTH, FDG REAL :: FDDMAX -!/S CALL STRACE (IENT, 'PROP_REFRACTION_PR1') +#ifdef W3_S + CALL STRACE (IENT, 'PROP_REFRACTION_PR1') +#endif IX=MAPSF(ISEA,1) IY=MAPSF(ISEA,2) eDDDX=DDDX(IY,IX) @@ -307,9 +337,11 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) DO ITH=1, NTH FDDMAX = MAX ( FDDMAX , ABS(ESIN(ITH)*eDDDX - ECOS(ITH)*eDDDY ) ) END DO -!/DEBUG WRITE(740+IAPROC,*) 'eDDDX=', eDDDX, ' Y=', eDDDY -!/DEBUG WRITE(740+IAPROC,*) 'FDDMAX=', FDDMAX -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'eDDDX=', eDDDX, ' Y=', eDDDY + WRITE(740+IAPROC,*) 'FDDMAX=', FDDMAX + FLUSH(740+IAPROC) +#endif DO IK=1, NK FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) @@ -319,27 +351,31 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) + & FRK(MAPWN(ISP)) * ( ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY ) END DO -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: FACTH=', FACTH -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: CTHG0=', eCTHG0 -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: FDG=', FDG -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: FDDMAX=', FDDMAX -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: sum(FRK)=', sum(FRK) -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: sum(FRG)=', sum(FRG) -!/DEBUG WRITE(740+IAPROC,*) 'pdlib: sum(DSDD)=', sum(DSDD) -!/DEBUG WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCFLT) -!/DEBUG FLUSH(740+IAPROC) -! -!/REFRX! 3.c @C/@x refraction and great-circle propagation -!/REFRX VCFLT = 0. -!/REFRX FRK = 0. -!/REFRX DO IK=1, NK -!/REFRX FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) -!/REFRX END DO -!/REFRX DO ISP=1, NSPEC -!/REFRX VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & -!/REFRX + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & -!/REFRX - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) -!/REFRX END DO +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'pdlib: FACTH=', FACTH + WRITE(740+IAPROC,*) 'pdlib: CTHG0=', eCTHG0 + WRITE(740+IAPROC,*) 'pdlib: FDG=', FDG + WRITE(740+IAPROC,*) 'pdlib: FDDMAX=', FDDMAX + WRITE(740+IAPROC,*) 'pdlib: sum(FRK)=', sum(FRK) + WRITE(740+IAPROC,*) 'pdlib: sum(FRG)=', sum(FRG) + WRITE(740+IAPROC,*) 'pdlib: sum(DSDD)=', sum(DSDD) + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCFLT) + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_REFRX +! 3.c @C/@x refraction and great-circle propagation + VCFLT = 0. + FRK = 0. + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO + DO ISP=1, NSPEC + VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & + - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) + END DO +#endif ! IF ( FLCUR ) THEN eDCXDX=DCXDX(IY,IX) @@ -407,7 +443,9 @@ SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & @@ -424,7 +462,9 @@ SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, intent(out) :: CAD(NSPEC) INTEGER, intent(in) :: ISEA, IP REAL, intent(in) :: DTG @@ -435,7 +475,9 @@ SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 REAL :: VCFLT(NSPEC), DEPTH, FDG REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff -!/S CALL STRACE (IENT, 'PROP_REFRACTION_PR3') +#ifdef W3_S + CALL STRACE (IENT, 'PROP_REFRACTION_PR3') +#endif IX=MAPSF(ISEA,1) IY=MAPSF(ISEA,2) IF (LPDLIB) THEN @@ -483,10 +525,12 @@ SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) VCFLT=0 END IF ! -!/REFRX! 3.c @C/@x refraction and great-circle propagation -!/REFRX DO IK=1, NK -!/REFRX FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) -!/REFRX END DO +#ifdef W3_REFRX +! 3.c @C/@x refraction and great-circle propagation + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO +#endif ! CTMAX_eff=CTMAX/DTG DO ISP=1, NSPEC @@ -557,7 +601,9 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & @@ -570,7 +616,9 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, intent(in) :: ISEA, IP REAL, intent(out) :: DMM(0:NK2) REAL, intent(in) :: DTG @@ -581,7 +629,9 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) REAL :: VELNOFILT, VELFAC, DEPTH REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0 INTEGER :: IK, ITH, ISP, IY, IX -!/S CALL STRACE (IENT, 'PROP_FREQ_SHIFT') +#ifdef W3_S + CALL STRACE (IENT, 'PROP_FREQ_SHIFT') +#endif ! IF (LPDLIB) THEN eDCXDX = DCXDX(1,IP) @@ -607,10 +657,12 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) DCYY = - eDCYDY FKD = ( eCX*eDDDX + eCY*eDDDY ) FACK = DTG -!/DEBUG WRITE(740+IAPROC,*) 'DCXX=', DCXX, ' DCXYYX=', DCXYYX -!/DEBUG WRITE(740+IAPROC,*) 'DCYY=', DCYY, ' FKD=', FKD -!/DEBUG WRITE(740+IAPROC,*) 'DTG=', DTG -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'DCXX=', DCXX, ' DCXYYX=', DCXYYX + WRITE(740+IAPROC,*) 'DCYY=', DCYY, ' FKD=', FKD + WRITE(740+IAPROC,*) 'DTG=', DTG + FLUSH(740+IAPROC) +#endif DO ITH=1, NTH FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY END DO @@ -630,8 +682,10 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) DSDD(IK) = 0. END IF END DO -!/DEBUG WRITE(740+IAPROC,*) 'DSDD(min/max)=', minval(DSDD), maxval(DSDD) -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'DSDD(min/max)=', minval(DSDD), maxval(DSDD) + FLUSH(740+IAPROC) +#endif DO IK=0, NK+1 FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) VELFAC = FACK/DB(IK+1) @@ -640,16 +694,20 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) CFLK(IK+1,ITH) = VELNOFILT/VELFAC END DO END DO -!/DEBUG WRITE(740+IAPROC,*) 'sum(CFLK)=', sum(CFLK) -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'sum(CFLK)=', sum(CFLK) + FLUSH(740+IAPROC) +#endif DO IK=1,NK DO ITH=1,NTH ISP=ITH + (IK-1)*NTH CAS(ISP)=DBLE(CFLK(IK,ITH)) END DO END DO -!/DEBUG WRITE(740+IAPROC,*) 'sum(abs(CAS))=', sum(abs(CAS)) -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'sum(abs(CAS))=', sum(abs(CAS)) + FLUSH(740+IAPROC) +#endif !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ @@ -701,7 +759,9 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & @@ -714,7 +774,9 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, intent(in) :: ISEA, IP REAL, intent(out) :: CWNB_M2(1-NTH:NSPEC) @@ -732,9 +794,13 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) INTEGER :: IK, ITH, ISP, IY, IX !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') +#ifdef W3_S + CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') +#endif -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'Now we use DCXDX array in PROP_FREQ_SHIFT_M2' +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'Now we use DCXDX array in PROP_FREQ_SHIFT_M2' +#endif IF (LPDLIB) THEN eDCXDX = DCXDX(1,IP) @@ -762,27 +828,33 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) DCYY = - FACK * eDCYDY FKD = FACK * ( eCX*eDDDX + eCY*eDDDY ) -!/DEBUGDCXDX sumDiff0=0 -!/DEBUGDCXDX sumDiff1=0 -!/DEBUGDCXDX sumDiff2=0 -!/DEBUGDCXDX sumDiff3=0 -!/DEBUGDCXDX sumDiff4=0 -!/DEBUGDCXDX sumDiff5=0 +#ifdef W3_DEBUGDCXDX + sumDiff0=0 + sumDiff1=0 + sumDiff2=0 + sumDiff3=0 + sumDiff4=0 + sumDiff5=0 +#endif DO ITH=1, NTH FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY -!/DEBUGDCXDX sumDiff0 = sumDiff0 + MIN(EC2(ITH), ZERO) -!/DEBUGDCXDX sumDiff1 = sumDiff1 + MIN(DCXX, ZERO) -!/DEBUGDCXDX sumDiff2 = sumDiff2 + MIN(ESC(ITH), ZERO) -!/DEBUGDCXDX sumDiff3 = sumDiff3 + MIN(DCXYYX, ZERO) -!/DEBUGDCXDX sumDiff4 = sumDiff4 + MIN(ES2(ITH), ZERO) -!/DEBUGDCXDX sumDiff5 = sumDiff5 + MIN(DCYY, ZERO) +#ifdef W3_DEBUGDCXDX + sumDiff0 = sumDiff0 + MIN(EC2(ITH), ZERO) + sumDiff1 = sumDiff1 + MIN(DCXX, ZERO) + sumDiff2 = sumDiff2 + MIN(ESC(ITH), ZERO) + sumDiff3 = sumDiff3 + MIN(DCXYYX, ZERO) + sumDiff4 = sumDiff4 + MIN(ES2(ITH), ZERO) + sumDiff5 = sumDiff5 + MIN(DCYY, ZERO) +#endif END DO -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff0=', sumDiff0 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff4=', sumDiff4 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff5=', sumDiff5 +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'sumDiff0=', sumDiff0 + WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 + WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 + WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 + WRITE(740+IAPROC,*) 'sumDiff4=', sumDiff4 + WRITE(740+IAPROC,*) 'sumDiff5=', sumDiff5 +#endif ! DEPTH = MAX ( DMIN , DW(ISEA) ) DO IK=0, NK+1 @@ -793,32 +865,40 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) END IF END DO ISP = -NTH -!/DEBUGDCXDX sumDiff=0 -!/DEBUGDCXDX sumDiff1=0 -!/DEBUGDCXDX sumDiff2=0 -!/DEBUGDCXDX sumDiff3=0 +#ifdef W3_DEBUGDCXDX + sumDiff=0 + sumDiff1=0 + sumDiff2=0 + sumDiff3=0 +#endif DO IK=0, NK+1 FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) DO ITH=1, NTH ISP = ISP + 1 VCWN(ISP) = FKD0 + WN(IK,ISEA)*FKC(ITH) -!/DEBUGDCXDX sumDiff = sumDiff + MAX(VCWN(ISP),ZERO) -!/DEBUGDCXDX sumDiff1 = sumDiff1 + MAX(FKD0,ZERO) -!/DEBUGDCXDX sumDiff2 = sumDiff2 + MAX(WN(IK,ISEA),ZERO) -!/DEBUGDCXDX sumDiff3 = sumDiff3 + MAX(FKC(ITH),ZERO) +#ifdef W3_DEBUGDCXDX + sumDiff = sumDiff + MAX(VCWN(ISP),ZERO) + sumDiff1 = sumDiff1 + MAX(FKD0,ZERO) + sumDiff2 = sumDiff2 + MAX(WN(IK,ISEA),ZERO) + sumDiff3 = sumDiff3 + MAX(FKC(ITH),ZERO) +#endif END DO END DO -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff=', sumDiff -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'sumDiff=', sumDiff + WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 + WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 + WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 +#endif sumDiff=0 DO ISP=1-NTH,NSPEC CWNB_M2(ISP) = DBLE(0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) )) sumDiff = sumDiff + MAX(CWNB_M2(ISP), ZERO) END DO -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'sumDiff=', sumDiff +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'sumDiff=', sumDiff +#endif DO IK=1,NK DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) END DO @@ -875,53 +955,67 @@ SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE -!/PDLIB USE yowDatapool, only: istatus -!/PDLIB USE yowNodepool, only: np_global -!/PDLIB USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC -!/PDLIB USE W3GDATMD, ONLY: MAPSF, NSEA -!/PDLIB USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP -!/PDLIB USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot -!/PDLIB USE WMMDATMD, ONLY: MDATAS +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_PDLIB + USE yowDatapool, only: istatus + USE yowNodepool, only: np_global + USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC + USE W3GDATMD, ONLY: MAPSF, NSEA + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot + USE WMMDATMD, ONLY: MDATAS +#endif IMPLICIT NONE -!/PDLIB INCLUDE "mpif.h" +#ifdef W3_PDLIB + INCLUDE "mpif.h" +#endif INTEGER, intent(in) :: IMOD logical, intent(in) :: IsMulti -!/S INTEGER, SAVE :: IENT = 0 -!/PDLIB INTEGER :: Iarr(1) -!/PDLIB INTEGER :: ISEA, IP_glob -!/PDLIB INTEGER :: IPROC, IERR_MPI, istat +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_PDLIB + INTEGER :: Iarr(1) + INTEGER :: ISEA, IP_glob + INTEGER :: IPROC, IERR_MPI, istat +#endif -!/S CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') +#ifdef W3_S + CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') +#endif -!/PDLIB IF (IAPROC .le. NAPROC) THEN -!/PDLIB IF (IAPROC .eq. 1) THEN -!/PDLIB Iarr(1)=np_global -!/PDLIB DO IPROC=NAPROC+1,NTPROC -!/PDLIB CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) -!/PDLIB END DO -!/PDLIB DO IPROC=NAPROC+1,NTPROC -!/PDLIB CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) -!/PDLIB CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) -!/PDLIB END DO -!/PDLIB END IF -!/PDLIB ELSE -!/PDLIB CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) -!/PDLIB np_global=Iarr(1) -!/PDLIB allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) -!/PDLIB CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) -!/PDLIB CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) -!/PDLIB END IF -!/PDLIB IF (IsMulti) THEN -!/PDLIB WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA -!/PDLIB ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) -!/PDLIB !CHECK_ALLOC_STATUS ( ISTAT ) -!/PDLIB DO ISEA=1,NSEA -!/PDLIB IP_glob = MAPSF(ISEA, 1) -!/PDLIB MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) -!/PDLIB MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) -!/PDLIB END DO -!/PDLIB END IF +#ifdef W3_PDLIB + IF (IAPROC .le. NAPROC) THEN + IF (IAPROC .eq. 1) THEN + Iarr(1)=np_global + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) + END DO + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) + CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) + END DO + END IF + ELSE + CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) + np_global=Iarr(1) + allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) + CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) + CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) + END IF + IF (IsMulti) THEN + WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA + ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) + !CHECK_ALLOC_STATUS ( ISTAT ) + DO ISEA=1,NSEA + IP_glob = MAPSF(ISEA, 1) + MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) + MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) + END DO + END IF +#endif !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ @@ -972,14 +1066,20 @@ SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / -!/PDLIB use yowDatapool, only: istatus -!/PDLIB use yowNodepool, only: npa -!/PDLIB use yowRankModule, only : rank -!/PDLIB USE W3GDATMD, ONLY: GTYPE, UNGTYPE -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP +#ifdef W3_PDLIB + use yowDatapool, only: istatus + use yowNodepool, only: npa + use yowRankModule, only : rank + USE W3GDATMD, ONLY: GTYPE, UNGTYPE +#endif +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP +#endif USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: NSEA USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC @@ -987,40 +1087,54 @@ SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) INTEGER, intent(out) :: NSEALout, NSEALMout !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') +#ifdef W3_S + CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') +#endif !!/PDLIB WRITE(*,*) 'LPDLIB=', LPDLIB !!/PDLIB WRITE(*,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE -!/DEBUG WRITE(740+IAPROC,*) 'SET_UP, PDLIB=', LPDLIB -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'SET_UP, PDLIB=', LPDLIB + FLUSH(740+IAPROC) +#endif -!/SHRD NSEALout = NSEA -!/SHRD NSEALMout = NSEA -! -!/DIST IF (.NOT. LPDLIB ) THEN -!/DIST IF ( IAPROC .LE. NAPROC ) THEN -!/DIST NSEALout = 1 + (NSEA-IAPROC)/NAPROC -!/DIST ELSE -!/DIST NSEALout = 0 -!/DIST END IF -!/DIST NSEALMout = 1 + (NSEA-1)/NAPROC -!/DIST ELSE -!/PDLIB IF (GTYPE .eq. UNGTYPE) THEN -!/PDLIB NSEALout = PDLIB_NSEAL -!/PDLIB NSEALMout = PDLIB_NSEALM -!/PDLIB WRITE(*,*) 'PDLIB_NSEAL=', PDLIB_NSEAL, ' PDLIB_NSEALM=', PDLIB_NSEALM -!/PDLIB ELSE -!/PDLIB IF ( IAPROC .LE. NAPROC ) THEN -!/PDLIB NSEALout = 1 + (NSEA-IAPROC)/NAPROC -!/PDLIB ELSE -!/PDLIB NSEALout = 0 -!/PDLIB END IF -!/PDLIB NSEALMout = 1 + (NSEA-1)/NAPROC -!/PDLIB ENDIF -!/DIST ENDIF +#ifdef W3_SHRD + NSEALout = NSEA + NSEALMout = NSEA +#endif +! +#ifdef W3_DIST + IF (.NOT. LPDLIB ) THEN + IF ( IAPROC .LE. NAPROC ) THEN + NSEALout = 1 + (NSEA-IAPROC)/NAPROC + ELSE + NSEALout = 0 + END IF + NSEALMout = 1 + (NSEA-1)/NAPROC + ELSE +#endif +#ifdef W3_PDLIB + IF (GTYPE .eq. UNGTYPE) THEN + NSEALout = PDLIB_NSEAL + NSEALMout = PDLIB_NSEALM + WRITE(*,*) 'PDLIB_NSEAL=', PDLIB_NSEAL, ' PDLIB_NSEALM=', PDLIB_NSEALM + ELSE + IF ( IAPROC .LE. NAPROC ) THEN + NSEALout = 1 + (NSEA-IAPROC)/NAPROC + ELSE + NSEALout = 0 + END IF + NSEALMout = 1 + (NSEA-1)/NAPROC + ENDIF +#endif +#ifdef W3_DIST + ENDIF +#endif !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ @@ -1072,13 +1186,17 @@ SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF USE CONSTANTS, ONLY : LPDLIB -!/PDLIB USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot -!/PDLIB use yowNodepool, only: ipgl, iplg +#ifdef W3_PDLIB + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot + use yowNodepool, only: ipgl, iplg +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1086,13 +1204,17 @@ SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / INTEGER, intent(in) :: ISEA INTEGER, intent(out) :: JSEA, ISPROC INTEGER IP_glob -!/S CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') +#ifdef W3_S + CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') +#endif !!/DEBUG WRITE(740+IAPROC,*) 'PDLIB=', PDLIB !!/DEBUG WRITE(740+IAPROC,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE !!/DEBUG FLUSH(740+IAPROC) @@ -1100,18 +1222,20 @@ SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) JSEA = 1 + (ISEA-1)/NAPROC ISPROC = ISEA - (JSEA-1)*NAPROC ELSE -!/PDLIB IF (GTYPE .ne. UNGTYPE) THEN -!/PDLIB JSEA = 1 + (ISEA-1)/NAPROC -!/PDLIB ISPROC = ISEA - (JSEA-1)*NAPROC -!/PDLIB ELSE -!/PDLIB IP_glob = MAPSF(ISEA,1) -!/PDLIB IF (IAPROC .le. NAPROC) THEN -!/PDLIB JSEA = ISEA_TO_JSEA(ISEA) -!/PDLIB ELSE -!/PDLIB JSEA = -1 -!/PDLIB END IF -!/PDLIB ISPROC = IPGL_TO_PROC(IP_glob) -!/PDLIB ENDIF +#ifdef W3_PDLIB + IF (GTYPE .ne. UNGTYPE) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + ELSE + IP_glob = MAPSF(ISEA,1) + IF (IAPROC .le. NAPROC) THEN + JSEA = ISEA_TO_JSEA(ISEA) + ELSE + JSEA = -1 + END IF + ISPROC = IPGL_TO_PROC(IP_glob) + ENDIF +#endif ENDIF !/ !/ End of JACOBI_INIT ------------------------------------------------ / @@ -1164,13 +1288,17 @@ SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF USE CONSTANTS, ONLY : LPDLIB -!/PDLIB USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot, IPGL_npa -!/PDLIB use yowNodepool, only: ipgl, iplg +#ifdef W3_PDLIB + USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot, IPGL_npa + use yowNodepool, only: ipgl, iplg +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1178,14 +1306,18 @@ SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER, intent(in) :: ISEA INTEGER, intent(out) :: JSEA, IBELONG INTEGER ISPROC, IX, JX -!/S CALL STRACE (IENT, 'GET_JSEA_IBELONG') +#ifdef W3_S + CALL STRACE (IENT, 'GET_JSEA_IBELONG') +#endif IF (.NOT. LPDLIB) THEN JSEA = 1 + (ISEA-1)/NAPROC ISPROC = ISEA - (JSEA-1)*NAPROC @@ -1195,30 +1327,32 @@ SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) IBELONG=0 END IF ELSE -!/PDLIB IF (GTYPE .ne. UNGTYPE) THEN -!/PDLIB JSEA = 1 + (ISEA-1)/NAPROC -!/PDLIB ISPROC = ISEA - (JSEA-1)*NAPROC -!/PDLIB IF (ISPROC .eq. IAPROC) THEN -!/PDLIB IBELONG=1 -!/PDLIB ELSE -!/PDLIB IBELONG=0 -!/PDLIB END IF -!/PDLIB ELSE -!/PDLIB IF (IAPROC .le. NAPROC) THEN -!/PDLIB IX = MAPSF(ISEA,1) -!/PDLIB JX = IPGL_npa(IX) -!/PDLIB IF (JX .eq. 0) THEN -!/PDLIB IBELONG=0 -!/PDLIB JSEA=-1 -!/PDLIB ELSE -!/PDLIB IBELONG=1 -!/PDLIB JSEA=JX_TO_JSEA(JX) -!/PDLIB END IF -!/PDLIB ELSE -!/PDLIB IBELONG=0 -!/PDLIB JSEA=-1 -!/PDLIB END IF -!/PDLIB ENDIF +#ifdef W3_PDLIB + IF (GTYPE .ne. UNGTYPE) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + IF (ISPROC .eq. IAPROC) THEN + IBELONG=1 + ELSE + IBELONG=0 + END IF + ELSE + IF (IAPROC .le. NAPROC) THEN + IX = MAPSF(ISEA,1) + JX = IPGL_npa(IX) + IF (JX .eq. 0) THEN + IBELONG=0 + JSEA=-1 + ELSE + IBELONG=1 + JSEA=JX_TO_JSEA(JX) + END IF + ELSE + IBELONG=0 + JSEA=-1 + END IF + ENDIF +#endif ENDIF !/ !/ End of INIT_GET_ISEA ---------------------------------------------- / @@ -1271,12 +1405,16 @@ SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC USE W3GDATMD, ONLY: GTYPE, UNGTYPE USE CONSTANTS, ONLY : LPDLIB -!/PDLIB USE YOWNODEPOOL, ONLY: iplg +#ifdef W3_PDLIB + USE YOWNODEPOOL, ONLY: iplg +#endif !/ ------------------------------------------------------------------- / !/ Parameter list !/ @@ -1293,22 +1431,36 @@ SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC USE W3GDATMD, ONLY: GTYPE, UNGTYPE USE CONSTANTS, ONLY : LPDLIB -!/PDLIB USE YOWNODEPOOL, ONLY: iplg +#ifdef W3_PDLIB + USE YOWNODEPOOL, ONLY: iplg +#endif IMPLICIT NONE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, intent(in) :: JSEA INTEGER, intent(out) :: ISEA -!/S CALL STRACE (IENT, 'INIT_GET_ISEA') -!/SHRD ISEA = JSEA -!/DIST IF (.NOT. LPDLIB) THEN -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/DIST ELSE -!/PDLIB IF (GTYPE .eq. UNGTYPE) THEN -!/PDLIB ISEA = iplg(JSEA) -!/PDLIB ELSE -!/PDLIB ISEA = IAPROC + (JSEA-1)*NAPROC -!/PDLIB ENDIF -!/DIST ENDIF +#ifdef W3_S + CALL STRACE (IENT, 'INIT_GET_ISEA') +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif +#ifdef W3_DIST + IF (.NOT. LPDLIB) THEN + ISEA = IAPROC + (JSEA-1)*NAPROC + ELSE +#endif +#ifdef W3_PDLIB + IF (GTYPE .eq. UNGTYPE) THEN + ISEA = iplg(JSEA) + ELSE + ISEA = IAPROC + (JSEA-1)*NAPROC + ENDIF +#endif +#ifdef W3_DIST + ENDIF +#endif !/ !/ End of INIT_GET_ISEA ------------------------------------------------ / !/ @@ -1365,14 +1517,18 @@ SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NSEAL, NSEA, NX -!/PDLIB USE W3ODATMD, only : IAPROC, NAPROC, NTPROC -!/PDLIB USE W3ADATMD, ONLY: MPI_COMM_WCMP -!/PDLIB use yowDatapool, only: rtype, istatus -!/PDLIB USE yowNodepool, only: npa -!/PDLIB use yowNodepool, only: iplg +#ifdef W3_PDLIB + USE W3ODATMD, only : IAPROC, NAPROC, NTPROC + USE W3ADATMD, ONLY: MPI_COMM_WCMP + use yowDatapool, only: rtype, istatus + USE yowNodepool, only: npa + use yowNodepool, only: iplg +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1380,40 +1536,48 @@ SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif INTEGER ISEA, JSEA, Status(NX), rStatus(NX) INTEGER IPROC, I, ierr, IP, IX, IP_glob REAL*8, intent(inout) :: TheVar(NX) REAL*8 rVect(NX) Status=0 -!/S CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') -!/PDLIB DO IP=1,npa -!/PDLIB IP_glob=iplg(IP) -!/PDLIB Status(IP_glob)=1 -!/PDLIB END DO -!/PDLIB IF (IAPROC .eq. 1) THEN -!/PDLIB DO iProc=2,NAPROC -!/PDLIB CALL MPI_RECV(rVect,NX,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) -!/PDLIB CALL MPI_RECV(rStatus,NX,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) -!/PDLIB DO I=1,NX -!/PDLIB IF (rStatus(I) .eq. 1) THEN -!/PDLIB TheVar(I)=rVect(I) -!/PDLIB Status(I)=1 -!/PDLIB END IF -!/PDLIB END DO -!/PDLIB END DO -!/PDLIB DO IPROC=2,NAPROC -!/PDLIB CALL MPI_SEND(TheVar,NX,rtype, iProc-1, 29, MPI_COMM_WCMP, ierr) -!/PDLIB END DO -!/PDLIB ELSE -!/PDLIB CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) -!/PDLIB CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) -!/PDLIB CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) -!/PDLIB END IF +#ifdef W3_S + CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') +#endif +#ifdef W3_PDLIB + DO IP=1,npa + IP_glob=iplg(IP) + Status(IP_glob)=1 + END DO + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC + CALL MPI_RECV(rVect,NX,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) + CALL MPI_RECV(rStatus,NX,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) + DO I=1,NX + IF (rStatus(I) .eq. 1) THEN + TheVar(I)=rVect(I) + Status(I)=1 + END IF + END DO + END DO + DO IPROC=2,NAPROC + CALL MPI_SEND(TheVar,NX,rtype, iProc-1, 29, MPI_COMM_WCMP, ierr) + END DO + ELSE + CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) + CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) + END IF +#endif !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ diff --git a/model/ftn/w3partmd.ftn b/model/src/w3partmd.F90 similarity index 98% rename from model/ftn/w3partmd.ftn rename to model/src/w3partmd.F90 index f8be477d7..ab9409daf 100644 --- a/model/ftn/w3partmd.ftn +++ b/model/src/w3partmd.F90 @@ -161,7 +161,9 @@ SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) !/ ------------------------------------------------------------------- / !/ USE CONSTANTS -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH USE W3ODATMD, ONLY: WSCUT, FLCOMB @@ -185,7 +187,9 @@ SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) IP, IT(1), INDEX(DIMXP), NWS, & IPW, IPT, ISP INTEGER :: PMAP(DIMXP) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: ZP(NSPEC), ZMIN, ZMAX, Z(NSPEC), & FACT, WSMAX, HSMAX REAL :: TP(DIMP,DIMXP) @@ -195,7 +199,9 @@ SUBROUTINE W3PART ( SPEC, UABS, UDIR, DEPTH, WN, NP, XP, DIMXP ) !/ ------------------------------------------------------------------- / ! 0. Initializations ! -!/S CALL STRACE (IENT, 'W3PART') +#ifdef W3_S + CALL STRACE (IENT, 'W3PART') +#endif ! NP = 0 XP = 0. @@ -467,7 +473,9 @@ SUBROUTINE PTSORT ( IMI, IND, IHMAX ) ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NSPEC ! @@ -483,11 +491,15 @@ SUBROUTINE PTSORT ( IMI, IND, IHMAX ) !/ Local parameters !/ INTEGER :: I, IN, IV -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: NUMV(IHMAX), IADDR(IHMAX), & IORDER(NSPEC) !/ -!/S CALL STRACE (IENT, 'PTSORT') +#ifdef W3_S + CALL STRACE (IENT, 'PTSORT') +#endif ! ! -------------------------------------------------------------------- / ! 1. Occurences per height @@ -566,7 +578,9 @@ SUBROUTINE PTNGHB ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NTH, NSPEC ! @@ -582,9 +596,13 @@ SUBROUTINE PTNGHB !/ Local parameters !/ INTEGER :: N, J, I, K -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'PTNGHB') +#ifdef W3_S + CALL STRACE (IENT, 'PTNGHB') +#endif ! ! -------------------------------------------------------------------- / ! 1. Check on need of processing @@ -756,7 +774,9 @@ SUBROUTINE PT_FLD ( IMI, IND, IMO, ZP, NPART ) ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NSPEC ! @@ -777,10 +797,14 @@ SUBROUTINE PT_FLD ( IMI, IND, IMO, ZP, NPART ) IP, I, IPP, IC_DIST, IEMPTY, IPPP, & JL, JN, IPT, J INTEGER :: IQ(NSPEC), IQ_START, IQ_END -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: ZPMAX, EP1, DIFF !/ -!/S CALL STRACE (IENT, 'PT_FLD') +#ifdef W3_S + CALL STRACE (IENT, 'PT_FLD') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -1069,7 +1093,9 @@ SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & !/ ------------------------------------------------------------------- / ! USE CONSTANTS -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3DISPMD, ONLY: WAVNU1 ! USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DSII, DSIP, & @@ -1090,7 +1116,9 @@ SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & !/ Local parameters !/ INTEGER :: IK, ITH, ISP, IP, IFPMAX(0:NPI) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SUMF(0:NK+1,0:NPI), SUMFW(NK,0:NPI), & SUMFX(NK,0:NPI), SUMFY(NK,0:NPI), & SUME(0:NPI), SUMEW(0:NPI), & @@ -1104,7 +1132,9 @@ SUBROUTINE PTMEAN ( NPI, IMO, ZP, DEPTH, UABS, UDIR, WN, & SUMY, SUMXXY, SUMXYLOGY, SUMEXP, SUMEYP REAL :: FTEII !/ -!/S CALL STRACE (IENT, 'PTMEAN') +#ifdef W3_S + CALL STRACE (IENT, 'PTMEAN') +#endif ! ! -------------------------------------------------------------------- / ! 1. Check on need of processing diff --git a/model/ftn/w3pro1md.ftn b/model/src/w3pro1md.F90 similarity index 85% rename from model/ftn/w3pro1md.ftn rename to model/src/w3pro1md.F90 index 2039bfd4f..aac0a7fb4 100644 --- a/model/ftn/w3pro1md.ftn +++ b/model/src/w3pro1md.F90 @@ -143,7 +143,9 @@ SUBROUTINE W3MAP1 ( MAPSTA ) USE W3ADATMD, ONLY: IS0, IS2, FACVX, FACVY USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -156,11 +158,15 @@ SUBROUTINE W3MAP1 ( MAPSTA ) !/ Local parameters !/ INTEGER :: IX, IY, IXY, ISP, IXNEXT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3MAP1') +#ifdef W3_S + CALL STRACE (IENT, 'W3MAP1') +#endif ! ! 1. Initialize x-y arrays ------------------------------------------ * @@ -391,7 +397,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) USE W3ODATMD, ONLY: NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, & BBPI0, BBPIN, NDSE, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -408,13 +416,19 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) INTEGER :: IK, ITH, NTLOC, ITLOC, ISEA, IXY, & IY0, IX, IY, JXN, JXP, JYN, JYP, & IBI, NYMAX -!/T3 INTEGER :: IXF, IYF -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_T3 + INTEGER :: IXF, IYF +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CG0, CGL, CGA, CC, CGN REAL :: DTLOC,DTRAD, VCB REAL :: RD1, RD2 REAL :: CP, CQ -!/T3 REAL :: AOLD +#ifdef W3_T3 + REAL :: AOLD +#endif !/ !/ Automatic work arrays !/ @@ -429,7 +443,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XYP1') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYP1') +#endif ! ! 1. Preparations --------------------------------------------------- * @@ -445,12 +461,16 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA))**2 & +(CGL*ESIN(ITH)+CY(1:NSEA))**2)) CC = SQRT(MAXVAL(CX(1:NSEA)**2+CY(1:NSEA)**2)) -!/MGP CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA)-VGX)**2 & -!/MGP +(CGL*ESIN(ITH)+CY(1:NSEA)-VGY)**2)) -!/MGP CC = SQRT(MAXVAL((CX(1:NSEA)-VGX)**2+(CY(1:NSEA)-VGY)**2)) +#ifdef W3_MGP + CGA = SQRT(MAXVAL((CGL*ECOS(ITH)+CX(1:NSEA)-VGX)**2 & + +(CGL*ESIN(ITH)+CY(1:NSEA)-VGY)**2)) + CC = SQRT(MAXVAL((CX(1:NSEA)-VGX)**2+(CY(1:NSEA)-VGY)**2)) +#endif ELSE CGA = CGL -!/MGP CGA = SQRT((CGL*ECOS(ITH)-VGX)**2+(CGL*ESIN(ITH)-VGY)**2) +#ifdef W3_MGP + CGA = SQRT((CGL*ECOS(ITH)-VGX)**2+(CGL*ESIN(ITH)-VGY)**2) +#endif CC = 0. END IF ! @@ -462,8 +482,10 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) IF ( FLAGLL ) DTRAD=DTRAD/(DERA*RADIUS) ! -!/T WRITE (NDST,9000) NTLOC -!/T WRITE (NDST,9001) ISP, ITH, IK +#ifdef W3_T + WRITE (NDST,9000) NTLOC + WRITE (NDST,9001) ISP, ITH, IK +#endif ! ! ====================== Loop partial ================================ * ! @@ -471,7 +493,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) ! ! 1.b Initialize arrays ! -!/T1 WRITE (NDST,9010) ITLOC +#ifdef W3_T1 + WRITE (NDST,9010) ITLOC +#endif ! VCX2D = 0. VCY2D = 0. @@ -487,9 +511,13 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) ! VCX = COS*CG / CLATS ! VCY = SIN*CG ! -!/T1 WRITE (NDST,9020) +#ifdef W3_T1 + WRITE (NDST,9020) +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY, IX, IY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY, IX, IY) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -500,14 +528,20 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) CXTOT2D(IY,IX) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) CYTOT2D(IY,IX) = ESIN(ITH) * CG(IK,ISEA) -!/MGP CXTOT2D(IY,IX) = CXTOT2D(IY,IX) - VGX/CLATS(ISEA) -!/MGP CYTOT2D(IY,IX) = CYTOT2D(IY,IX) - VGY +#ifdef W3_MGP + CXTOT2D(IY,IX) = CXTOT2D(IY,IX) - VGX/CLATS(ISEA) + CYTOT2D(IY,IX) = CYTOT2D(IY,IX) - VGY +#endif -!/T1 WRITE (NDST,9021) ISEA, IXY, FLD2D(IY,IX), & -!/T1 CXTOT2D(IY,IX), CYTOT2D(IY,IX) +#ifdef W3_T1 + WRITE (NDST,9021) ISEA, IXY, FLD2D(IY,IX), & + CXTOT2D(IY,IX), CYTOT2D(IY,IX) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! IF ( FLCUR ) THEN DO ISEA=1, NSEA @@ -552,11 +586,15 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) ! Deal with longitude closure by duplicating one row *to the right* ! in FIELD/FLD2D, VCX IF ( ICLOSE.NE.ICLOSE_NONE ) THEN -!/T1 WRITE (NDST,9024) +#ifdef W3_T1 + WRITE (NDST,9024) +#endif DO IY=1, NY FLD2D(IY,NX+1)=FLD2D(IY,1) VCX2D(IY,NX+1)=VCX2D(IY,1) -!/T1 WRITE (NDST,9025) IY, FLD2D(IY,NX+1), VCX2D(IY,NX+1) +#ifdef W3_T1 + WRITE (NDST,9025) IY, FLD2D(IY,NX+1), VCX2D(IY,NX+1) +#endif END DO END IF @@ -576,7 +614,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) NYMAX=NY-1 IF ( ICLOSE.EQ.ICLOSE_TRPL ) NYMAX=NY ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) +#endif ! DO IX=1, NX DO IY=1, NYMAX @@ -587,21 +627,29 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) END DO END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! Deal with longitude closure by duplicating one row *to the left* ! in VFLX. Note that a similar action is not take for tripole grid, ! since tripole seam is only: IY=NY communicating with other points ! at IY=NY, not a case of IY=NY communicating with IY=1 IF ( ICLOSE.NE.ICLOSE_NONE ) THEN -!/T2 WRITE (NDST,9032) +#ifdef W3_T2 + WRITE (NDST,9032) +#endif DO IY=1, NY VFLX2D(IY,0) = VFLX2D(IY,NX) -!/T2 WRITE (NDST,9033) IY, VFLX2D(IY,0) +#ifdef W3_T2 + WRITE (NDST,9033) IY, VFLX2D(IY,0) +#endif END DO END IF ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IX, IY, IXY, VCB) +#endif ! DO IX=1, NX DO IY=1, NY-1 @@ -612,7 +660,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) END DO END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! For tripole grid, include IY=NY in calculation. VCB is handled @@ -620,7 +670,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) IF ( ICLOSE.EQ.ICLOSE_TRPL ) THEN IY=NY ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IXY, VCB, IX) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IXY, VCB, IX) +#endif ! DO IX=1, NX IXY = IY +(IX-1)*NY @@ -629,15 +681,21 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) + MIN ( VCB , 0. ) * FLD2D(IY+1,IX) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! 4. Propagate ------------------------------------------------------ * ! -!/T3 WRITE (NDST,9040) +#ifdef W3_T3 + WRITE (NDST,9040) +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY, JXN, JXP, JYN, JYP, IX, IY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY, JXN, JXP, JYN, JYP, IX, IY) +#endif ! DO ISEA=1, NSEA ! @@ -645,7 +703,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) IY = MAPSF(ISEA,2) IXY = MAPSF(ISEA,3) -!/T3 AOLD = FLD2D(IY,IX) * CG(IK,ISEA) / CLATS(ISEA) +#ifdef W3_T3 + AOLD = FLD2D(IY,IX) * CG(IK,ISEA) / CLATS(ISEA) +#endif ! IF (MAPSTA(IXY).EQ.1) THEN ! @@ -676,13 +736,17 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) + ATRNY(IXY,JYN) * VFLY2D(IY-1,IX) & - ATRNY(IXY,JYP) * VFLY2D(IY,IX) -!/T3 WRITE (NDST,9041) ISEA, IXY, IXY-NY, IXY-1, & -!/T3 VFLX2D(IY,IX-1), VFLX2D(IY,IX), VFLY2D(IY-1,IX), & -!/T3 VFLY2D(IY,IX) , CG(IK,ISEA)/CLATS(ISEA),AOLD, & -!/T3 FLD2D(IY,IX) +#ifdef W3_T3 + WRITE (NDST,9041) ISEA, IXY, IXY-NY, IXY-1, & + VFLX2D(IY,IX-1), VFLX2D(IY,IX), VFLY2D(IY-1,IX), & + VFLY2D(IY,IX) , CG(IK,ISEA)/CLATS(ISEA),AOLD, & + FLD2D(IY,IX) +#endif ! ! -!/T3 WRITE (NDST,9042) ISEA, MAPSTA(IXY), AOLD,FLD2D(IY,IX) +#ifdef W3_T3 + WRITE (NDST,9042) ISEA, MAPSTA(IXY), AOLD,FLD2D(IY,IX) +#endif ! END IF ! IF (MAPSTA(IXY).EQ.1) THEN @@ -690,7 +754,9 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) END DO ! DO ISEA=1, NSEA ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! Transform FIELD back to physical space, i.e. may be curvilinear @@ -733,23 +799,33 @@ SUBROUTINE W3XYP1 ( ISP, DTG, MAPSTA, FIELD, VGX, VGY ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3XYP1 : NTLOC :',I4) -!/T 9001 FORMAT (' TEST W3XYP1 : ISP, ITH, IK :',I8,2I4) -! -!/T1 9010 FORMAT (' TEST W3XYP1 : INIT. VFX-YL, ITLOC =',I3) -! -!/T1 9020 FORMAT (' TEST W3XYP1 : ISEA, IXY, FIELD, VCX, VCY') -!/T1 9021 FORMAT (' ',2I8,3E12.4) -!/T1 9024 FORMAT (' TEST W3XYP1 : GLOBAL CLOSURE: IY, FIELD, VCX ') -!/T1 9025 FORMAT (' ',I4,2E12.4) -! -!/T2 9032 FORMAT (' TEST W3XYP1 : CLOSE. : IY, VFLX') -!/T2 9033 FORMAT (' ',I4,E12.4) -! -!/T3 9040 FORMAT (' TEST W3XYP1 : PROPAGATION '/ & -!/T3 ' ISEA, IXY(3), , FLX(2), FLY(2), FAC, A(2)') -!/T3 9041 FORMAT (2X,4I5,1X,4E10.3,1X,E10.3,1X,2E10.3) -!/T3 9042 FORMAT (2X,I5,'( MAP = ',I2,' )',56X,2E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3XYP1 : NTLOC :',I4) + 9001 FORMAT (' TEST W3XYP1 : ISP, ITH, IK :',I8,2I4) +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3XYP1 : INIT. VFX-YL, ITLOC =',I3) +#endif +! +#ifdef W3_T1 + 9020 FORMAT (' TEST W3XYP1 : ISEA, IXY, FIELD, VCX, VCY') + 9021 FORMAT (' ',2I8,3E12.4) + 9024 FORMAT (' TEST W3XYP1 : GLOBAL CLOSURE: IY, FIELD, VCX ') + 9025 FORMAT (' ',I4,2E12.4) +#endif +! +#ifdef W3_T2 + 9032 FORMAT (' TEST W3XYP1 : CLOSE. : IY, VFLX') + 9033 FORMAT (' ',I4,E12.4) +#endif +! +#ifdef W3_T3 + 9040 FORMAT (' TEST W3XYP1 : PROPAGATION '/ & + ' ISEA, IXY(3), , FLX(2), FLY(2), FAC, A(2)') + 9041 FORMAT (2X,4I5,1X,4E10.3,1X,E10.3,1X,2E10.3) + 9042 FORMAT (2X,I5,'( MAP = ',I2,' )',56X,2E10.3) +#endif !/ !/ End of W3XYP1 ----------------------------------------------------- / !/ @@ -858,8 +934,12 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & USE W3ADATMD, ONLY: IS0, IS2 USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, ONLY: NDST -!/DEBUG USE W3ODATMD, only : IAPROC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_DEBUG + USE W3ODATMD, only : IAPROC +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -877,7 +957,9 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ Local parameters !/ INTEGER :: ITH, IK, ISP, ITH0 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FDDMAX, FDG, DCYX, DCXXYY, DCXY, & DCXX, DCXYYX, DCYY, FKD, FKD0, CTHB, & CWNB @@ -888,11 +970,15 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3KTP1') +#ifdef W3_S + CALL STRACE (IENT, 'W3KTP1') +#endif ! -!/T WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX -!/T WRITE (NDST,9001) ISEA, DEPTH, CX, CY, & -!/T DDDX, DDDY, DCXDX, DCXDY, DCYDX, DCYDY +#ifdef W3_T + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9001) ISEA, DEPTH, CX, CY, & + DDDX, DDDY, DCXDX, DCXDY, DCYDX, DCYDY +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Array with partial derivative of sigma versus depth @@ -906,11 +992,13 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & END IF END DO ! -!/T WRITE (NDST,9010) -!/T DO IK=1, NK+1 -!/T WRITE (NDST,9011) IK, TPI/SIG(IK), TPI/WN(IK), & -!/T CG(IK), DSDD(IK) -!/T END DO +#ifdef W3_T + WRITE (NDST,9010) + DO IK=1, NK+1 + WRITE (NDST,9011) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO +#endif ! ! 1.b Extract spectrum ! @@ -944,37 +1032,45 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) END DO -!/DEBUG WRITE(740+IAPROC,*) 'pro1 FACTH=', FACTH -!/DEBUG WRITE(740+IAPROC,*) 'pro1 CTHG0=', CTHG0 -!/DEBUG WRITE(740+IAPROC,*) 'pro1 FDG=', FDG -!/DEBUG WRITE(740+IAPROC,*) 'pro1 FDDMAX=', FDDMAX -!/DEBUG WRITE(740+IAPROC,*) 'pro1 sum(FRK)=', sum(FRK) -!/DEBUG WRITE(740+IAPROC,*) 'pro1 sum(FRG)=', sum(FRG) -!/DEBUG WRITE(740+IAPROC,*) 'pro1 sum(DSDD)=', sum(DSDD) -!/DEBUG WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCTH) -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE(740+IAPROC,*) 'pro1 FACTH=', FACTH + WRITE(740+IAPROC,*) 'pro1 CTHG0=', CTHG0 + WRITE(740+IAPROC,*) 'pro1 FDG=', FDG + WRITE(740+IAPROC,*) 'pro1 FDDMAX=', FDDMAX + WRITE(740+IAPROC,*) 'pro1 sum(FRK)=', sum(FRK) + WRITE(740+IAPROC,*) 'pro1 sum(FRG)=', sum(FRG) + WRITE(740+IAPROC,*) 'pro1 sum(DSDD)=', sum(DSDD) + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCTH) + FLUSH(740+IAPROC) +#endif ! -!/REFRX! 2.c @C/@x refraction and great-circle propagation -!/REFRX VCTH = 0. -!/REFRX FRK = 0. -!/REFRX FDDMAX = 0. -! -!/REFRX DO ISP=1, NSPEC -!/REFRX FDDMAX = MAX ( FDDMAX , ABS ( & -!/REFRX ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) -!/REFRX END DO -! -!/REFRX DO IK=1, NK -!/REFRX FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) -!/REFRX FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) -!/REFRX FRG(IK) = FDG * CG(IK) -!/REFRX END DO -!/REFRX DO ISP=1, NSPEC -!/REFRX VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & -!/REFRX + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & -!/REFRX - ECOS(ISP)*DCDY(MAPWN(ISP)) ) -!/REFRX END DO +#ifdef W3_REFRX +! 2.c @C/@x refraction and great-circle propagation + VCTH = 0. + FRK = 0. + FDDMAX = 0. +#endif +! +#ifdef W3_REFRX + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO +#endif +! +#ifdef W3_REFRX + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK) + END DO + DO ISP=1, NSPEC + VCTH(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) + END DO +#endif ! ! 2.d Current refraction ! @@ -1073,12 +1169,14 @@ SUBROUTINE W3KTP1 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & ! ! Formats ! -!/T 9000 FORMAT (' TEST W3KTP1 : FLCTH-K, FACTH-K, CTMAX :', & -!/T 2L2,2E10.3,F7.3) -!/T 9001 FORMAT (' TEST W3KTP1 : LOCAL DATA :',I7,F7.1,2F6.2,1X, & -!/T 6E10.3) -!/T 9010 FORMAT (' TEST W3KTP1 : IK, T, L, CG, DSDD : ') -!/T 9011 FORMAT (' ',I3,F7.2,F7.1,F7.2,E11.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3KTP1 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) + 9001 FORMAT (' TEST W3KTP1 : LOCAL DATA :',I7,F7.1,2F6.2,1X, & + 6E10.3) + 9010 FORMAT (' TEST W3KTP1 : IK, T, L, CG, DSDD : ') + 9011 FORMAT (' ',I3,F7.2,F7.1,F7.2,E11.3) +#endif !/ !/ End of W3KTP1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3pro2md.ftn b/model/src/w3pro2md.F90 similarity index 79% rename from model/ftn/w3pro2md.ftn rename to model/src/w3pro2md.F90 index 75c7abf54..3997d17c9 100644 --- a/model/ftn/w3pro2md.ftn +++ b/model/src/w3pro2md.F90 @@ -190,7 +190,9 @@ SUBROUTINE W3MAP2 NMXY, MAPX2, MAPY2, MAPAXY, MAPXY, & MAPTH2, MAPWN2 USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -202,18 +204,26 @@ SUBROUTINE W3MAP2 !/ INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & IK, ITH, ISP, ISP0, ISP2 -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: MAPTXY(NY,NX), I, IXY -!/T INTEGER :: MAPTST(NK+2,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: MAPTXY(NY,NX), I, IXY + INTEGER :: MAPTST(NK+2,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3MAP2') +#ifdef W3_S + CALL STRACE (IENT, 'W3MAP2') +#endif ! ! 1. Map MAPX2 ------------------------------------------------------ * ! 1.a Range 1 to NMX0 ! -!/T MAPTXY = 0. +#ifdef W3_T + MAPTXY = 0. +#endif ! NMX0 = 0 DO IX=1, NX @@ -223,7 +233,9 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN NMX0 = NMX0 + 1 MAPX2(NMX0) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#endif END IF END DO END DO @@ -238,7 +250,9 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN NMX1 = NMX1 + 1 MAPX2(NMX1) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#endif END IF END DO END DO @@ -253,22 +267,28 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN NMX2 = NMX2 + 1 MAPX2(NMX2) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#endif END IF END DO END DO ! -!/T WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & -!/T NMX2-NMX1, NMX2 -!/T DO IY=NY, 1, -1 -!/T WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & + NMX2-NMX1, NMX2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif ! ! 2. Map MAPY2 ------------------------------------------------------ * ! 2.a Range 1 to NMY0 ! -!/T MAPTXY = 0. +#ifdef W3_T + MAPTXY = 0. +#endif ! NMY0 = 0 DO IX=1, NX @@ -278,7 +298,9 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN NMY0 = NMY0 + 1 MAPY2(NMY0) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#endif END IF END DO END DO @@ -293,7 +315,9 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN NMY1 = NMY1 + 1 MAPY2(NMY1) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#endif END IF END DO END DO @@ -308,16 +332,20 @@ SUBROUTINE W3MAP2 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN NMY2 = NMY2 + 1 MAPY2(NMY2) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#endif END IF END DO END DO ! -!/T WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & -!/T NMY2-NMY1, NMY2 -!/T DO IY=NY, 1, -1 -!/T WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & + NMY2-NMY1, NMY2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif ! ! 3. Map MAPAXY and MAPXY ------------------------------------------- * ! @@ -352,7 +380,9 @@ SUBROUTINE W3MAP2 ! IF ( MAPTH2(1) .NE. 0 ) RETURN ! -!/T MAPTST = 0 +#ifdef W3_T + MAPTST = 0 +#endif ! ! 4.a MAPTH2 and MAPBTK ! @@ -361,16 +391,22 @@ SUBROUTINE W3MAP2 ISP = ITH + (IK-1)*NTH ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPTH2(ISP) = ISP2 -!/T MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#ifdef W3_T + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#endif END DO END DO ! -!/T WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP -!/T DO IK=NK+2, 1, -1 -!/T WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif ! -!/T MAPTST = 0 +#ifdef W3_T + MAPTST = 0 +#endif ! ! 4.b MAPWN2 ! @@ -380,7 +416,9 @@ SUBROUTINE W3MAP2 ISP0 = ISP0 + 1 ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#ifdef W3_T + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#endif END DO END DO ! @@ -388,35 +426,45 @@ SUBROUTINE W3MAP2 ISP0 = ISP0 + 1 ISP2 = NK+1 + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#ifdef W3_T + MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#endif END DO ! DO ITH=1, NTH ISP0 = ISP0 + 1 ISP2 = 1 + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(1,ITH) = MAPTST(1,ITH) + 4 +#ifdef W3_T + MAPTST(1,ITH) = MAPTST(1,ITH) + 4 +#endif END DO ! -!/T WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH -!/T DO IK=NK+2, 1, -1 -!/T WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (/' TEST W3MAP2 : TEST MAP FOR PROPAGATION'/ & -!/T ' MAP : ',A/ & -!/T ' CENTRAL : ',I6/ & -!/T ' ABOVE : ',I6/ & -!/T ' BELOW : ',I6/ & -!/T ' TOTAL : ',I6/) -!/T 9001 FORMAT (1X,130I1) -! -!/T 9010 FORMAT (' TEST W3MAP2 : COMPOSITE MAPS TH2, WN2 AND BTK') -!/T 9011 FORMAT (2X,60I2) +#ifdef W3_T + 9000 FORMAT (/' TEST W3MAP2 : TEST MAP FOR PROPAGATION'/ & + ' MAP : ',A/ & + ' CENTRAL : ',I6/ & + ' ABOVE : ',I6/ & + ' BELOW : ',I6/ & + ' TOTAL : ',I6/) + 9001 FORMAT (1X,130I1) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3MAP2 : COMPOSITE MAPS TH2, WN2 AND BTK') + 9011 FORMAT (2X,60I2) +#endif !/ !/ End of W3MAP2 ----------------------------------------------------- / !/ @@ -604,9 +652,15 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & ISBPI, BBPI0, BBPIN, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE -!/UQ USE W3UQCKMD -!/UNO USE W3UNO2MD +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_UQ + USE W3UQCKMD +#endif +#ifdef W3_UNO + USE W3UNO2MD +#endif !/ IMPLICIT NONE !/ @@ -623,7 +677,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) INTEGER :: ITH, IK, NTLOC, ITLOC, ISEA, IXY, & IX,IY, IY0, IP, IBI INTEGER :: TTEST(2),DTTST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & CXMIN, CXMAX, CYMIN, CYMAX REAL :: DTLOC, DTRAD, & @@ -652,7 +708,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XYP2') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYP2') +#endif ! ! IF ( MAXVAL(VQ) .EQ. 0. ) THEN ! IF ( NBI .EQ. 0 ) THEN @@ -682,8 +740,10 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) CGA = 0.575 * GRAV / SIG(IK) CGX = CGA * ECOS(ITH) CGY = CGA * ESIN(ITH) -!/MGP CGX = CGX - VGX -!/MGP CGY = CGY - VGY +#ifdef W3_MGP + CGX = CGX - VGX + CGY = CGY - VGY +#endif ! IF ( FLCUR ) THEN CXMIN = MINVAL ( CX(1:NSEA) ) @@ -702,8 +762,10 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) END IF CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) -!/MGP CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) -!/MGP CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#ifdef W3_MGP + CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) + CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#endif ELSE CXC = 0. CYC = 0. @@ -729,10 +791,14 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) DTTST = DSEC21(TTEST,TIME) YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 ! -!/T WRITE (NDST,9000) YFIRST -!/T WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) +#ifdef W3_T + WRITE (NDST,9000) YFIRST + WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) +#endif ! -!/TDYN IF ( ISP .EQ. 1 ) DTME = DTME + DTG +#ifdef W3_TDYN + IF ( ISP .EQ. 1 ) DTME = DTME + DTG +#endif ! IF ( DTME .NE. 0. ) THEN DFRR = XFR - 1. @@ -740,15 +806,19 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) CGD = 0.5 * GRAV / SIG(IK) DSSD = ( DFRR * CGD )**2 * DTME / 12. DNND = ( CGD * DTH )**2 * DTME / 12. -!/T WRITE (NDST,9002) DFRR, CELLP, DTME -!/T ELSE -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9002) DFRR, CELLP, DTME + ELSE + WRITE (NDST,9003) +#endif END IF ! ! 1.b Initialize arrays ! -!/T WRITE (NDST,9010) +#ifdef W3_T + WRITE (NDST,9010) +#endif ! VLCFLX = 0. VLCFLY = 0. @@ -768,37 +838,53 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! LCFLX = ( COS*CG / CLATS ) * DT / DX ! LCFLY = ( SIN*CG ) * DT / DX ! -!/T WRITE (NDST,9020) NSEA +#ifdef W3_T + WRITE (NDST,9020) NSEA +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#endif ! DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) -!/MGP CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) -!/MGP CYTOT(IXY) = CYTOT(IXY) - VGY -!/T1 IF ( .NOT. FLCUR ) & -!/T1 WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & -!/T1 VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#ifdef W3_MGP + CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) - VGY +#endif +#ifdef W3_T1 + IF ( .NOT. FLCUR ) & + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! IF ( FLCUR ) THEN -!/T WRITE (NDST,9022) +#ifdef W3_T + WRITE (NDST,9022) +#endif DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) -!/T1 WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & -!/T1 VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#ifdef W3_T1 + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#endif END DO END IF ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, CP, CQ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, CP, CQ) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -810,14 +896,18 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VLCFLY(IXY) = CQ*DTRAD END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 2.b Diffusion coefficients ! IF ( DTME .NE. 0. ) THEN ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & -!/OMPH/!$OMP& DCELL, XWIND, TFAC, DSS, DNN) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & +!$OMP& DCELL, XWIND, TFAC, DSS, DNN) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -829,11 +919,17 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) HQFAC(IY,IX)*RFAC ) / CELLP XWIND = 3.3 * U10(ISEA)*WN(IK,ISEA)/SIG(IK) - 2.3 XWIND = MAX ( 0. , MIN ( 1. , XWIND ) ) -!/XW0 XWIND = 0. -!/XW1 XWIND = 1. +#ifdef W3_XW0 + XWIND = 0. +#endif +#ifdef W3_XW1 + XWIND = 1. +#endif TFAC = MIN ( 1. , (CLATS(ISEA)/CLATMN)**2 ) DSS = XWIND * DCELL + (1.-XWIND) * DSSD * TFAC -!/DSS0 DSS = 0. +#ifdef W3_DSS0 + DSS = 0. +#endif DNN = XWIND * DCELL + (1.-XWIND) * DNND * TFAC VDXX(IXY) = DTLOC * (DSS*ECOS(ITH)**2+DNN*ESIN(ITH)**2) @@ -845,7 +941,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) END IF END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! @@ -855,7 +953,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! ! 3.a Propagate fields ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -864,51 +964,63 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! IF ( YFIRST ) THEN ! -!/UQ IF ( FLCY ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UQ .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UQ NMY1, NMY2, NDSE, NDST ) -!/UQ IF ( FLCX ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UQ GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UQ NMX1, NMX2, NDSE, NDST ) -! -!/UNO IF ( FLCY ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UNO .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UNO NMY1, NMY2, NDSE, NDST ) -!/UNO IF ( FLCX ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UNO GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UNO NMX1, NMX2, NDSE, NDST ) +#ifdef W3_UQ + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif +! +#ifdef W3_UNO + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif ! ELSE ! -!/UQ IF ( FLCX ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UQ GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UQ NMX1, NMX2, NDSE, NDST ) -!/UQ IF ( FLCY ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UQ .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UQ NMY1, NMY2, NDSE, NDST ) -! -!/UNO IF ( FLCX ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UNO GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UNO NMX1, NMX2, NDSE, NDST ) -!/UNO IF ( FLCY ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UNO .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UNO NMY1, NMY2, NDSE, NDST ) +#ifdef W3_UQ + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif +! +#ifdef W3_UNO + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif ! END IF ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY ) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -917,7 +1029,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 3.b Update boundaries ! @@ -977,8 +1091,10 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VQ_OLD = VQ ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & -!/OMPH/!$OMP& QXX, QYY, QXY, DVQ ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY, & +!$OMP& QXX, QYY, QXY, DVQ ) +#endif ! DO IP=1, NACT IXY = MAPAXY(IP) @@ -1047,7 +1163,9 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! @@ -1056,40 +1174,62 @@ SUBROUTINE W3XYP2 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! ! 4. Store results in VQ in proper format --------------------------- * ! -!/T WRITE (NDST,9040) NSEA +#ifdef W3_T + WRITE (NDST,9040) NSEA +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY ) +#endif ! DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) IF ( MAPSTA(IXY) .GT. 0 ) THEN -!/T2 WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) +#ifdef W3_T2 + WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) +#endif VQ(IXY) = MAX ( 0. , CG(IK,ISEA) / CLATS(ISEA) * VQ(IXY) ) ! ELSE ! VQ(IXY) = 0. END IF END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3XYP2 : YFIRST :',L2) -!/T 9001 FORMAT (' TEST W3XYP2 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) -!/T 9002 FORMAT (' TEST W3XYP2 : DFRR, CELLP, DTME :',3E10.3) -!/T 9003 FORMAT (' TEST W3XYP2 : NO DISPERSION CORRECTION ') -! -!/T 9010 FORMAT (' TEST W3XYP2 : INITIALIZE ARRAYS') -! -!/T 9020 FORMAT (' TEST W3XYP2 : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & -!/T I6,')') -!/T1 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) -!/T 9022 FORMAT (' TEST W3XYP2 : CORRECTING FOR CURRENT') -! -!/T 9040 FORMAT (' TEST W3XYP2 : FIELD AFTER PROP. (NSEA=',I6,')') -!/T2 9041 FORMAT (1X,I6,2I5,E12.4) +#ifdef W3_T + 9000 FORMAT (' TEST W3XYP2 : YFIRST :',L2) + 9001 FORMAT (' TEST W3XYP2 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) + 9002 FORMAT (' TEST W3XYP2 : DFRR, CELLP, DTME :',3E10.3) + 9003 FORMAT (' TEST W3XYP2 : NO DISPERSION CORRECTION ') +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3XYP2 : INITIALIZE ARRAYS') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3XYP2 : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & + I6,')') +#endif +#ifdef W3_T1 + 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) +#endif +#ifdef W3_T + 9022 FORMAT (' TEST W3XYP2 : CORRECTING FOR CURRENT') +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3XYP2 : FIELD AFTER PROP. (NSEA=',I6,')') +#endif +#ifdef W3_T2 + 9041 FORMAT (1X,I6,2I5,E12.4) +#endif !/ !/ End of W3XYP2 ----------------------------------------------------- / !/ @@ -1212,9 +1352,15 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, ONLY: NDSE, NDST -!/S USE W3SERVMD, ONLY: STRACE -!/UQ USE W3UQCKMD -!/UNO USE W3UNO2MD +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_UQ + USE W3UQCKMD +#endif +#ifdef W3_UNO + USE W3UNO2MD +#endif !/ IMPLICIT NONE !/ @@ -1232,7 +1378,9 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ Local parameters !/ INTEGER :: ITH, IK, ISP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & DCXXYY, DCXY, DCXX, DCXYYX, DCYY REAL :: DSDD(0:NK+1), FRK(NK), FRG(NK), & @@ -1242,16 +1390,20 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3KTP2') +#ifdef W3_S + CALL STRACE (IENT, 'W3KTP2') +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Initialize arrays ! IF ( FLCK ) VQ = 0. ! -!/T WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX -!/T WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & -!/T DCXDX, DCXDY, DCYDX, DCYDY +#ifdef W3_T + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & + DCXDX, DCXDY, DCYDX, DCYDY +#endif ! ! 2. Preparation for point ------------------------------------------ * ! 2.a Array with partial derivative of sigma versus depth @@ -1265,11 +1417,13 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & END IF END DO ! -!/T WRITE (NDST,9020) -!/T DO IK=1, NK+1 -!/T WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & -!/T CG(IK), DSDD(IK) -!/T END DO +#ifdef W3_T + WRITE (NDST,9020) + DO IK=1, NK+1 + WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO +#endif ! ! 2.b Extract spectrum ! @@ -1303,24 +1457,30 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) END DO ! -!/REFRX! 3.c @C/@x refraction and great-circle propagation -!/REFRX VCFLT = 0. -!/REFRX FRK = 0. -!/REFRX FDDMAX = 0. -! -!/REFRX DO ISP=1, NSPEC -!/REFRX FDDMAX = MAX ( FDDMAX , ABS ( & -!/REFRX ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) -!/REFRX END DO -! -!/REFRX DO IK=1, NK -!/REFRX FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) -!/REFRX END DO -!/REFRX DO ISP=1, NSPEC -!/REFRX VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & -!/REFRX + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & -!/REFRX - ECOS(ISP)*DCDY(MAPWN(ISP)) ) -!/REFRX END DO +#ifdef W3_REFRX +! 3.c @C/@x refraction and great-circle propagation + VCFLT = 0. + FRK = 0. + FDDMAX = 0. +#endif +! +#ifdef W3_REFRX + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO +#endif +! +#ifdef W3_REFRX + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + END DO + DO ISP=1, NSPEC + VCFLT(MAPTH2(ISP)) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) + END DO +#endif ! ! 3.d Current refraction ! @@ -1391,37 +1551,49 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) END DO ! -!/UQ CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UQ VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UQ MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UQ NDSE, NDST ) -! -!/UNO CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UNO VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UNO MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UNO NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif +! +#ifdef W3_UNO + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif END IF IF ( FLCTH ) THEN ! -!/UQ CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UQ NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & -!/UQ NSPEC, NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UNO NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& -!/UNO NSPEC, NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif ! END IF ELSE IF ( FLCTH ) THEN ! -!/UQ CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UQ NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & -!/UQ NSPEC, NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UNO NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& -!/UNO NSPEC, NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif ! END IF IF ( FLCK ) THEN @@ -1429,15 +1601,19 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) END DO ! -!/UQ CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UQ VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UQ MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UQ NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UNO VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UNO MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UNO NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! END IF END IF @@ -1452,15 +1628,19 @@ SUBROUTINE W3KTP2 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3KTP2 : FLCTH-K, FACTH-K, CTMAX :', & -!/T 2L2,2E10.3,F7.3) -!/T 9010 FORMAT ( ' TEST W3KTP2 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) -!/T 9020 FORMAT ( ' TEST W3KTP2 : IK, T, L, CG, DSDD : ') -!/T 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) -! -!/T0 9040 FORMAT (/' TEST W3KTP2 : NORMALIZED ',A/) -!/T0 9041 FORMAT (1X,60(1X,I2)) -!/T0 9042 FORMAT (1X,60I3) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3KTP2 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) + 9010 FORMAT ( ' TEST W3KTP2 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) + 9020 FORMAT ( ' TEST W3KTP2 : IK, T, L, CG, DSDD : ') + 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) +#endif +! +#ifdef W3_T0 + 9040 FORMAT (/' TEST W3KTP2 : NORMALIZED ',A/) + 9041 FORMAT (1X,60(1X,I2)) + 9042 FORMAT (1X,60I3) +#endif !/ !/ End of W3KTP2 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3pro3md.ftn b/model/src/w3pro3md.F90 similarity index 81% rename from model/ftn/w3pro3md.ftn rename to model/src/w3pro3md.F90 index 67725c47d..afec95b66 100644 --- a/model/ftn/w3pro3md.ftn +++ b/model/src/w3pro3md.F90 @@ -195,7 +195,9 @@ SUBROUTINE W3MAP3 NCENT, MAPX2, MAPY2, MAPAXY, MAPCXY, & MAPTH2, MAPWN2 USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -207,19 +209,27 @@ SUBROUTINE W3MAP3 !/ INTEGER :: IX, IY, IXY0, IX2, IY2, IX0, IY0, & ISEA, IK, ITH, ISP, ISP0, ISP2, NCENTC -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: MAPTXY(NY,NX), I, IXY -!/T INTEGER :: MAPTST(NK+2,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: MAPTXY(NY,NX), I, IXY + INTEGER :: MAPTST(NK+2,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3MAP3') +#ifdef W3_S + CALL STRACE (IENT, 'W3MAP3') +#endif ! IF (GTYPE .LT. 3) THEN ! 1. Map MAPX2 ------------------------------------------------------ * ! 1.a Range 1 to NMX0 ! -!/T MAPTXY = 0. +#ifdef W3_T + MAPTXY = 0. +#endif ! NMX0 = 0 DO IX=1, NX @@ -229,7 +239,9 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN NMX0 = NMX0 + 1 MAPX2(NMX0) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#endif END IF END DO END DO @@ -244,7 +256,9 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY,IX2).NE.1 ) THEN NMX1 = NMX1 + 1 MAPX2(NMX1) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#endif END IF END DO END DO @@ -259,21 +273,27 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY,IX2).EQ.1 ) THEN NMX2 = NMX2 + 1 MAPX2(NMX2) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#endif END IF END DO END DO ! -!/T WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & -!/T NMX2-NMX1, NMX2 -!/T DO IY=NY, 1, -1 -!/T WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPX2', NMX0, NMX1-NMX0, & + NMX2-NMX1, NMX2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif ! ! 2. Map MAPY2 ------------------------------------------------------ * ! 2.a Range 1 to NMY0 ! -!/T MAPTXY = 0. +#ifdef W3_T + MAPTXY = 0. +#endif ! NMY0 = 0 DO IX=1, NX @@ -283,7 +303,9 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN NMY0 = NMY0 + 1 MAPY2(NMY0) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 1 +#endif END IF END DO END DO @@ -298,7 +320,9 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).EQ.1 .AND. MAPSTA(IY2,IX).NE.1 ) THEN NMY1 = NMY1 + 1 MAPY2(NMY1) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 2 +#endif END IF END DO END DO @@ -313,16 +337,20 @@ SUBROUTINE W3MAP3 IF ( MAPSTA(IY,IX).NE.1 .AND. MAPSTA(IY2,IX).EQ.1 ) THEN NMY2 = NMY2 + 1 MAPY2(NMY2) = IXY0 + IY -!/T MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#ifdef W3_T + MAPTXY(IY,IX) = MAPTXY(IY,IX) + 4 +#endif END IF END DO END DO ! -!/T WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & -!/T NMY2-NMY1, NMY2 -!/T DO IY=NY, 1, -1 -!/T WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPY2', NMY0, NMY1-NMY0, & + NMY2-NMY1, NMY2 + DO IY=NY, 1, -1 + WRITE (NDST,9001) (MAPTXY(IY,IX),IX=1, NX) + END DO +#endif ! ! 3. Map MAPAXY ----------------------------------------------------- * ! @@ -376,7 +404,9 @@ SUBROUTINE W3MAP3 ! IF ( MAPTH2(1) .NE. 0 ) RETURN ! -!/T MAPTST = 0 +#ifdef W3_T + MAPTST = 0 +#endif ! ! 5.a MAPTH2 and MAPBTK ! @@ -385,16 +415,22 @@ SUBROUTINE W3MAP3 ISP = ITH + (IK-1)*NTH ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPTH2(ISP) = ISP2 -!/T MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#ifdef W3_T + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#endif END DO END DO ! -!/T WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP -!/T DO IK=NK+2, 1, -1 -!/T WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPTH2', ISP, 0, 0, ISP + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif ! -!/T MAPTST = 0 +#ifdef W3_T + MAPTST = 0 +#endif ! ! 5.b MAPWN2 ! @@ -404,7 +440,9 @@ SUBROUTINE W3MAP3 ISP0 = ISP0 + 1 ISP2 = (IK+1) + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#ifdef W3_T + MAPTST(IK+1,ITH) = MAPTST(IK+1,ITH) + 1 +#endif END DO END DO ! @@ -412,35 +450,45 @@ SUBROUTINE W3MAP3 ISP0 = ISP0 + 1 ISP2 = NK+1 + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#ifdef W3_T + MAPTST(NK+1,ITH) = MAPTST(NK+1,ITH) + 2 +#endif END DO ! DO ITH=1, NTH ISP0 = ISP0 + 1 ISP2 = 1 + (ITH-1)*(NK+2) MAPWN2(ISP0) = ISP2 -!/T MAPTST(1,ITH) = MAPTST(1,ITH) + 4 +#ifdef W3_T + MAPTST(1,ITH) = MAPTST(1,ITH) + 4 +#endif END DO ! -!/T WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH -!/T DO IK=NK+2, 1, -1 -!/T WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) -!/T END DO +#ifdef W3_T + WRITE (NDST,9000) 'MAPWN2', NSPEC-NTH, NTH, NTH, NSPEC+NTH + DO IK=NK+2, 1, -1 + WRITE (NDST,9001) (MAPTST(IK,ITH),ITH=1, NTH) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (/' TEST W3MAP3 : TEST MAP FOR PROPAGATION'/ & -!/T ' MAP : ',A/ & -!/T ' CENTRAL : ',I6/ & -!/T ' ABOVE : ',I6/ & -!/T ' BELOW : ',I6/ & -!/T ' TOTAL : ',I6/) -!/T 9001 FORMAT (1X,130I1) -! -!/T 9010 FORMAT (' TEST W3MAP3 : COMPOSITE MAPS TH2, WN2 AND BTK') -!/T 9011 FORMAT (2X,60I2) +#ifdef W3_T + 9000 FORMAT (/' TEST W3MAP3 : TEST MAP FOR PROPAGATION'/ & + ' MAP : ',A/ & + ' CENTRAL : ',I6/ & + ' ABOVE : ',I6/ & + ' BELOW : ',I6/ & + ' TOTAL : ',I6/) + 9001 FORMAT (1X,130I1) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3MAP3 : COMPOSITE MAPS TH2, WN2 AND BTK') + 9011 FORMAT (2X,60I2) +#endif !/ !/ End of W3MAP3 ----------------------------------------------------- / !/ @@ -498,7 +546,9 @@ SUBROUTINE W3MAPT !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF USE W3ADATMD, ONLY: ATRNX, ATRNY, MAPTRN -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -509,11 +559,15 @@ SUBROUTINE W3MAPT !/ Local parameters !/ INTEGER :: ISEA, IXY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3MAPT') +#ifdef W3_S + CALL STRACE (IENT, 'W3MAPT') +#endif ! ! 1. Map MAPTRN ----------------------------------------------------- * ! @@ -705,9 +759,15 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & ISBPI, BBPI0, BBPIN, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE -!/UQ USE W3UQCKMD -!/UNO USE W3UNO2MD +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_UQ + USE W3UQCKMD +#endif +#ifdef W3_UNO + USE W3UNO2MD +#endif !/ IMPLICIT NONE !/ @@ -726,7 +786,9 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) INTEGER :: IIXY1(NSEA), IIXY2(NSEA), & IIXY3(NSEA), IIXY4(NSEA) INTEGER :: TTEST(2),DTTST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & CXMIN, CXMAX, CYMIN, CYMAX REAL :: CGC, FGSE = 1. @@ -750,7 +812,9 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XYP3') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYP3') +#endif ! ! 1. Preparations --------------------------------------------------- * @@ -772,10 +836,14 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) CGA = 0.575 * GRAV / SIG(IK) CGX = CGA * ECOS(ITH) CGY = CGA * ESIN(ITH) -!/MGP CGX = CGX - VGX -!/MGP CGY = CGY - VGY +#ifdef W3_MGP + CGX = CGX - VGX + CGY = CGY - VGY +#endif CGC = SQRT ( CGX**2 + CGY**2 ) -!/MGG FGSE = ( CGA / MAX(0.001*CGA,CGC) )**PFMOVE +#ifdef W3_MGG + FGSE = ( CGA / MAX(0.001*CGA,CGC) )**PFMOVE +#endif ! IF ( FLCUR ) THEN CXMIN = MINVAL ( CX(1:NSEA) ) @@ -794,8 +862,10 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) END IF CXC = MAX ( ABS(CXMIN) , ABS(CXMAX) ) CYC = MAX ( ABS(CYMIN) , ABS(CYMAX) ) -!/MGP CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) -!/MGP CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#ifdef W3_MGP + CXC = MAX ( ABS(CXMIN-VGX) , ABS(CXMAX-VGX) ) + CYC = MAX ( ABS(CYMIN-VGY) , ABS(CYMAX-VGY) ) +#endif ELSE CXC = 0. CYC = 0. @@ -813,12 +883,16 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) DTTST = DSEC21(TTEST,TIME) YFIRST = MOD(NINT(DTTST/DTG),2) .EQ. 0 ! -!/T WRITE (NDST,9000) YFIRST -!/T WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) +#ifdef W3_T + WRITE (NDST,9000) YFIRST + WRITE (NDST,9001) ISP, ITH, IK, ECOS(ITH), ESIN(ITH) +#endif ! ! 1.b Initialize arrays ! -!/T WRITE (NDST,9010) +#ifdef W3_T + WRITE (NDST,9010) +#endif ! VLCFLX = 0. VLCFLY = 0. @@ -849,11 +923,15 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) FCGX = FCG * ECOS(ITH) FCGY = FCG * ESIN(ITH) ! -!/T0 WRITE (NDST,9011) +#ifdef W3_T0 + WRITE (NDST,9011) +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, TMPX, TMPY, & -!/OMPH/!$OMP& DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, DYCGC, & -!/OMPH/!$OMP& IXC, IYC) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, TMPX, TMPY, & +!$OMP& DXCGN, DYCGN, DXCGS, DYCGS, DXCGC, DYCGC, & +!$OMP& IXC, IYC) +#endif ! DO ISEA=1, NSEA ! @@ -896,8 +974,10 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) RDI2(ISEA) = ABS(DYCGC) END IF ! -!/T0 WRITE (NDST,9012) ISEA, ITH, IIXY1(ISEA), IIXY2(ISEA), & -!/T0 RDI1(ISEA), RDI2(ISEA)*CG(IK,1) +#ifdef W3_T0 + WRITE (NDST,9012) ISEA, ITH, IIXY1(ISEA), IIXY2(ISEA), & + RDI1(ISEA), RDI2(ISEA)*CG(IK,1) +#endif ! ! 1.c.2 "Difference" corner (and mirror image) ... ! @@ -924,12 +1004,16 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) RDI4(ISEA) = ABS(DYCGC) END IF ! -!/T0 WRITE (NDST,9013) IIXY3(ISEA), IIXY4(ISEA), RDI3(ISEA), & -!/T0 RDI4(ISEA)*CG(IK,1) +#ifdef W3_T0 + WRITE (NDST,9013) IIXY3(ISEA), IIXY4(ISEA), RDI3(ISEA), & + RDI4(ISEA)*CG(IK,1) +#endif ! END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 2. Calculate velocities and diffusion coefficients ---------------- * ! 2.a Velocities @@ -938,42 +1022,62 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! LCFLX = ( COS*CG / CLATS ) * DT / DX ! LCFLY = ( SIN*CG ) * DT / DY ! -!/T WRITE (NDST,9020) NSEA +#ifdef W3_T + WRITE (NDST,9020) NSEA +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#endif ! DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) VQ (IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) CXTOT(IXY) = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) CYTOT(IXY) = ESIN(ITH) * CG(IK,ISEA) -!/MGP CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) -!/MGP CYTOT(IXY) = CYTOT(IXY) - VGY -!/T1 IF ( .NOT. FLCUR ) & -!/T1 WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & -!/T1 VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#ifdef W3_MGP + CXTOT(IXY) = CXTOT(IXY) - VGX/CLATS(ISEA) + CYTOT(IXY) = CYTOT(IXY) - VGY +#endif +#ifdef W3_T1 + IF ( .NOT. FLCUR ) & + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! IF ( FLCUR ) THEN -!/T WRITE (NDST,9022) +#ifdef W3_T + WRITE (NDST,9022) +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA,IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA,IXY) +#endif ! DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) CXTOT(IXY) = CXTOT(IXY) + CX(ISEA)/CLATS(ISEA) CYTOT(IXY) = CYTOT(IXY) + CY(ISEA) -!/T1 WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & -!/T1 VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#ifdef W3_T1 + WRITE (NDST,9021) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), & + VQ(IXY), CXTOT(IXY), CYTOT(IXY) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA,IX, IY, IXY, CP, CQ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA,IX, IY, IXY, CP, CQ) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -985,7 +1089,9 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VLCFLY(IXY) = CQ*DTRAD END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 3. Loop over sub-steps -------------------------------------------- * ! @@ -1141,7 +1247,9 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! ! Transform VQ to straightened space ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -1150,53 +1258,65 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VQ(IXY)= VQ(IXY) * GSQRT(IY,IX) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! IF ( YFIRST ) THEN ! -!/UQ IF ( FLCY ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UQ .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UQ NMY1, NMY2, NDSE, NDST ) -!/UQ IF ( FLCX ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UQ GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UQ NMX1, NMX2, NDSE, NDST ) -! -!/UNO IF ( FLCY ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UNO .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UNO NMY1, NMY2, NDSE, NDST ) -!/UNO IF ( FLCX ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UNO GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UNO NMX1, NMX2, NDSE, NDST ) +#ifdef W3_UQ + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif +! +#ifdef W3_UNO + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) +#endif ! ELSE ! -!/UQ IF ( FLCX ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UQ GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UQ NMX1, NMX2, NDSE, NDST ) -!/UQ IF ( FLCY ) CALL W3QCK3 & -!/UQ (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UQ .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UQ NMY1, NMY2, NDSE, NDST ) -! -!/UNO IF ( FLCX ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & -!/UNO GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & -!/UNO NMX1, NMX2, NDSE, NDST ) -!/UNO IF ( FLCY ) CALL W3UNO2s & -!/UNO (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & -!/UNO .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & -!/UNO NMY1, NMY2, NDSE, NDST ) +#ifdef W3_UQ + IF ( FLCX ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3QCK3 & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif +! +#ifdef W3_UNO + IF ( FLCX ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLX, ATRNX, VQ, & + GLOBAL, NY, MAPAXY, NACT, MAPX2, NMX0, & + NMX1, NMX2, NDSE, NDST ) + IF ( FLCY ) CALL W3UNO2s & + (NX, NY, NX, NY, VLCFLY, ATRNY, VQ, & + .FALSE., 1, MAPAXY, NACT, MAPY2, NMY0, & + NMY1, NMY2, NDSE, NDST ) +#endif ! END IF ! ! Transform VQ back to normal space ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IX, IY, IXY) +#endif ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) @@ -1205,19 +1325,25 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) VQ(IXY)= VQ(IXY) / GSQRT(IY,IX) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 3.c Update boundaries ! -!/T WRITE (NDST,9030) NSEA +#ifdef W3_T + WRITE (NDST,9030) NSEA +#endif ! -!/T2 DO ISEA=1, NSEA -!/T2 IXY = MAPSF(ISEA,3) -!/T2 IF ( MAPSTA(IXY) .GT. 0 ) THEN -!/T2 WRITE(NDST,9031)ISEA,MAPSF(ISEA,1),MAPSF(ISEA,2),VQ(IXY) -!/T2 VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GT. 0 ) THEN + WRITE(NDST,9031)ISEA,MAPSF(ISEA,1),MAPSF(ISEA,2),VQ(IXY) + VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) + END IF + END DO +#endif ! IF ( FLBPI ) THEN RD1 = DSEC21 ( TBPI0, TIME ) - DTG * & @@ -1242,41 +1368,69 @@ SUBROUTINE W3XYP3 ( ISP, DTG, MAPSTA, MAPFS, VQ, VGX, VGY ) ! ! 4. Store results in VQ in proper format --------------------------- * ! -!/T WRITE (NDST,9040) NSEA +#ifdef W3_T + WRITE (NDST,9040) NSEA +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (ISEA, IXY) +#endif ! DO ISEA=1, NSEA IXY = MAPSF(ISEA,3) IF ( MAPSTA(IXY) .GT. 0 ) THEN -!/T3 WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) +#ifdef W3_T3 + WRITE (NDST,9041) ISEA, MAPSF(ISEA,1), MAPSF(ISEA,2), VQ(IXY) +#endif VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) END IF END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3XYP3 : YFIRST :',L2) -!/T 9001 FORMAT (' TEST W3XYP3 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) -! -!/T 9010 FORMAT (' TEST W3XYP3 : INITIALIZE ARRAYS') -!/T0 9011 FORMAT (' TEST W3XYP3 : PREPARE AVERAGING') -!/T0 9012 FORMAT (' ',4I4,2F7.3) -!/T0 9013 FORMAT (' ',8X,2I4,2F7.3) -! -!/T 9020 FORMAT (' TEST W3XYP3 : CALCULATING VCFL0X/Y (NSEA=',I6,')') -!/T1 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) -!/T 9022 FORMAT (' TEST W3XYP3 : CALCULATING VCFLUX/Y') -! -!/T 9030 FORMAT (' TEST W3XYP3 : FIELD BEFORE BPI. (NSEA=',I6,')') -!/T2 9031 FORMAT (1X,I6,2I5,E12.4) -! -!/T 9040 FORMAT (' TEST W3XYP3 : FIELD AFTER PROP. (NSEA=',I6,')') -!/T3 9041 FORMAT (1X,I6,2I5,E12.4) +#ifdef W3_T + 9000 FORMAT (' TEST W3XYP3 : YFIRST :',L2) + 9001 FORMAT (' TEST W3XYP3 : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3XYP3 : INITIALIZE ARRAYS') +#endif +#ifdef W3_T0 + 9011 FORMAT (' TEST W3XYP3 : PREPARE AVERAGING') + 9012 FORMAT (' ',4I4,2F7.3) + 9013 FORMAT (' ',8X,2I4,2F7.3) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3XYP3 : CALCULATING VCFL0X/Y (NSEA=',I6,')') +#endif +#ifdef W3_T1 + 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) +#endif +#ifdef W3_T + 9022 FORMAT (' TEST W3XYP3 : CALCULATING VCFLUX/Y') +#endif +! +#ifdef W3_T + 9030 FORMAT (' TEST W3XYP3 : FIELD BEFORE BPI. (NSEA=',I6,')') +#endif +#ifdef W3_T2 + 9031 FORMAT (1X,I6,2I5,E12.4) +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3XYP3 : FIELD AFTER PROP. (NSEA=',I6,')') +#endif +#ifdef W3_T3 + 9041 FORMAT (1X,I6,2I5,E12.4) +#endif !/ !/ End of W3XYP3 ----------------------------------------------------- / !/ @@ -1404,9 +1558,15 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & USE W3ADATMD, ONLY: MAPTH2, MAPWN2, ITIME USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, ONLY: NDSE, NDST -!/S USE W3SERVMD, ONLY: STRACE -!/UQ USE W3UQCKMD -!/UNO USE W3UNO2MD +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_UQ + USE W3UQCKMD +#endif +#ifdef W3_UNO + USE W3UNO2MD +#endif !/ IMPLICIT NONE !/ @@ -1425,7 +1585,9 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & !/ Local parameters !/ INTEGER :: ITH, IK, ISP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FDDMAX, FDG, FKD, FKD0, DCYX, & DCXXYY, DCXY, DCXX, DCXYYX, DCYY, & VELNOFILT, VELFAC, DEPTH @@ -1436,7 +1598,9 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3KTP3') +#ifdef W3_S + CALL STRACE (IENT, 'W3KTP3') +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Initialize arrays @@ -1448,9 +1612,11 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & CFLTHMAX = 0. CFLKMAX = 0. ! -!/T WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX -!/T WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & -!/T DCXDX, DCXDY, DCYDX, DCYDY +#ifdef W3_T + WRITE (NDST,9000) FLCTH, FLCK, FACTH, FACK, CTMAX + WRITE (NDST,9010) ISEA, DEPTH, CX, CY, DDDX, DDDY, & + DCXDX, DCXDY, DCYDX, DCYDY +#endif ! ! 2. Preparation for point ------------------------------------------ * ! 2.a Array with partial derivative of sigma versus depth @@ -1464,11 +1630,13 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & END IF END DO ! -!/T WRITE (NDST,9020) -!/T DO IK=1, NK+1 -!/T WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & -!/T CG(IK), DSDD(IK) -!/T END DO +#ifdef W3_T + WRITE (NDST,9020) + DO IK=1, NK+1 + WRITE (NDST,9021) IK, TPI/SIG(IK), TPI/WN(IK), & + CG(IK), DSDD(IK) + END DO +#endif ! ! 2.b Extract spectrum ! @@ -1520,28 +1688,34 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & ! ! 3.c Depth refraction and great-circle propagation ! -!/REFRX! 3.d @C/@x refraction and great-circle propagation -!/REFRX FRK = 0. -!/REFRX FDDMAX = 0. +#ifdef W3_REFRX +! 3.d @C/@x refraction and great-circle propagation + FRK = 0. + FDDMAX = 0. +#endif ! -!/REFRX DO ISP=1, NSPEC -!/REFRX FDDMAX = MAX ( FDDMAX , ABS ( & -!/REFRX ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) -!/REFRX END DO -!/REFRX DO IK=1, NK -!/REFRX FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) -!/REFRX END DO +#ifdef W3_REFRX + DO ISP=1, NSPEC + FDDMAX = MAX ( FDDMAX , ABS ( & + ESIN(ISP)*DCDX(MAPWN(ISP)) - ECOS(ISP)*DCDY(MAPWN(ISP)) ) ) + END DO + DO IK=1, NK + FRK(IK) = FACTH * CG(IK) * WN(IK) / SIG(IK) + END DO +#endif ! DO ISP=1, NSPEC VELNOFILT = VCFLT(MAPTH2(ISP)) & + FRG(MAPWN(ISP)) * ECOS(ISP) & + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DDDX - ECOS(ISP)*DDDY ) ! -!/REFRX! 3.d @C/@x refraction and great-circle propagation -!/REFRX VELNOFILT = VCFLT(MAPTH2(ISP)) & -!/REFRX + FRG(MAPWN(ISP)) * ECOS(ISP) & -!/REFRX + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & -!/REFRX - ECOS(ISP)*DCDY(MAPWN(ISP)) ) +#ifdef W3_REFRX +! 3.d @C/@x refraction and great-circle propagation + VELNOFILT = VCFLT(MAPTH2(ISP)) & + + FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(MAPWN(ISP)) & + - ECOS(ISP)*DCDY(MAPWN(ISP)) ) +#endif CFLTHMAX = MAX(CFLTHMAX, ABS(VELNOFILT)) ! ! Puts filtering on total velocity (including currents and great circle effects) @@ -1612,38 +1786,50 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) END DO ! -!/UQ CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UQ VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UQ MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UQ NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UNO VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UNO MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UNO NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! END IF IF ( FLCTH ) THEN ! -!/UQ CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UQ NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & -!/UQ NSPEC, NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UNO NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& -!/UNO NSPEC, NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif ! END IF ELSE IF ( FLCTH ) THEN ! -!/UQ CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UQ NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & -!/UQ NSPEC, NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK1 ( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC, & + NSPEC, NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & -!/UNO NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& -!/UNO NSPEC, NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2r( NTH, NK2, NTH, NK2, VCFLT, VQ, .TRUE., & + NK2, MAPTH2, NSPEC, MAPTH2, NSPEC, NSPEC,& + NSPEC, NDSE, NDST ) +#endif ! END IF IF ( FLCK ) THEN @@ -1651,15 +1837,19 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & VQ(NK+2+(ITH-1)*NK2) = FACHFA * VQ(NK+1+(ITH-1)*NK2) END DO ! -!/UQ CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UQ VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UQ MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UQ NDSE, NDST ) +#ifdef W3_UQ + CALL W3QCK2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! -!/UNO CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & -!/UNO VQ, .FALSE., 1, MAPTH2, NSPEC, & -!/UNO MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & -!/UNO NDSE, NDST ) +#ifdef W3_UNO + CALL W3UNO2 ( NTH, NK2, NTH, NK2, CFLK, FACK, DB, DM, & + VQ, .FALSE., 1, MAPTH2, NSPEC, & + MAPWN2, NSPEC-NTH, NSPEC, NSPEC+NTH, & + NDSE, NDST ) +#endif ! END IF END IF @@ -1674,15 +1864,19 @@ SUBROUTINE W3KTP3 ( ISEA, FACTH, FACK, CTHG0, CG, WN, DW, & ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3KTP3 : FLCTH-K, FACTH-K, CTMAX :', & -!/T 2L2,2E10.3,F7.3) -!/T 9010 FORMAT ( ' TEST W3KTP3 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) -!/T 9020 FORMAT ( ' TEST W3KTP3 : IK, T, L, CG, DSDD : ') -!/T 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3KTP3 : FLCTH-K, FACTH-K, CTMAX :', & + 2L2,2E10.3,F7.3) + 9010 FORMAT ( ' TEST W3KTP3 : LOCAL DATA :',I7,F7.1,2F6.2,1X,6E10.2) + 9020 FORMAT ( ' TEST W3KTP3 : IK, T, L, CG, DSDD : ') + 9021 FORMAT ( ' ',I3,F7.2,F7.1,F7.2,E11.3) +#endif ! -!/T0 9040 FORMAT (/' TEST W3KTP3 : NORMALIZED ',A/) -!/T0 9041 FORMAT (1X,60(1X,I2)) -!/T0 9042 FORMAT (1X,60I3) +#ifdef W3_T0 + 9040 FORMAT (/' TEST W3KTP3 : NORMALIZED ',A/) + 9041 FORMAT (1X,60(1X,I2)) + 9042 FORMAT (1X,60I3) +#endif !/ !/ End of W3KTP3 ----------------------------------------------------- / !/ @@ -1782,7 +1976,9 @@ SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & ISBPI, BBPI0, BBPIN -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -1798,7 +1994,9 @@ SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) !/ INTEGER :: ITH, IK, IXY, IP INTEGER :: IX, IY, IXC, IYC, IBI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CG0, CGA, CGN, CGX, CGY, CXC, CYC, & CXMIN, CXMAX, CYMIN, CYMAX REAL :: CGC, FGSE = 1. @@ -1812,7 +2010,9 @@ SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3XYCFL') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYCFL') +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Set constants @@ -1826,8 +2026,10 @@ SUBROUTINE W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX, VGX, VGY ) DO ITH=1,NTH CXTOT = ECOS(ITH) * CG(IK,ISEA) / CLATS(ISEA) CYTOT = ESIN(ITH) * CG(IK,ISEA) -!/MGP CXTOT = CXTOT - VGX/CLATS(ISEA) -!/MGP CYTOT = CYTOT - VGY +#ifdef W3_MGP + CXTOT = CXTOT - VGX/CLATS(ISEA) + CYTOT = CYTOT - VGY +#endif IF ( FLCUR ) THEN diff --git a/model/ftn/w3profsmd.ftn b/model/src/w3profsmd.F90 similarity index 98% rename from model/ftn/w3profsmd.ftn rename to model/src/w3profsmd.F90 index d2f3010ab..211d20af1 100644 --- a/model/ftn/w3profsmd.ftn +++ b/model/src/w3profsmd.F90 @@ -142,7 +142,9 @@ SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) USE W3IDATMD, ONLY: FLCUR ! USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & ! ISBPI, BBPI0, BBPIN -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -158,7 +160,9 @@ SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) !/ INTEGER :: ITH, IK, ISEA, IXY INTEGER :: IX -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CCOS, CSIN, CCURX, CCURY REAL :: C(NX,2) REAL :: RD1, RD2 @@ -173,7 +177,9 @@ SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) ! 1.a Set constants ! -!/S CALL STRACE (IENT, 'W3XYPUG') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPUG') +#endif ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH @@ -199,8 +205,10 @@ SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) VQ(IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) VLCFLX(IXY) = CCOS * CG(IK,ISEA) / CLATS(ISEA) VLCFLY(IXY) = CSIN * CG(IK,ISEA) -!/MGP VLCFLX(IXY) = VLCFLX(IXY) - CCURX*VGX/CLATS(ISEA) -!/MGP VLCFLY(IXY) = VLCFLY(IXY) - CCURY*VGY +#ifdef W3_MGP + VLCFLX(IXY) = VLCFLX(IXY) - CCURX*VGX/CLATS(ISEA) + VLCFLY(IXY) = VLCFLY(IXY) - CCURY*VGY +#endif END DO IF ( FLCUR ) THEN @@ -339,9 +347,13 @@ SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, DW USE W3IDATMD, ONLY: FLCUR -!/T USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & -!/T ISBPI, BBPI0, BBPIN -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & + ISBPI, BBPI0, BBPIN +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -356,7 +368,9 @@ SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & !/ INTEGER :: ITH, IK INTEGER :: IP, IP2, ISEA2, I, J, IE, IV, I1, I2, I3 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CCOS, CSIN, CCURX, CCURY REAL :: C(NX,2) REAL*8 :: KELEM(3), KTMP(3), LAMBDA(2) @@ -374,7 +388,9 @@ SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & ! 1.a Set constants ! -!/S CALL STRACE (IENT, 'W3CFLUG') +#ifdef W3_S + CALL STRACE (IENT, 'W3CFLUG') +#endif CFLXYMAX=1E-10 IP = MAPSF(ISEA,3) ! @@ -405,8 +421,10 @@ SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & ISEA2=MAPFS(IP2) C(IP2,1) = CCOS * CG(IK,ISEA2) / CLATS(ISEA2) C(IP2,2) = CSIN * CG(IK,ISEA2) -!/MGP C(IP2,1) = C(IP2,1) - CCURX*VGX/CLATS(ISEA2) -!/MGP C(IP2,2) = C(IP2,2) - CCURY*VGY +#ifdef W3_MGP + C(IP2,1) = C(IP2,1) - CCURX*VGX/CLATS(ISEA2) + C(IP2,2) = C(IP2,2) - CCURY*VGY +#endif IF ( FLCUR ) THEN IF (IOBP(IP2) .EQ. 1) THEN C(IP2,1) = C(IP2,1) + CCURX*CX(ISEA2)/CLATS(ISEA2) @@ -508,12 +526,16 @@ SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, IOBDP, & IOBPA, XYB, FSBCCFL -!/REF1 USE W3GDATMD, ONLY : REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY : REFPARS +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: CG, ITER USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction @@ -530,7 +552,9 @@ SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) @@ -561,7 +585,9 @@ SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) REAL*8 :: KKSUM(NX), ST(NX) REAL*8 :: NM(NTRI) -!/S CALL STRACE (IENT, 'W3XYPFSN') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSN') +#endif ! 1. initialisation @@ -646,7 +672,9 @@ SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC) ! Possibly set flux to zero by multiplying ST by IOBPD but also in UTILDE multiply U(NI) by IOBPD ... ! U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#endif END DO ! update spectrum AC = U @@ -738,12 +766,16 @@ SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & IEN, TRIGP, CLATS, MAPSF, IOBPA, IOBPD, IOBP, NNZ, IOBDP -!/REF1 USE W3GDATMD, ONLY : REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY : REFPARS +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: CG, ITER USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction @@ -760,7 +792,9 @@ SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) @@ -792,7 +826,9 @@ SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) REAL*8 :: KKSUM(NX), ST(NX) REAL*8 :: NM(NTRI) -!/S CALL STRACE (IENT, 'W3XYPFSN') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSN') +#endif ! 1. initialisation @@ -887,7 +923,9 @@ SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) DO IP = 1, NX U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP)))*DBLE(IOBPD(ITH,IP)) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#endif END DO ! update spectrum @@ -983,12 +1021,16 @@ SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, IOBP, IAA, JAA, POSI, & TRIA, NNZ -!/REF1 USE W3GDATMD, ONLY : REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY : REFPARS +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: CG, ITER USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction @@ -1005,7 +1047,9 @@ SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 @@ -1062,7 +1106,9 @@ SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) POS_TRICK(3,1) = 1 POS_TRICK(3,2) = 2 -!/S CALL STRACE (IENT, 'W3XYPFSN') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSN') +#endif ! 1. initialisation @@ -1187,7 +1233,9 @@ SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC) DO IP = 1,NX U(IP) = MAX(0.d0,X(IP)*DBLE(IOBPD(ITH,IP))) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#endif END DO ! ! update spectrum @@ -1274,12 +1322,16 @@ SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBPA, TRIA, IOBDP -!/REF1 USE W3GDATMD, ONLY : REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY : REFPARS +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: CG, ITER USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction @@ -1296,7 +1348,9 @@ SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 @@ -1334,7 +1388,9 @@ SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) REAL*8 :: KKSUM(NX), ST(NX), BETA REAL*8 :: NM(NTRI) -!/S CALL STRACE (IENT, 'W3XYPFSFCT2') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSFCT2') +#endif ! 1. initialisation @@ -1479,7 +1535,9 @@ SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) ! IOBPD is the switch for removing energy coming from the shoreline ! U(IP) = MAX(0.d0,UL(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP).EQ.0.AND.IOBPA(IP).EQ.0) U(IP)= AC(IP) ! restores reflected boundary values +#endif END DO ! ! update spectrum @@ -1563,7 +1621,9 @@ SUBROUTINE SETDEPTH ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX @@ -1577,13 +1637,17 @@ SUBROUTINE SETDEPTH !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / ! INTEGER :: JSEA, ISEA, IX, IP REAL*8, PARAMETER :: DTHR = 10E-6 -!/S CALL STRACE (IENT, 'SETDEPTH') +#ifdef W3_S + CALL STRACE (IENT, 'SETDEPTH') +#endif IOBDP = 1 DO IP=1,NX IF (DW(IP) .LT. DMIN + DTHR) IOBDP(IP) = 0 diff --git a/model/ftn/w3profsmd_pdlib.ftn b/model/src/w3profsmd_pdlib.F90 similarity index 84% rename from model/ftn/w3profsmd_pdlib.ftn rename to model/src/w3profsmd_pdlib.F90 index 156435915..7813a1ce5 100644 --- a/model/ftn/w3profsmd_pdlib.ftn +++ b/model/src/w3profsmd_pdlib.F90 @@ -83,7 +83,9 @@ MODULE PDLIB_W3PROFSMD ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -91,7 +93,9 @@ MODULE PDLIB_W3PROFSMD !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -110,7 +114,9 @@ MODULE PDLIB_W3PROFSMD INTEGER, ALLOCATABLE :: IS0_pdlib(:) INTEGER :: FreqShiftMethod = 2 LOGICAL :: FSGEOADVECT -!/DEBUGSRC INTEGER :: TESTNODE = 1 +#ifdef W3_DEBUGSRC + INTEGER :: TESTNODE = 1 +#endif ! !/ ------------------------------------------------------------------- / ! @@ -163,7 +169,9 @@ SUBROUTINE VA_SETUP_IOBPD ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: IOBPD, GTYPE, UNGTYPE USE W3GDATMD, ONLY: NSPEC, NTH, NSEAL @@ -178,13 +186,17 @@ SUBROUTINE VA_SETUP_IOBPD !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ ! INTEGER JSEA, IP, IP_glob, ITH, ISP -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif IF (GTYPE .eq. UNGTYPE) THEN DO JSEA=1,NSEAL IP = JSEA @@ -242,7 +254,9 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: FLCX, FLCY USE CONSTANTS, ONLY : GRAV, TPI @@ -271,7 +285,9 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -290,11 +306,15 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) INTEGER IK0, ISP0, ITH REAL :: eSIG, eFR REAL, PARAMETER :: COEF4 = 5.0E-7 -!/S CALL STRACE (IENT, 'PDLIB_STYLE_INIT') -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, IMOD (no print)' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NAPROC=', NAPROC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NTPROC=', NTPROC -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_S + CALL STRACE (IENT, 'PDLIB_STYLE_INIT') +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, IMOD (no print)' + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'NTPROC=', NTPROC + FLUSH(740+IAPROC) +#endif PDLIB_NSEAL=0 IF (IAPROC .le. NAPROC) THEN ALLOCATE(XP_IN(NX), YP_IN(NX), DEP_IN(NX), stat=istat) @@ -312,15 +332,19 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) END DO END DO CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, IAPROC=', IAPROC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, NAPROC=', NAPROC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, myrank=', myrank -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, IAPROC=', IAPROC + WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'PDLIB_STYLE_INIT, myrank=', myrank + FLUSH(740+IAPROC) +#endif ! CALL initFromGridDim(NX,XP_IN,YP_IN,DEP_IN,NTRI,INE_IN,NSPEC,MPI_COMM_WCMP) ! -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'After initFromGridDim' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'After initFromGridDim' + FLUSH(740+IAPROC) +#endif DEALLOCATE(XP_IN, YP_IN, DEP_IN, INE_IN) ! ! Now the computation of NSEAL @@ -330,15 +354,19 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) ISEA = MAPFS(1,IX) IF (ISEA .gt. 0) PDLIB_NSEAL = PDLIB_NSEAL + 1 END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'npa is augmented domain over NX' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_NSEAL is basicall npa but ONLY over the wet points' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NSEAL is set to PDLIB_NSEAL' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_NSEAL=', PDLIB_NSEAL -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'npa=', npa -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'npa is augmented domain over NX' + WRITE(740+IAPROC,*) 'PDLIB_NSEAL is basicall npa but ONLY over the wet points' + WRITE(740+IAPROC,*) 'NSEAL is set to PDLIB_NSEAL' + WRITE(740+IAPROC,*) 'PDLIB_NSEAL=', PDLIB_NSEAL + WRITE(740+IAPROC,*) 'npa=', npa + FLUSH(740+IAPROC) +#endif ALLOCATE(JX_TO_JSEA(npa), ISEA_TO_JSEA(NSEA), stat=istat) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISEA_TO_JSEA ALLOCATEd' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'ISEA_TO_JSEA ALLOCATEd' + FLUSH(740+IAPROC) +#endif if(istat /= 0) CALL PDLIB_ABORT(3) JSEA = 0 JX_TO_JSEA = 0 @@ -353,8 +381,10 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) END IF END DO ! -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'After JX_TO_JSEA, ISEA_TO_JSEA and friend computation' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'After JX_TO_JSEA, ISEA_TO_JSEA and friend computation' + FLUSH(740+IAPROC) +#endif ! ! Map a point in (1:PDLIB_NSEAL) to a point in (1:NSEA) ! @@ -368,8 +398,10 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) WRITE(*,*) 'nb=', nb, ' NSEA=', NSEA STOP END IF -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'nb / NSEA consistency check' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'nb / NSEA consistency check' + FLUSH(740+IAPROC) +#endif END IF FSGEOADVECT=.FALSE. IF ((FLCX .eqv. .TRUE.).and.(FLCY .eqv. .TRUE.)) THEN @@ -415,9 +447,11 @@ SUBROUTINE PDLIB_STYLE_INIT(IMOD) GRIDS(IMOD)%IOBP_loc(IP) = IOBP(IP_glob) GRIDS(IMOD)%IOBPD_loc(:,IP) = IOBPD(:,IP_glob) END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'ALLOCATEd(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) -!/DEBUGINIT WRITE(740+IAPROC,*) 'PDLIB_NSEALM=', PDLIB_NSEALM -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ALLOCATEd(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + WRITE(740+IAPROC,*) 'PDLIB_NSEALM=', PDLIB_NSEALM + FLUSH(740+IAPROC) +#endif ! WRITE(*,*) 'Begin, ComputeListNP_ListNPA_ListIPLG' CALL ComputeListNP_ListNPA_ListIPLG ALLOCATE(COFRM4(NK)) @@ -489,7 +523,9 @@ SUBROUTINE PDLIB_MAPSTA_INIT(IMOD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : INDEX_MAP, NBND_MAP, NSEA, NSEAL, MAPSTA, GRIDS, NX USE W3ODATMD, ONLY : IAPROC, NAPROC @@ -505,15 +541,21 @@ SUBROUTINE PDLIB_MAPSTA_INIT(IMOD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob INTEGER, INTENT(in) :: IMOD INTEGER :: Status(NX), istat -!/S CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') -!/DEBUGINIT WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC +#ifdef W3_S + CALL STRACE (IENT, 'PDLIB_MAPSTA_INIT') +#endif +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', IAPROC +#endif IF (IAPROC .gt. NAPROC) THEN RETURN END IF @@ -653,9 +695,13 @@ SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) ! 1.a Set constants ! -!/S CALL STRACE (IENT, 'W3XYPUG') -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Begin of PDLIB_W3XYPUG' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPUG') +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Begin of PDLIB_W3XYPUG' + FLUSH(740+IAPROC) +#endif ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH @@ -682,14 +728,18 @@ SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) AC(IP) = VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA) VLCFLX(IP) = CCOS * CG(IK,ISEA) / CLATS(ISEA) VLCFLY(IP) = CSIN * CG(IK,ISEA) -!/MGP VLCFLX(IP) = VLCFLX(IP) - CCURX*VGX/CLATS(ISEA) -!/MGP VLCFLY(IP) = VLCFLY(IP) - CCURY*VGY +#ifdef W3_MGP + VLCFLX(IP) = VLCFLX(IP) - CCURX*VGX/CLATS(ISEA) + VLCFLY(IP) = VLCFLY(IP) - CCURY*VGY +#endif END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, ' ITH=', ITH, ' IK=', IK -!/DEBUGSOLVER WRITE(740+IAPROC,*) '1: maxval(VLCFLX)=', maxval(VLCFLX) -!/DEBUGSOLVER WRITE(740+IAPROC,*) '1: maxval(VLCFLY)=', maxval(VLCFLY) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FLCUR=', FLCUR -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'ISP=', ISP, ' ITH=', ITH, ' IK=', IK + WRITE(740+IAPROC,*) '1: maxval(VLCFLX)=', maxval(VLCFLX) + WRITE(740+IAPROC,*) '1: maxval(VLCFLY)=', maxval(VLCFLY) + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + FLUSH(740+IAPROC) +#endif IF ( FLCUR ) THEN DO JSEA=1, NSEAL IP = JSEA @@ -735,8 +785,10 @@ SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) ! ! 4. propagate using the selected scheme ! -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'maxval(C)=', maxval(C) -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'maxval(C)=', maxval(C) + FLUSH(740+IAPROC) +#endif IF (FSN) THEN CALL PDLIB_W3XYPFSN2(ISP, C, LCALC, RD1, RD2, DTG, AC) ELSE IF (FSPSI) THEN @@ -753,8 +805,10 @@ SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) AC(IP) = AC_MAP(IBND_MAP) END DO END IF -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'After solutioning' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'After solutioning' + FLUSH(740+IAPROC) +#endif ! 6. Store results in VQ in proper format --------------------------- * ! @@ -764,8 +818,10 @@ SUBROUTINE PDLIB_W3XYPUG ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC ) ISEA=MAPFS(1,IP_glob) VA(ISP,JSEA) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*AC(IP) ) END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Leaving PDLIB_W3XYPUG' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Leaving PDLIB_W3XYPUG' + FLUSH(740+IAPROC) +#endif !/ !/ End of W3SPR4 ----------------------------------------------------- / !/ @@ -816,7 +872,9 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NK, NTH, NX, & IEN, CLATS, MAPSF, IOBPD, IOBP, IOBDP, IOBPA @@ -826,7 +884,9 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) USE W3TIMEMD, ONLY: DSEC21 USE W3ADATMD, ONLY: MPI_COMM_WCMP USE W3GDATMD, ONLY: NSEAL, DMIN, NSEA -!/REF1 USE W3GDATMD, ONLY: REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY: REFPARS +#endif USE YOWNODEPOOL, ONLY: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA, ipgl, iplg, npa, np use yowElementpool, ONLY: ne, INE use yowDatapool, ONLY: rtype @@ -851,8 +911,12 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) ! conditions LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of ! the max. Global Time step -!/S INTEGER, SAVE :: IENT = 0 -!/REF1 INTEGER(KIND=1) :: IOBPDR(NX) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_REF1 + INTEGER(KIND=1) :: IOBPDR(NX) +#endif INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK INTEGER :: IBI, NI(3) INTEGER :: JX @@ -878,17 +942,21 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) REAL :: eSumAC, sumAC, sumBPI0, sumBPIN, sumCG, sumCLATS LOGICAL :: testWrite REAL :: FIN(1), FOUT(1) -!/S CALL STRACE (IENT, 'W3XYPFSN') -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 1' -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER CALL GET_SCAL_INTEGRAL_COH_R4(AC, eSumAC) -!/DEBUGSOLVER testWrite=.FALSE. -!/DEBUGSOLVER IF (eSumAC .gt. 0) THEN -!/DEBUGSOLVER testWrite=.TRUE. -!/DEBUGSOLVER END IF -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC in input") -!/DEBUGSOLVER END IF +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSN') +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 1' + FLUSH(740+IAPROC) + CALL GET_SCAL_INTEGRAL_COH_R4(AC, eSumAC) + testWrite=.FALSE. + IF (eSumAC .gt. 0) THEN + testWrite=.TRUE. + END IF + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC in input") + END IF +#endif ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH @@ -901,15 +969,19 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) ! endif ! END DO ! -!/REF1 IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#ifdef W3_REF1 + IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#endif -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NX=', NX -!/DEBUGSOLVER DO IX=1,NX -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'IX/IOBP=', IX, IOBP(IX) -!/DEBUGSOLVER END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'sum(IOBP)=', sum(IOBP) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 2' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'NX=', NX + DO IX=1,NX + WRITE(740+IAPROC,*) 'IX/IOBP=', IX, IOBP(IX) + END DO + WRITE(740+IAPROC,*) 'sum(IOBP)=', sum(IOBP) + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 2' + FLUSH(740+IAPROC) +#endif ! !2 Propagation !2.a Calculate K-Values and contour based quantities ... @@ -942,8 +1014,10 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 3' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 3' + FLUSH(740+IAPROC) +#endif IF (LCALC) THEN KKSUM = ZERO DO IE = 1, NE @@ -969,30 +1043,40 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) ITER(IK,ITH) = ABS(NINT(CFLXY)) END IF END IF ! LCALC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4' + FLUSH(740+IAPROC) +#endif DO IP = 1, npa DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/PDLIB_SI(IP) ! Some precalculations for the time integration. END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.1' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.1' + FLUSH(740+IAPROC) +#endif !!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R8(PDLIB_SI, "PDLIB_SI in input") -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.2' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 4.2' + FLUSH(740+IAPROC) +#endif !!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R8(DTSI, "DTSI in input") -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 5' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ITER=', ITER(IK,ITH) -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 5' + WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH + WRITE(740+IAPROC,*) 'ITER=', ITER(IK,ITH) + FLUSH(740+IAPROC) +#endif DO IT = 1, ITER(IK,ITH) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'IT=', IT, ' ITER=', ITER(IK,ITH) -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'IT=', IT -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'IK=', IK, ' ITH=', ITH + WRITE(740+IAPROC,*) 'IT=', IT, ' ITER=', ITER(IK,ITH) + FLUSH(740+IAPROC) + IF (testWrite) THEN + WRITE(740+IAPROC,*) 'IT=', IT + FLUSH(740+IAPROC) + END IF +#endif U = DBLE(AC) ST = ZERO DO IE = 1, NE @@ -1000,9 +1084,11 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... END DO ! IE -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R8(ST, "ST in loop") -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R8(ST, "ST in loop") + END IF +#endif ! ! IOBPD=0 : waves coming from land ! IOBPD=1 : waves coming from the coast @@ -1010,20 +1096,28 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) DO IP = 1, npa IP_glob=iplg(IP) U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP_glob)))*DBLE(IOBPD(ITH,IP_glob))*IOBDP(IP_glob) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#endif END DO -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R8(U, "U in loop") -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R8(U, "U in loop") + END IF +#endif AC = REAL(U) -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC before synchronization") -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC before synchronization") + END IF +#endif CALL PDLIB_exchange1DREAL(AC) -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after synchronization") -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after synchronization") + END IF +#endif ! ! 5 Update boundaries ... would be better to omit any if clause in this loop ... ! a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI @@ -1038,42 +1132,52 @@ SUBROUTINE PDLIB_W3XYPFSN2(ISP, C, LCALC, RD10, RD20, DT, AC) RD1 = 0. RD2 = 1. END IF -!/DEBUGSOLVER sumAC=0 -!/DEBUGSOLVER sumBPI0=0 -!/DEBUGSOLVER sumBPIN=0 -!/DEBUGSOLVER sumCG=0 -!/DEBUGSOLVER sumCLATS=0 +#ifdef W3_DEBUGSOLVER + sumAC=0 + sumBPI0=0 + sumBPIN=0 + sumCG=0 + sumCLATS=0 +#endif DO IBI = 1, NBI IP_glob = MAPSF(ISBPI(IBI),1) JX=IPGL_npa(IP_glob) IF (JX .gt. 0) THEN AC(JX) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) -!/DEBUGSOLVER sumAC=sumAC + AC(JX) -!/DEBUGSOLVER sumBPI0=sumBPI0 + BBPI0(ISP,IBI) -!/DEBUGSOLVER sumBPIN=sumBPIN + BBPIN(ISP,IBI) -!/DEBUGSOLVER sumCG=sumCG + CG(IK,ISBPI(IBI)) -!/DEBUGSOLVER sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) +#ifdef W3_DEBUGSOLVER + sumAC=sumAC + AC(JX) + sumBPI0=sumBPI0 + BBPI0(ISP,IBI) + sumBPIN=sumBPIN + BBPIN(ISP,IBI) + sumCG=sumCG + CG(IK,ISBPI(IBI)) + sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) +#endif END IF END DO END IF -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NBI=', NBI -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0 -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'NBI=', NBI + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS + FLUSH(740+IAPROC) +#endif CALL PDLIB_exchange1DREAL(AC) -!/DEBUGSOLVER IF (testWrite) THEN -!/DEBUGSOLVER CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after FLBPI") -!/DEBUGSOLVER END IF +#ifdef W3_DEBUGSOLVER + IF (testWrite) THEN + CALL SCAL_INTEGRAL_PRINT_R4(AC, "AC after FLBPI") + END IF +#endif END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 6' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_W3XYPFSN2, step 6' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) @@ -1121,7 +1225,9 @@ SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NK, NTH, NX, & IEN, CLATS, MAPSF, IOBPD, IOBP, IOBPA, NNZ, IOBDP @@ -1130,7 +1236,9 @@ SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 USE W3GDATMD, ONLY: NSEAL, DMIN -!/REF1 USE W3GDATMD, ONLY: REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY: REFPARS +#endif USE W3ADATMD, ONLY: MPI_COMM_WCMP use yowElementpool, ONLY: ne, INE use YOWNODEPOOL, ONLY: PDLIB_IEN, PDLIB_TRIA, PDLIB_SI, iplg, npa @@ -1157,8 +1265,12 @@ SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) ! conditions LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of ! the max. Global Time step -!/REF1 INTEGER(KIND=1) :: IOBPDR(NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_REF1 + INTEGER(KIND=1) :: IOBPDR(NX) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK INTEGER :: IBI, NI(3), JX INTEGER :: ISPROC, IP_glob, JSEA, ierr @@ -1176,11 +1288,15 @@ SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) REAL :: KELEM(3,NE), FLALL(3,NE) REAL :: KKSUM(npa), ST(npa) REAL :: NM(NE) -!/S CALL STRACE (IENT, 'W3XYPFSN') +#ifdef W3_S + CALL STRACE (IENT, 'W3XYPFSN') +#endif ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH DTMAX = DBLE(10.E10) -!/REF1 IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#ifdef W3_REF1 + IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#endif DO IE = 1, NE I1 = INE(1,IE) I2 = INE(2,IE) @@ -1261,7 +1377,9 @@ SUBROUTINE PDLIB_W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC) DO IP = 1, npa IP_glob=iplg(IP) U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP_glob)))*DBLE(IOBPD(ITH,IP_glob))*IOBDP(IP_glob) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#endif END DO AC = REAL(U) ! @@ -1341,7 +1459,9 @@ SUBROUTINE HACK_CHECK(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY : NK, NTH USE W3WDATMD, ONLY : VA USE W3GDATMD, ONLY : NSPEC, NX, NY, NSEAL @@ -1355,7 +1475,9 @@ SUBROUTINE HACK_CHECK(string) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1363,7 +1485,9 @@ SUBROUTINE HACK_CHECK(string) INTEGER ITH_F, IK INTEGER ITH, ISP, JSEA REAL eVal, eErr -!/S CALL STRACE (IENT, 'HACK_CHECK') +#ifdef W3_S + CALL STRACE (IENT, 'HACK_CHECK') +#endif ITH_F=4 WRITE(740+IAPROC,*) 'HACK_CHECK, begin' DO ITH=1,NTH @@ -1437,7 +1561,9 @@ SUBROUTINE GET_SCAL_INTEGRAL_COH_R4(V, eSum) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY : NSEAL !/ IMPLICIT NONE @@ -1448,7 +1574,9 @@ SUBROUTINE GET_SCAL_INTEGRAL_COH_R4(V, eSum) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1459,7 +1587,9 @@ SUBROUTINE GET_SCAL_INTEGRAL_COH_R4(V, eSum) LOGICAL :: PrintFullValue = .FALSE. LOGICAL :: PrintBasicData = .FALSE. ! -!/S CALL STRACE (IENT, 'GET_SCAL_INTEGRAL_COH_R4') +#ifdef W3_S + CALL STRACE (IENT, 'GET_SCAL_INTEGRAL_COH_R4') +#endif V8 = DBLE(V) CALL SCAL_INTEGRAL_PRINT_GENERAL(eSum, V8, string, PrintFullValue, PrintBasicData) END SUBROUTINE @@ -1509,7 +1639,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R8(V, string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY : NSEAL !/ IMPLICIT NONE @@ -1520,7 +1652,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R8(V, string) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1531,7 +1665,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R8(V, string) LOGICAL :: PrintBasicData = .TRUE. REAL :: eSum ! -!/S CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_R8') +#ifdef W3_S + CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_R8') +#endif V8 = DBLE(V) CALL SCAL_INTEGRAL_PRINT_GENERAL(eSum, V8, string, PrintFullValue, PrintBasicData) END SUBROUTINE @@ -1581,7 +1717,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R4(V, string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY : NSEAL !/ IMPLICIT NONE @@ -1592,7 +1730,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R4(V, string) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1602,7 +1742,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_R4(V, string) LOGICAL :: PrintBasicData = .TRUE. REAL :: eSum ! -!/S CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_R4') +#ifdef W3_S + CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_R4') +#endif CALL SCAL_INTEGRAL_PRINT_GENERAL(eSum, V, string, PrintFullValue, PrintBasicData) END SUBROUTINE !/ ------------------------------------------------------------------- / @@ -1651,7 +1793,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL(eSum, V, string, PrintFullValue, PrintBas ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY : NK, NTH, FTE USE W3GDATMD, ONLY : NSPEC, NX, NY, NSEAL, MAPFS USE W3ADATMD, ONLY : MPI_COMM_WCMP @@ -1670,7 +1814,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL(eSum, V, string, PrintFullValue, PrintBas !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1687,7 +1833,9 @@ SUBROUTINE SCAL_INTEGRAL_PRINT_GENERAL(eSum, V, string, PrintFullValue, PrintBas INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob INTEGER nbIncorr INTEGER ITH, IK -!/S CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_GENERAL') +#ifdef W3_S + CALL STRACE (IENT, 'SCAL_INTEGRAL_PRINT_GENERAL') +#endif WRITE(740+IAPROC,*) 'IAPROC=', IAPROC WRITE(740+IAPROC,*) 'NAPROC=', NAPROC WRITE(740+IAPROC,*) 'NTPROC=', NTPROC @@ -1825,7 +1973,9 @@ SUBROUTINE ALL_VAOLD_INTEGRAL_PRINT(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NSEAL USE W3WDATMD, ONLY : VAOLD @@ -1892,7 +2042,9 @@ SUBROUTINE ALL_VA_INTEGRAL_PRINT(IMOD, string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NSEAL, NSEA, NX, NY USE W3WDATMD, ONLY : VA @@ -1988,7 +2140,9 @@ SUBROUTINE ALL_FIELD_INTEGRAL_PRINT(FIELD, string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NSEAL USE W3WDATMD, ONLY : VA @@ -2052,7 +2206,9 @@ SUBROUTINE ALL_FIELD_INTEGRAL_PRINT_GENERAL(FIELD, string, PrintHs, PrintHsNode, ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : CLATS, SIG USE W3ADATMD, ONLY : CG @@ -2306,7 +2462,9 @@ SUBROUTINE TEST_MPI_STATUS(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ADATMD, ONLY : MPI_COMM_WCMP USE W3GDATMD, ONLY : GTYPE, UNGTYPE @@ -2392,7 +2550,9 @@ SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8(TheARR, string, maxidx) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NSPEC USE YOWNODEPOOL, ONLY: npa @@ -2454,7 +2614,9 @@ SUBROUTINE CHECK_ARRAY_INTEGRAL_NX_R8_MaxFunct(TheARR, string, maxidx, PrintMinI ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NK, NTH USE W3WDATMD, ONLY : VA @@ -2648,7 +2810,9 @@ SUBROUTINE COLLECT_AND_PRINT(V, ifile) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX, NSEAL, NSEA USE W3ADATMD, ONLY: MPI_COMM_WCMP @@ -2701,9 +2865,11 @@ SUBROUTINE COLLECT_AND_PRINT(V, ifile) FLUSH(740+IAPROC) STOP END IF -!/DEBUGSOLVER DO I=1,NX -!/DEBUGSOLVER WRITE(ifile,*) 'I=', I, ' var=', Vcoll(I) -!/DEBUGSOLVER END DO +#ifdef W3_DEBUGSOLVER + DO I=1,NX + WRITE(ifile,*) 'I=', I, ' var=', Vcoll(I) + END DO +#endif END IF END SUBROUTINE !/ ------------------------------------------------------------------- / @@ -2752,7 +2918,9 @@ SUBROUTINE DOMAIN_INTEGRAL(V, eScal) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX USE W3ADATMD, ONLY: MPI_COMM_WCMP @@ -2833,7 +3001,9 @@ SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NK, NTH, NX, & IEN, CLATS, MAPSF, IOBPD, IOBP, TRIA, IOBDP @@ -2842,7 +3012,9 @@ SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, ISBPI, BBPI0, BBPIN USE W3TIMEMD, ONLY: DSEC21 USE W3GDATMD, ONLY: NSEAL, IOBPA -!/REF1 USE W3GDATMD, ONLY: REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY: REFPARS +#endif USE W3ADATMD, ONLY: MPI_COMM_WCMP use yowElementpool, ONLY: ne, INE use YOWNODEPOOL, ONLY: PDLIB_SI, PDLIB_IEN, PDLIB_TRIA @@ -2891,11 +3063,15 @@ SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) REAL :: NM(NE) INTEGER :: ISproc, IP_glob, JSEA, ierr REAL :: eScal -!/REF1 INTEGER(KIND=1) :: IOBPDR(NX) +#ifdef W3_REF1 + INTEGER(KIND=1) :: IOBPDR(NX) +#endif ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH DTMAX = DBLE(10.E10) -!/REF1 IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#ifdef W3_REF1 + IOBPDR(:)=(1-IOBP(:))*(1-IOBPD(ITH,:)) +#endif DO IE = 1, NE I1 = INE(1,IE) ! Index of the Element Nodes I2 = INE(2,IE) @@ -3022,7 +3198,9 @@ SUBROUTINE PDLIB_W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC) DO IP = 1,npa IP_glob=iplg(IP) U(IP) = MAX(ZERO,U(IP)-DTSI(IP)*ST(IP)*(1-IOBPA(IP_glob)))*DBLE(IOBPD(ITH,IP_glob))*IOBDP(IP_glob) -!/REF1 IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#ifdef W3_REF1 + IF (REFPARS(3).LT.0.5.AND.IOBPD(ITH,IP_glob).EQ.0.AND.IOBPA(IP_glob).EQ.0) U(IP) = AC(IP) ! restores reflected boundary values +#endif END DO AC = REAL(U) ! @@ -3108,15 +3286,19 @@ SUBROUTINE PDLIB_W3XYPUG_BLOCK_IMPLICIT(FACX, FACY, DTG, VGX, VGY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY: IAPROC USE W3GDATMD, ONLY: B_JGS_USE_JACOBI IMPLICIT NONE REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY INTEGER DoSomething -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_USE_JACOBI=', B_JGS_USE_JACOBI -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'B_JGS_USE_JACOBI=', B_JGS_USE_JACOBI + FLUSH(740+IAPROC) +#endif DoSomething=0 IF (B_JGS_USE_JACOBI) THEN CALL PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) @@ -3176,7 +3358,9 @@ SUBROUTINE PDLIB_W3XYPUG_BLOCK_EXPLICIT(FACX, FACY, DTG, VGX, VGY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY: IAPROC USE W3GDATMD, ONLY: B_JGS_USE_JACOBI @@ -3233,7 +3417,9 @@ SUBROUTINE PRINT_WN_STATISTIC(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY : IAPROC @@ -3312,7 +3498,9 @@ SUBROUTINE WRITE_VAR_TO_TEXT_FILE(TheArr, eFile) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : NK, NTH USE W3WDATMD, ONLY : VA @@ -3443,7 +3631,9 @@ SUBROUTINE PrintTotalOffContrib(string) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE YOWNODEPOOL, ONLY: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P USE W3GDATMD, ONLY: NSPEC @@ -3529,20 +3719,30 @@ SUBROUTINE COMPUTE_MEAN_PARAM (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK) REAL, INTENT(OUT) :: EMEAN, FMEAN, WNMEAN, AMAX INTEGER :: IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: EB(NK), EBAND -!/S CALL STRACE (IENT, 'W3SPR0') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR0') +#endif ! EMEAN = 0. FMEAN = 0. @@ -3581,13 +3781,17 @@ SUBROUTINE COMPUTE_MEAN_PARAM (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 ! -!/T WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#ifdef W3_T + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +#endif !/ !/ End of W3SPR0 ----------------------------------------------------- / !/ @@ -3638,14 +3842,18 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, FACHFA, IOBPD, DMIN USE W3GDATMD, ONLY: NSEAL, IOBDP, IOBPA, CLATS USE W3GDATMD, ONLY: MAPSTA USE W3WDATMD, ONLY: VA USE W3ADATMD, ONLY: CG, DW, WN, CX, CY -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD, ONLY: FLCUR USE W3GDATMD, ONLY: ECOS, ESIN, MAPFS USE W3PARALL, ONLY : ONESIXTH, ZERO, THR @@ -3657,16 +3865,36 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) USE W3GDATMD, ONLY: IOBP USE W3ODATMD, ONLY : IAPROC USE W3PARALL, ONLY : ZERO -!/MEMCHECK USE MallocInfo_m -!/DB1 USE W3SDB1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/TR1 USE W3STR1MD +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif implicit none REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY INTEGER :: IP, ISP, ISEA, IP_glob @@ -3675,7 +3903,9 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) INTEGER :: IE, POS, JSEA INTEGER :: I1, I2, I3, NI(3) INTEGER :: counter -!/REF1 INTEGER :: eIOBPDR +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif INTEGER :: POS_TRICK(3,2) REAL :: DTK, TMP3 REAL :: LAMBDA(2) @@ -3699,8 +3929,10 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) POS_TRICK(3,1) = 1 POS_TRICK(3,2) = 2 -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'calcARRAY_JACOBI, begin' + FLUSH(740+IAPROC) +#endif !!/DEBUGSRC DO JSEA=1,NSEAL !!/DEBUGSRC WRITE(740+IAPROC,*) 'JSEA=', JSEA @@ -3716,9 +3948,11 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) DTK = 0 TMP3 = 0 -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif DO IE = 1, NE I1 = INE(1,IE) @@ -3736,8 +3970,10 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) CXY(:,1) = CXY(:,1) + FACX * CX(NI)/CLATS(NI) CXY(:,2) = CXY(:,2) + FACY * CY(NI) ENDIF -!/MGP CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) -!/MGP CXY(:,2) = CXY(:,2) - CCURY*VGY +#ifdef W3_MGP + CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) + CXY(:,2) = CXY(:,2) - CCURY*VGY +#endif FL11 = CXY(2,1)*PDLIB_IEN(1,IE)+CXY(2,2)*PDLIB_IEN(2,IE) FL12 = CXY(3,1)*PDLIB_IEN(1,IE)+CXY(3,2)*PDLIB_IEN(2,IE) FL21 = CXY(3,1)*PDLIB_IEN(3,IE)+CXY(3,2)*PDLIB_IEN(4,IE) @@ -3769,15 +4005,19 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) I1 = PDLIB_POSI(1,J) I2 = PDLIB_POSI(2,J) I3 = PDLIB_POSI(3,J) -!/DEBUGSRC WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'I1=', I1, ' PDLIB_I_DIAG=', PDLIB_I_DIAG(IP) +#endif DO ISP=1,NSPEC ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH K1 = KP(POS,ISP,IE) -!/REF1 eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) -!/REF1 IF (eIOBPDR .eq. 1) THEN -!/REF1 K1=ZERO -!/REF1 END IF +#ifdef W3_REF1 + eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) + IF (eIOBPDR .eq. 1) THEN + K1=ZERO + END IF +#endif TRIA03= 1./3. * PDLIB_TRIA(IE) DTK = K1 * DTG * IOBPD(ITH,IP_glob) * (1-IOBPA(IP_glob)) TMP3 = DTK * NM(ISP,IE) @@ -3793,11 +4033,15 @@ SUBROUTINE calcARRAY_JACOBI(DTG,FACX,FACY,VGX,VGY) END DO END DO -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) -!/DEBUGSOLVER CALL PrintTotalOffContrib("Offdiag after the geo advection") +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'sum(VA)=', sum(VA) + CALL PrintTotalOffContrib("Offdiag after the geo advection") +#endif !/ !/ End of W3XYPFSN ----------------------------------------------------- / !/ @@ -3848,7 +4092,9 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, FACHFA, IOBPD, DMIN @@ -3856,8 +4102,10 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) USE W3GDATMD, ONLY: MAPSTA USE W3WDATMD, ONLY: VA, VAOLD USE W3ADATMD, ONLY: CG, DW, WN, CX, CY -!/MEMCHECK USE MallocInfo_m -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE MallocInfo_m + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD, ONLY: FLCUR USE W3GDATMD, ONLY: ECOS, ESIN, MAPFS USE W3PARALL, ONLY : ONESIXTH, ZERO, THR, IMEM @@ -3868,15 +4116,33 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) PDLIB_I_DIAG, PDLIB_JA USE W3GDATMD, ONLY: IOBP USE W3ODATMD, ONLY : IAPROC -!/DB1 USE W3SDB1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/TR1 USE W3STR1MD +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif implicit none REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY INTEGER :: IP, ISP, ISEA, IP_glob @@ -3885,7 +4151,9 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) INTEGER :: IE, POS, JSEA INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) INTEGER :: counter -!/REF1 INTEGER :: eIOBPDR +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif INTEGER :: POS_TRICK(3,2), IP1, IP2, IPP1, IPP2 REAL :: DTK, TMP3 REAL :: LAMBDA(2) @@ -3903,9 +4171,11 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) REAL :: TRIA03, SIDT, CCOS, CSIN REAL :: SPEC(NSPEC), DEPTH -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif POS_TRICK(1,1) = 2 POS_TRICK(1,2) = 3 @@ -3944,8 +4214,10 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) CXY(:,1) = CXY(:,1) + FACX * CX(NI_ISEA)/CLATS(NI_ISEA) CXY(:,2) = CXY(:,2) + FACY * CY(NI_ISEA) ENDIF -!/MGP CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) -!/MGP CXY(:,2) = CXY(:,2) - CCURY*VGY +#ifdef W3_MGP + CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) + CXY(:,2) = CXY(:,2) - CCURY*VGY +#endif FL11 = CXY(2,1)*IEN_LOCAL(1)+CXY(2,2)*IEN_LOCAL(2) FL12 = CXY(3,1)*IEN_LOCAL(1)+CXY(3,2)*IEN_LOCAL(2) FL21 = CXY(3,1)*IEN_LOCAL(3)+CXY(3,2)*IEN_LOCAL(4) @@ -3965,10 +4237,12 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) KM(:) = MIN(ZERO,K(:)) NM = 1.d0/MIN(-THR,SUM(KM)) K1 = KP(POS) -!/REF1 eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) -!/REF1 IF (eIOBPDR .eq. 1) THEN -!/REF1 K1=ZERO -!/REF1 END IF +#ifdef W3_REF1 + eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) + IF (eIOBPDR .eq. 1) THEN + K1=ZERO + END IF +#endif TRIA03 = 1./3. * PDLIB_TRIA(IE) DTK = K1 * DTG * IOBDP(IP_glob) * IOBPD(ITH,IP_glob) * (1-IOBPA(IP_glob)) TMP3 = DTK * NM @@ -3984,9 +4258,11 @@ SUBROUTINE calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) END DO END DO -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_JACOBI SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif !/ !/ End of W3XYPFSN ----------------------------------------------------- / !/ @@ -4037,14 +4313,18 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, FACHFA, IOBPD, DMIN USE W3GDATMD, ONLY: NSEAL, IOBDP, IOBPA, CLATS USE W3GDATMD, ONLY: MAPSTA USE W3WDATMD, ONLY: VA, VAOLD USE W3ADATMD, ONLY: CG, DW, WN, CX, CY -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD, ONLY: FLCUR USE W3GDATMD, ONLY: ECOS, ESIN, MAPFS USE W3PARALL, ONLY : ONESIXTH, ZERO, THR, ONETHIRD @@ -4055,16 +4335,36 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O PDLIB_I_DIAG, PDLIB_JA USE W3GDATMD, ONLY: IOBP USE W3ODATMD, ONLY : IAPROC -!/MEMCHECK USE MallocInfo_m -!/DB1 USE W3SDB1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/TR1 USE W3STR1MD +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif implicit none INTEGER, INTENT(IN) :: IP INTEGER, INTENT(INOUT) :: J @@ -4076,7 +4376,9 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O INTEGER :: IE, POS, JSEA INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) INTEGER :: counter -!/REF1 INTEGER :: eIOBPDR +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif INTEGER :: POS_TRICK(3,2) REAL*8 :: DTK, TMP3 REAL*8 :: LAMBDA(2) @@ -4134,8 +4436,10 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O CXY(:,2) = CXY(:,2) + FACY * CY(NI_ISEA) ENDIF -!/MGP CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) -!/MGP CXY(:,2) = CXY(:,2) - CCURY*VGY +#ifdef W3_MGP + CXY(:,1) = CXY(:,1) - CCURX*VGX/CLATS(ISEA) + CXY(:,2) = CXY(:,2) - CCURY*VGY +#endif FL11 = CXY(2,1)*IEN_LOCAL(1)+CXY(2,2)*IEN_LOCAL(2) FL12 = CXY(3,1)*IEN_LOCAL(1)+CXY(3,2)*IEN_LOCAL(2) FL21 = CXY(3,1)*IEN_LOCAL(3)+CXY(3,2)*IEN_LOCAL(4) @@ -4154,10 +4458,12 @@ SUBROUTINE calcARRAY_JACOBI3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O DELTAL(:) = CRFS(:) - KP(:) KM(:) = MIN(ZERO,K(:)) NM = 1.d0/MIN(-THR,SUM(KM)) -!/REF1 eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) -!/REF1 IF (eIOBPDR .eq. 1) THEN -!/REF1 K1=ZERO -!/REF1 END IF +#ifdef W3_REF1 + eIOBPDR=(1-IOBP(IP_glob))*(1-IOBPD(ITH,IP_glob)) + IF (eIOBPDR .eq. 1) THEN + K1=ZERO + END IF +#endif TRIA03 = ONETHIRD * PDLIB_TRIA(IE) DTK = KP(POS) * DBLE(DTG) * IOBDP(IP_glob) * IOBPD(ITH,IP_glob) * (1-IOBPA(IP_glob)) TMP3 = DTK * NM @@ -4223,14 +4529,18 @@ SUBROUTINE calcARRAY_JACOBI4(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, FACHFA, IOBPD, DMIN USE W3GDATMD, ONLY: NSEAL, IOBDP, IOBPA, CLATS USE W3GDATMD, ONLY: MAPSTA, NK USE W3WDATMD, ONLY: VA, VAOLD USE W3ADATMD, ONLY: CG, DW, WN, CX, CY -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD, ONLY: FLCUR USE W3GDATMD, ONLY: ECOS, ESIN, MAPFS USE W3PARALL, ONLY : ONESIXTH, ZERO, THR, ONETHIRD @@ -4241,16 +4551,36 @@ SUBROUTINE calcARRAY_JACOBI4(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O PDLIB_I_DIAG, PDLIB_JA USE W3GDATMD, ONLY: IOBP USE W3ODATMD, ONLY : IAPROC -!/MEMCHECK USE MallocInfo_m -!/DB1 USE W3SDB1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/TR1 USE W3STR1MD +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif implicit none INTEGER, INTENT(IN) :: IP INTEGER, INTENT(INOUT) :: J @@ -4263,7 +4593,9 @@ SUBROUTINE calcARRAY_JACOBI4(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_O INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) INTEGER :: ISP, IP_glob, IPP1, IPP2 INTEGER :: counter -!/REF1 INTEGER :: eIOBPDR +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif INTEGER :: POS_TRICK(3,2) REAL*8 :: DTK, TMP3 REAL*8 :: LAMBDA(2) @@ -4437,7 +4769,9 @@ SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, FACHFA, IOBPD, DMIN @@ -4445,7 +4779,9 @@ SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) USE W3GDATMD, ONLY: MAPSTA, NK USE W3WDATMD, ONLY: VA, VAOLD USE W3ADATMD, ONLY: CG, DW, WN, CX, CY -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD, ONLY: FLCUR USE W3GDATMD, ONLY: ECOS, ESIN, MAPFS USE W3PARALL, ONLY : ONESIXTH, ZERO, THR, ONETHIRD @@ -4456,16 +4792,36 @@ SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) PDLIB_I_DIAG, PDLIB_JA USE W3GDATMD, ONLY: IOBP USE W3ODATMD, ONLY : IAPROC -!/MEMCHECK USE MallocInfo_m -!/DB1 USE W3SDB1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/TR1 USE W3STR1MD +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif implicit none INTEGER, INTENT(IN) :: IE REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY @@ -4476,7 +4832,9 @@ SUBROUTINE calcARRAY_JACOBI5(IE,DTG,FACX,FACY,VGX,VGY) INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3) INTEGER :: ISP, IP_glob, IPP1, IPP2 INTEGER :: counter -!/REF1 INTEGER :: eIOBPDR +#ifdef W3_REF1 + INTEGER :: eIOBPDR +#endif INTEGER :: POS_TRICK(3,2) REAL :: DTK(3), TMP3(NSPEC,3) REAL :: LAMBDA(2) @@ -4632,7 +4990,9 @@ SUBROUTINE calcARRAY_JACOBI_SPECTRAL(DTG,ASPAR_DIAG_LOCAL) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT USE W3ODATMD, ONLY : IAPROC @@ -4699,7 +5059,9 @@ SUBROUTINE calcARRAY_JACOBI_SPECTRAL(DTG,ASPAR_DIAG_LOCAL) IF (FreqShiftMethod .eq. 2) THEN IF (MAPSTA(1,IP_glob) .eq. 1.and.IOBP(IP_glob).eq.1) THEN CALL PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'sum(CWNB_M2)=', sum(CWNB_M2) +#endif DO ITH=1,NTH DO IK=1,NK ISP = ITH + (IK-1)*NTH @@ -4740,8 +5102,10 @@ SUBROUTINE calcARRAY_JACOBI_SPECTRAL(DTG,ASPAR_DIAG_LOCAL) ELSE CAD=ZERO END IF -!/DEBUGREFRACTION WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA -!/DEBUGREFRACTION WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) +#ifdef W3_DEBUGREFRACTION + WRITE(740+IAPROC,*) 'refraction IP=', IP, ' ISEA=', ISEA + WRITE(740+IAPROC,*) 'sum(abs(CAD))=', sum(abs(CAD)) +#endif CAD_THE(:,IP)=CAD CP_THE = DTG*MAX(ZERO,CAD) CM_THE = DTG*MIN(ZERO,CAD) @@ -4801,7 +5165,9 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE(DTG,ASPAR_DIAG_LOCAL) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY : IAPROC USE YOWNODEPOOL, ONLY: iplg, PDLIB_SI, PDLIB_I_DIAG, NPA, NP @@ -4811,7 +5177,9 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE(DTG,ASPAR_DIAG_LOCAL) USE W3GDATMD, ONLY: IOBP, MAPSTA, FACP, SIG, IOBPD, IOBPA, IOBDP USE W3PARALL, ONLY: IMEM USE W3GDATMD, ONLY: NSEAL, CLATS -!/DB1 USE W3SDB1MD +#ifdef W3_DB1 + USE W3SDB1MD +#endif USE W3WDATMD, ONLY: VA, VSTOT, VDTOT, SHAVETOT USE constants, ONLY : TPI, TPIINV, GRAV IMPLICIT NONE @@ -4846,18 +5214,20 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE(DTG,ASPAR_DIAG_LOCAL) eSI = PDLIB_SI(IP) SIDT = eSI * DTG DEPTH = DW(ISEA) -!/DB1 VSDB = 0. -!/DB1 VDDB = 0. -!/DB1 CG1 = CG(1:NK,ISEA) -!/DB1 WN1 = WN(1:NK,ISEA) -!/DB1 DO IK=1,NK -!/DB1 DO ITH=1,NTH -!/DB1 ISP=ITH + (IK-1)*NTH -!/DB1 SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) -!/DB1 ENDDO -!/DB1 ENDDO -!/DB1 CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/DB1 CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) +#ifdef W3_DB1 + VSDB = 0. + VDDB = 0. + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) + ENDDO + ENDDO + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) +#endif ! IF (JSEA == 10000) WRITE(*,'(2I20,10F20.10)') JSEA, ISEA, SUM(VSTOT(:,JSEA)), SUM(VDTOT(:,JSEA)), SUM(VSDB),SUM(VDDB), DEPTH, EMEAN, FMEAN, WNMEAN DO IK=1,NK DO ITH=1,NTH @@ -4873,8 +5243,10 @@ SUBROUTINE CALCARRAY_JACOBI_SOURCE(DTG,ASPAR_DIAG_LOCAL) END IF eVS = PreVS / CG(IK,ISEA) * CLATS(ISEA) eVD = DBLE(VDTOT(ISP,JSEA)) -!/DB1 eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) -!/DB1 eVD = evD + DBLE(VDDB(ISP)) +#ifdef W3_DB1 + eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) + eVD = evD + DBLE(VDDB(ISP)) +#endif B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * (eVS - eVD*VA(ISP,JSEA)) IF (IMEM == 1) THEN ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - SIDT * eVD @@ -4935,7 +5307,9 @@ SUBROUTINE calcARRAY_JACOBI_SOURCE_LOCAL(DTG,ASPAR_DIAG_SOURCE, B_JAC_SOURCE) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY : IAPROC USE YOWNODEPOOL, ONLY: iplg, PDLIB_SI, PDLIB_I_DIAG @@ -4945,7 +5319,9 @@ SUBROUTINE calcARRAY_JACOBI_SOURCE_LOCAL(DTG,ASPAR_DIAG_SOURCE, B_JAC_SOURCE) USE W3GDATMD, ONLY: IOBP, MAPSTA, FACP, SIG, IOBPD, IOBPA, IOBDP USE W3GDATMD, ONLY: NSEAL, CLATS USE W3WDATMD, ONLY: VA, VSTOT, VDTOT, SHAVETOT -!/DB1 USE W3SDB1MD +#ifdef W3_DB1 + USE W3SDB1MD +#endif USE constants, ONLY : TPI, TPIINV, GRAV IMPLICIT NONE REAL, INTENT(in) :: DTG @@ -4977,17 +5353,19 @@ SUBROUTINE calcARRAY_JACOBI_SOURCE_LOCAL(DTG,ASPAR_DIAG_SOURCE, B_JAC_SOURCE) eSI = PDLIB_SI(IP) SIDT = eSI * DTG DEPTH = DW(ISEA) -!/DB1 CG1 = CG(1:NK,ISEA) -!/DB1 WN1 = WN(1:NK,ISEA) -!/DB1 DO IK=1,NK -!/DB1 DO ITH=1,NTH -!/DB1 ISP=ITH + (IK-1)*NTH -!/DB1 SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) -!/DB1 ENDDO -!/DB1 ENDDO -!/DB1 SPEC_VA = VA(:,JSEA) -!/DB1 CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/DB1 CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) +#ifdef W3_DB1 + CG1 = CG(1:NK,ISEA) + WN1 = WN(1:NK,ISEA) + DO IK=1,NK + DO ITH=1,NTH + ISP=ITH + (IK-1)*NTH + SPEC_VA(ISP) = VA(ISP,JSEA) * CG(IK,ISEA) / CLATS(ISEA) + ENDDO + ENDDO + SPEC_VA = VA(:,JSEA) + CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) +#endif DO IK=1,NK DO ITH=1,NTH ISP=ITH + (IK-1)*NTH @@ -5002,8 +5380,10 @@ SUBROUTINE calcARRAY_JACOBI_SOURCE_LOCAL(DTG,ASPAR_DIAG_SOURCE, B_JAC_SOURCE) END IF eVS = DBLE(PreVS) / CG(IK,ISEA) * CLATS(ISEA) eVD = DBLE(VDTOT(ISP,JSEA)) -!/DB1 eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) -!/DB1 eVD = eVD + DBLE(VDDB(ISP)) +#ifdef W3_DB1 + eVS = eVS + DBLE(VSDB(ISP)) / CG(IK,ISEA) * CLATS(ISEA) + eVD = eVD + DBLE(VDDB(ISP)) +#endif B_JAC_SOURCE(ISP) = B_JAC_SOURCE(ISP) + SIDT * (eVS - eVD*VA(ISP,IP)) ASPAR_DIAG_SOURCE(ISP) = ASPAR_DIAG_SOURCE(ISP) - SIDT * eVD END DO @@ -5060,22 +5440,40 @@ SUBROUTINE ADD_SOURCE_TERMS_NONLINEAR(DTG) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY : IAPROC USE YOWNODEPOOL, ONLY: iplg, PDLIB_SI, PDLIB_I_DIAG USE W3ADATMD, ONLY: CG, DW, WN, BEDFORMS, TAUBBL USE W3GDATMD, ONLY: NK, NTH, NSPEC, MAPFS, optionCall, DMIN USE W3GDATMD, ONLY: IOBP, MAPSTA, IOBDP, IOBPA -!/BT4 USE W3GDATMD, ONLY: SED_D50, SED_PSIC +#ifdef W3_BT4 + USE W3GDATMD, ONLY: SED_D50, SED_PSIC +#endif USE W3GDATMD, ONLY: NSEAL, CLATS USE W3WDATMD, ONLY: VA, VSTOT, VDTOT, SHAVETOT -!/DB1 USE W3SDB1MD -!/TR1 USE W3STR1MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/BS1 USE W3SBS1MD +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_BS1 + USE W3SBS1MD +#endif !/ IMPLICIT NONE !/ @@ -5085,7 +5483,9 @@ SUBROUTINE ADD_SOURCE_TERMS_NONLINEAR(DTG) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -5098,12 +5498,24 @@ SUBROUTINE ADD_SOURCE_TERMS_NONLINEAR(DTG) INTEGER :: ITH, IK, ISP REAL :: PreVS, AMAX, EMEAN, FMEAN, WNMEAN, D50, PSIC, TMP1(2), TMP2(3) LOGICAL :: LBREAK -!/DB1 REAL :: VSDB(NSPEC), VDDB(NSPEC) -!/TR1 REAL :: VSTR(NSPEC), VDTR(NSPEC) -!/BT1 REAL :: VSBT(NSPEC), VDBT(NSPEC) -!/BT4 REAL :: VSBT(NSPEC), VDBT(NSPEC) -!/BS1 REAL :: VSBS(NSPEC), VDBS(NSPEC) -!/S CALL STRACE (IENT, 'ADD_SOURCE_TERMS_NONLINEAR') +#ifdef W3_DB1 + REAL :: VSDB(NSPEC), VDDB(NSPEC) +#endif +#ifdef W3_TR1 + REAL :: VSTR(NSPEC), VDTR(NSPEC) +#endif +#ifdef W3_BT1 + REAL :: VSBT(NSPEC), VDBT(NSPEC) +#endif +#ifdef W3_BT4 + REAL :: VSBT(NSPEC), VDBT(NSPEC) +#endif +#ifdef W3_BS1 + REAL :: VSBS(NSPEC), VDBS(NSPEC) +#endif +#ifdef W3_S + CALL STRACE (IENT, 'ADD_SOURCE_TERMS_NONLINEAR') +#endif DO JSEA=1,NSEAL IP = JSEA IP_glob = iplg(IP) @@ -5116,43 +5528,85 @@ SUBROUTINE ADD_SOURCE_TERMS_NONLINEAR(DTG) SPEC_VA = VA(:,JSEA) CALL COMPUTE_MEAN_PARAM(SPEC_VA, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/DB1 VSDB = 0. -!/TR1 VSTR = 0. -!/BT1 VSBT = 0. -!/DB1 VDDB = 0. -!/TR1 VDTR = 0. -!/BT1 VDBT = 0. +#ifdef W3_DB1 + VSDB = 0. +#endif +#ifdef W3_TR1 + VSTR = 0. +#endif +#ifdef W3_BT1 + VSBT = 0. +#endif +#ifdef W3_DB1 + VDDB = 0. +#endif +#ifdef W3_TR1 + VDTR = 0. +#endif +#ifdef W3_BT1 + VDBT = 0. +#endif -!/TR1 CALL W3STR1 ( SPEC_VA, CG1, WN1, DEPTH, IX,VSTR, VDTR ) +#ifdef W3_TR1 + CALL W3STR1 ( SPEC_VA, CG1, WN1, DEPTH, IX,VSTR, VDTR ) +#endif -!/DB1 CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) -!/BT1 CALL W3SBT1 ( SPEC_VA, CG1, WN1, DEPTH, VSBT, VDBT ) +#ifdef W3_DB1 + CALL W3SDB1 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, LBREAK, VSDB, VDDB ) +#endif +#ifdef W3_BT1 + CALL W3SBT1 ( SPEC_VA, CG1, WN1, DEPTH, VSBT, VDBT ) +#endif -!/BT4 D50=SED_D50(ISEA) -!/BT4 PSIC=SED_PSIC(ISEA) -!/BT4 TMP1=TAUBBL(JSEA,1:2) -!/BT4 TMP2=BEDFORMS(JSEA,1:3) -!/BT4 CALL W3SBT4 ( SPEC_VA, CG1, WN1, DEPTH, D50, PSIC, TMP1,TMP2, VSBT, VDBT, IX, IY ) +#ifdef W3_BT4 + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) + TMP1=TAUBBL(JSEA,1:2) + TMP2=BEDFORMS(JSEA,1:3) + CALL W3SBT4 ( SPEC_VA, CG1, WN1, DEPTH, D50, PSIC, TMP1,TMP2, VSBT, VDBT, IX, IY ) +#endif -!/BT8 CALL W3SBT8 ( SPEC_VA, DEPTH, VSBT, VDBT, IX, IY ) -!/BT9 CALL W3SBT9 ( SPEC_VA, DEPTH, VSBT, VDBT, IX, IY ) -! -!/BS1 CALL W3SBS1 ( SPEC_VA, CG1, WN1, DEPTH, CX, CY,TAUSCX, TAUSCY, VSBS, VDBS ) +#ifdef W3_BT8 + CALL W3SBT8 ( SPEC_VA, DEPTH, VSBT, VDBT, IX, IY ) +#endif +#ifdef W3_BT9 + CALL W3SBT9 ( SPEC_VA, DEPTH, VSBT, VDBT, IX, IY ) +#endif +! +#ifdef W3_BS1 + CALL W3SBS1 ( SPEC_VA, CG1, WN1, DEPTH, CX, CY,TAUSCX, TAUSCY, VSBS, VDBS ) +#endif DO IK=1,NK DO ITH=1,NTH ISP=ITH + (IK-1)*NTH PreVS=0 eVD=0 -!/DB1 PreVS = PreVS + VSDB(ISP) -!/TR1 PreVS = PreVS + VSTR(ISP) -!/BT1 PreVS = PreVS + VSBT(ISP) -!/BS1 PreVS = PreVS + VSBS(ISP) +#ifdef W3_DB1 + PreVS = PreVS + VSDB(ISP) +#endif +#ifdef W3_TR1 + PreVS = PreVS + VSTR(ISP) +#endif +#ifdef W3_BT1 + PreVS = PreVS + VSBT(ISP) +#endif +#ifdef W3_BS1 + PreVS = PreVS + VSBS(ISP) +#endif eVS=DBLE(PreVS) / CG(IK,ISEA) * CLATS(ISEA) -!/DB1 eVD=eVD+DBLE(MIN(0., VDDB(ISP))) -!/TR1 eVD=eVD+DBLE(MIN(0., VDTR(ISP))) -!/BT1 eVD=eVD+DBLE(MIN(0., VDBT(ISP))) -!/BS1 eVD=eVD+DBLE(MIN(0., VDBS(ISP))) +#ifdef W3_DB1 + eVD=eVD+DBLE(MIN(0., VDDB(ISP))) +#endif +#ifdef W3_TR1 + eVD=eVD+DBLE(MIN(0., VDTR(ISP))) +#endif +#ifdef W3_BT1 + eVD=eVD+DBLE(MIN(0., VDBT(ISP))) +#endif +#ifdef W3_BS1 + eVD=eVD+DBLE(MIN(0., VDBS(ISP))) +#endif IF (optionCall .eq. 1) THEN B_JAC(ISP,IP) = B_JAC(ISP,IP) + SIDT * eVS ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) = ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) - SIDT * eVD @@ -5213,7 +5667,9 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION_VA ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE yowRankModule, ONLY : IPGL_npa USE W3GDATMD, ONLY: NSEAL, CLATS, GTYPE, UNGTYPE USE W3WDATMD, ONLY: TIME @@ -5232,7 +5688,9 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION_VA !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -5240,7 +5698,9 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION_VA REAL :: eVA, eAC INTEGER :: IK, ITH, ISEA, JSEA INTEGER :: IBI, ISP -!/S CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION_VA') +#ifdef W3_S + CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION_VA') +#endif IF (GTYPE .eq. UNGTYPE) THEN IF ( FLBPI ) THEN RD10 = DSEC21 ( TBPI0, TIME ) @@ -5323,7 +5783,9 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE YOWNODEPOOL, ONLY: npa USE yowRankModule, ONLY : IPGL_npa USE W3GDATMD, ONLY: NSEAL, CLATS, MAPSF @@ -5333,7 +5795,9 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION USE W3ADATMD, ONLY: CG, CX, CY USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI, IAPROC, BBPI0, BBPIN, ISBPI, NBI -!/DEBUGIOBC USE W3GDATMD, ONLY: DDEN +#ifdef W3_DEBUGIOBC + USE W3GDATMD, ONLY: DDEN +#endif !/ IMPLICIT NONE !/ @@ -5343,17 +5807,25 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/DEBUGSOLVER REAL*8 :: sumAC(NSPEC) -!/DEBUGSOLVER REAL :: sumBPI0(NSPEC), sumBPIN(NSPEC), sumCG, sumCLATS -!/DEBUGIOBC REAL :: ETOT, HSIG_bound, eVA, eAC, FACTOR +#ifdef W3_DEBUGSOLVER + REAL*8 :: sumAC(NSPEC) + REAL :: sumBPI0(NSPEC), sumBPIN(NSPEC), sumCG, sumCLATS +#endif +#ifdef W3_DEBUGIOBC + REAL :: ETOT, HSIG_bound, eVA, eAC, FACTOR +#endif REAL :: RD1, RD2, RD10, RD20 INTEGER :: IK, ITH, ISEA INTEGER :: IBI, IP_glob, ISP, JX -!/S CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION') +#ifdef W3_S + CALL STRACE (IENT, 'APPLY_BOUNDARY_CONDITION') +#endif IF ( FLBPI ) THEN RD10 = DSEC21 ( TBPI0, TIME ) RD20 = DSEC21 ( TBPI0, TBPIN ) @@ -5371,14 +5843,16 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION RD1 = 0. RD2 = 1. END IF -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NBI=', NBI -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER sumAC=0 -!/DEBUGSOLVER sumBPI0=0 -!/DEBUGSOLVER sumBPIN=0 -!/DEBUGSOLVER sumCG=0 -!/DEBUGSOLVER sumCLATS=0 +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' + WRITE(740+IAPROC,*) 'NBI=', NBI + FLUSH(740+IAPROC) + sumAC=0 + sumBPI0=0 + sumBPIN=0 + sumCG=0 + sumCLATS=0 +#endif DO IBI=1, NBI ISEA=ISBPI(IBI) IP_glob = MAPSF(ISEA,1) @@ -5391,38 +5865,46 @@ SUBROUTINE APPLY_BOUNDARY_CONDITION / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) END DO END DO -!/DEBUGIOBC ETOT=0 -!/DEBUGIOBC DO ITH=1,NTH -!/DEBUGIOBC DO IK=1,NK -!/DEBUGIOBC FACTOR = DDEN(IK)/CG(IK,ISEA) -!/DEBUGIOBC ISP=ITH + (IK-1)*NTH -!/DEBUGIOBC eAC=REAL(VA(ISP,JX)) -!/DEBUGIOBC eVA=CG(IK,ISEA)/CLATS(ISEA)*eAC -!/DEBUGIOBC ETOT = ETOT + eVA*FACTOR -!/DEBUGIOBC END DO -!/DEBUGIOBC END DO -!/DEBUGIOBC HSIG_bound=4.*SQRT(ETOT) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'IBI=', IBI, ' HSIG=', HSIG_bound +#ifdef W3_DEBUGIOBC + ETOT=0 + DO ITH=1,NTH + DO IK=1,NK + FACTOR = DDEN(IK)/CG(IK,ISEA) + ISP=ITH + (IK-1)*NTH + eAC=REAL(VA(ISP,JX)) + eVA=CG(IK,ISEA)/CLATS(ISEA)*eAC + ETOT = ETOT + eVA*FACTOR + END DO + END DO + HSIG_bound=4.*SQRT(ETOT) + WRITE(740+IAPROC,*) 'IBI=', IBI, ' HSIG=', HSIG_bound +#endif -!/DEBUGSOLVER sumAC=sumAC + VA(:,JX) -!/DEBUGSOLVER sumBPI0=sumBPI0 + BBPI0(:,IBI) -!/DEBUGSOLVER sumBPIN=sumBPIN + BBPIN(:,IBI) -!/DEBUGSOLVER sumCG=sumCG + CG(IK,ISBPI(IBI)) -!/DEBUGSOLVER sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) +#ifdef W3_DEBUGSOLVER + sumAC=sumAC + VA(:,JX) + sumBPI0=sumBPI0 + BBPI0(:,IBI) + sumBPIN=sumBPIN + BBPIN(:,IBI) + sumCG=sumCG + CG(IK,ISBPI(IBI)) + sumCLATS=sumCLATS + CLATS(ISBPI(IBI)) +#endif END IF ENDDO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 -!/DEBUGSOLVER DO ISP=1,NSPEC -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC(ISP) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0(ISP) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN(ISP) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS -!/DEBUGSOLVER END DO -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after boundary", npa) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'RD1=', RD1, ' RD2=', RD2 + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumAC=', sumAC(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPI0=', sumBPI0(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumBPIN=', sumBPIN(ISP) + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCG=', sumCG + WRITE(740+IAPROC,*) 'ISP=', ISP, 'sumCLATS=', sumCLATS + END DO + WRITE(740+IAPROC,*) 'Begin of APPLY_BOUNDARY_CONDITION' + FLUSH(740+IAPROC) +#endif +#ifdef W3_DEBUGSOLVERCOH + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after boundary", npa) +#endif END IF END SUBROUTINE !/ ------------------------------------------------------------------- / @@ -5471,7 +5953,9 @@ SUBROUTINE ACTION_LIMITER_LOCAL(IP,ACLOC,ACOLD, DTG) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif use YOWNODEPOOL, ONLY: iplg USE CONSTANTS, ONLY : GRAV, TPI USE W3ADATMD, ONLY : WN, CG @@ -5485,7 +5969,9 @@ SUBROUTINE ACTION_LIMITER_LOCAL(IP,ACLOC,ACOLD, DTG) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -5504,7 +5990,9 @@ SUBROUTINE ACTION_LIMITER_LOCAL(IP,ACLOC,ACOLD, DTG) INTEGER IP_glob, ISEA INTEGER :: IK, ITH, ISP LOGICAL :: LLIMITER_WWM -!/S CALL STRACE (IENT, 'ACTION_LIMITER_LOCAL')! +#ifdef W3_S + CALL STRACE (IENT, 'ACTION_LIMITER_LOCAL')! +#endif IP_glob=iplg(IP) ISEA=MAPFS(1,IP_glob) eSPSIG=SIG(NK) @@ -5592,7 +6080,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: MAPSTA USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP @@ -5600,8 +6090,10 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) USE W3GDATMD, ONLY: B_JGS_TERMINATE_DIFFERENCE, B_JGS_MAXITER, B_JGS_LIMITER USE W3GDATMD, ONLY: B_JGS_TERMINATE_MAXITER, B_JGS_BLOCK_GAUSS_SEIDEL, B_JGS_DIFF_THR USE W3GDATMD, ONLY: MAPWN -!/DEBUGSRC USE W3GDATMD, ONLY: optionCall -!/DEBUGSRC USE W3WDATMD, ONLY: SHAVETOT +#ifdef W3_DEBUGSRC + USE W3GDATMD, ONLY: optionCall + USE W3WDATMD, ONLY: SHAVETOT +#endif USE YOWNODEPOOL, ONLY: PDLIB_I_DIAG, PDLIB_IA_P, PDLIB_JA, np USE YOWNODEPOOL, ONLY: PDLIB_SI, PDLIB_NNZ, PDLIB_CCON use yowDatapool, ONLY: rtype @@ -5610,7 +6102,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) USE W3ADATMD, ONLY: WN USE MPI, ONLY : MPI_SUM, MPI_INT USE W3ADATMD, ONLY: MPI_COMM_WCMP -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3GDATMD, ONLY: IOBP, IOBPD, NSEA, SIG, IOBDP, IOBPA USE W3GDATMD, ONLY: NK, NK2, NTH, ECOS, ESIN, NSPEC, MAPFS USE W3WDATMD, ONLY: TIME @@ -5627,7 +6121,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) USE W3PARALL, ONLY : JX_TO_JSEA USE W3GDATMD, ONLY: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR USE yowfunction, ONLY : pdlib_abort -!/MEMCHECK USE MallocInfo_m +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif implicit none REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY ! @@ -5657,52 +6153,64 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) REAL :: eVal1, eVal2, extmp(nspec,nseal) REAL :: eVA LOGICAL :: LCONVERGED(NSEAL) -!/DEBUGSRC REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout -!/DEBUGSRC REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce -!/DEBUGSRC REAL :: VAsolve(NSPEC) -!/DEBUGSRC REAL*8 :: ACsolve -!/DEBUGSRC REAL :: eB +#ifdef W3_DEBUGSRC + REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout + REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce + REAL :: VAsolve(NSPEC) + REAL*8 :: ACsolve + REAL :: eB +#endif REAL :: ASPAR_DIAG_ALL(NSPEC,NSEAL) -!/DEBUGSOLVERCOH REAL :: TheARR(NSPEC, npa) -!/DEBUGSOLVERCOH REAL :: PRE_VA(NSPEC, npa) -!/DEBUGSOLVERCOH REAL :: OffDIAG(NSPEC, npa) -!/DEBUGSOLVERCOH REAL*8 :: eOff(NSPEC) -!/DEBUGSOLVERCOH REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) +#ifdef W3_DEBUGSOLVERCOH + REAL :: TheARR(NSPEC, npa) + REAL :: PRE_VA(NSPEC, npa) + REAL :: OffDIAG(NSPEC, npa) + REAL*8 :: eOff(NSPEC) + REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) +#endif CHARACTER(len=128) eFile INTEGER ierr, i INTEGER JP_glob INTEGER is_converged, itmp -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 0' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif CCURX = FACX CCURY = FACY CALL MPI_COMM_RANK(MPI_COMM_WCMP, myrank, ierr) ! -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, begin' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NX=', NX -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NP=', NP -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NPA=', NPA -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NSEA=', NSEA -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NSEAL=', NSEAL -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NBI=', NBI -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_NORM=', B_JGS_TERMINATE_NORM -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_DIFFERENCE=', B_JGS_TERMINATE_DIFFERENCE -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_MAXITER=', B_JGS_TERMINATE_MAXITER -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_MAXITER=', B_JGS_MAXITER -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_LIMITER=', B_JGS_LIMITER -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSRC WRITE(740+IAPROC,*) 'optionCall=', optionCall -!/DEBUGSRC FLUSH(740+IAPROC) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, begin' + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'NP=', NP + WRITE(740+IAPROC,*) 'NPA=', NPA + WRITE(740+IAPROC,*) 'NSEA=', NSEA + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'NBI=', NBI + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_NORM=', B_JGS_TERMINATE_NORM + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_DIFFERENCE=', B_JGS_TERMINATE_DIFFERENCE + WRITE(740+IAPROC,*) 'B_JGS_TERMINATE_MAXITER=', B_JGS_TERMINATE_MAXITER + WRITE(740+IAPROC,*) 'B_JGS_MAXITER=', B_JGS_MAXITER + WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'B_JGS_LIMITER=', B_JGS_LIMITER + WRITE(740+IAPROC,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', B_JGS_BLOCK_GAUSS_SEIDEL + FLUSH(740+IAPROC) +#endif +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'optionCall=', optionCall + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 1.b Initialize arrays ! @@ -5710,7 +6218,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) ! ! 2. Convert to Wave Action ---------------- * ! -!/DEBUGSRC WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'NSEAL =', NSEAL, 'NP =', NP, 'NPA =', NPA +#endif DO JSEA=1,NSEAL IP = JSEA IP_glob = iplg(IP) @@ -5723,25 +6233,33 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) END DO END DO VAOLD = VA(:,1:NSEAL) -!/DEBUGSRC DO JSEA=1,NSEAL -!/DEBUGSRC WRITE(740+IAPROC,*) 'JSEA=', JSEA -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) -!/DEBUGSRC END DO -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) just defined", np) -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) just defined", npa) -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 4' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FSGEOADVECT=', FSGEOADVECT -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'DTG=', DTG +#ifdef W3_DEBUGSRC + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) 'JSEA=', JSEA + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + END DO +#endif +#ifdef W3_DEBUGSOLVERCOH + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) just defined", np) + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) just defined", npa) +#endif +#ifdef W3_DEBUGSOLVER + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 4' + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'FSGEOADVECT=', FSGEOADVECT + WRITE(740+IAPROC,*) 'DTG=', DTG +#endif ! ! init matrix and right hand side ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! IF (IMEM == 1) THEN ASPAR_JAC = ZERO @@ -5750,11 +6268,15 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) ENDIF B_JAC = ZERO -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC INIT', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC INIT', sum(B_JAC), SUM(ASPAR_JAC) +#endif -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! source terms ! @@ -5766,22 +6288,30 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) ENDIF END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! geographical advection ! IF (IMEM == 1) call calcARRAY_JACOBI2(DTG,FACX,FACY,VGX,VGY) -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) +#endif -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 1', sum(B_JAC), SUM(ASPAR_JAC) +#endif ! ! spectral advection @@ -5790,23 +6320,33 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) call calcARRAY_JACOBI_SPECTRAL(DTG,ASPAR_DIAG_ALL) END IF -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 2', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 2', sum(B_JAC), SUM(ASPAR_JAC) +#endif ! CALL APPLY_BOUNDARY_CONDITION -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 3', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 3', sum(B_JAC), SUM(ASPAR_JAC) +#endif -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(B_JAC, "B_JAC after calcARRAY", np) -!/DEBUGSOLVERCOH DO IP=1,npa -!/DEBUGSOLVERCOH TheArr(:, IP)=REAL(ASPAR_JAC(:, PDLIB_I_DIAG(IP))) -!/DEBUGSOLVERCOH END DO -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(TheArr, "ASPAR(:,I_DIAG) after calArr", np) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGSOLVERCOH + CALL CHECK_ARRAY_INTEGRAL_NX_R8(B_JAC, "B_JAC after calcARRAY", np) + DO IP=1,npa + TheArr(:, IP)=REAL(ASPAR_JAC(:, PDLIB_I_DIAG(IP))) + END DO + CALL CHECK_ARRAY_INTEGRAL_NX_R8(TheArr, "ASPAR(:,I_DIAG) after calArr", np) +#endif -!/DEBUGSOLVER !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 4', sum(B_JAC), SUM(ASPAR_JAC) +#ifdef W3_DEBUGSOLVER + !WRITE(740+IAPROC,'(A20,20E20.10)') 'SUM BJAC 4', sum(B_JAC), SUM(ASPAR_JAC) +#endif nbIter=0 Lconverged = .false. @@ -5820,9 +6360,11 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) ICOUNT2 = 0 !AR: !ADD LOOP OVER ELEMENTS HERE FOR ALL ASPAR STUFF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif DO IP=1,np IP_glob=iplg(IP) @@ -5831,17 +6373,23 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) eSI=PDLIB_SI(IP) ACLOC=VA(:,JSEA) IF (.NOT. LCONVERGED(IP)) THEN -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'Begin loop' -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'IP/IP_glob/ISEA/JSEA=', IP, IP_glob, ISEA, JSEA -!/DEBUGSRC WRITE(740+IAPROC,*) 'IP=', IP, ' IP_glob=', IP_glob -!/DEBUGSRC WRITE(740+IAPROC,*) 'sum(VA)in=', sum(VA(:,IP)) -!/DEBUGFREQSHIFT DO ISP=1,NSPEC -!/DEBUGFREQSHIFT VAold(ISP) = VA(ISP,JSEA) -!/DEBUGFREQSHIFT IK=MAPWN(ISP) -!/DEBUGFREQSHIFT VAinput(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * VA(ISP, IP) -!/DEBUGFREQSHIFT VAacloc(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * ACLOC(ISP) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'sum(VAold/VAinput/VAacloc)=', sum(VAold), sum(VAinput), sum(VAacloc) +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'Begin loop' + WRITE(740+IAPROC,*) 'IP/IP_glob/ISEA/JSEA=', IP, IP_glob, ISEA, JSEA +#endif +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IP=', IP, ' IP_glob=', IP_glob + WRITE(740+IAPROC,*) 'sum(VA)in=', sum(VA(:,IP)) +#endif +#ifdef W3_DEBUGFREQSHIFT + DO ISP=1,NSPEC + VAold(ISP) = VA(ISP,JSEA) + IK=MAPWN(ISP) + VAinput(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * VA(ISP, IP) + VAacloc(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * ACLOC(ISP) + END DO + WRITE(740+IAPROC,*) 'sum(VAold/VAinput/VAacloc)=', sum(VAold), sum(VAinput), sum(VAacloc) +#endif !!/DEBUGFREQSHIFT DO ISP=1,NSPEC !!/DEBUGFREQSHIFT eVal1 = eSI * VA(ISP,IP) !!/DEBUGFREQSHIFT eVal2 = B_JAC(ISP,IP) @@ -5866,24 +6414,38 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) !WRITE(*,'(A10,10F20.10)') 'JAC3', SUM(ASPAR_DIAG_LOCAL), SUM(ASPAR_OFF_DIAG_LOCAL), SUM(B_JAC_LOCAL) eSum = B_JAC(:,IP) ASPAR_DIAG = ASPAR_JAC(:,PDLIB_I_DIAG(IP)) -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'eSI=', eSI -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'sum(ASPAR_DIAG)=', sum(ASPAR_DIAG) -!/DEBUGSRC WRITE(740+IAPROC,*) 'Step 1: sum(eSum)=', sum(eSum) -!/DEBUGSOLVERCOH eOff=ZERO +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'eSI=', eSI + WRITE(740+IAPROC,*) 'sum(ASPAR_DIAG)=', sum(ASPAR_DIAG) +#endif +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'Step 1: sum(eSum)=', sum(eSum) +#endif +#ifdef W3_DEBUGSOLVERCOH + eOff=ZERO +#endif DO i = PDLIB_IA_P(IP)+1, PDLIB_IA_P(IP+1) JP=PDLIB_JA(I) IF (JP .ne. IP) THEN eProd = ASPAR_JAC(:,i)*VA(:,JP) eSum = eSum - eProd -!/DEBUGSOLVER WRITE(740+IAPROC,'(A20,3I10,20E20.10)') 'OFF DIAGONAL', IP, i, jp, sum(B_JAC(:,IP)), sum(eSum), SUM(ASPAR_JAC(:,i)), SUM(VA(:,JP)) -!/DEBUGSOLVERCOH eOff=eOff + abs(ASPAR_JAC(:,i)) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,'(A20,3I10,20E20.10)') 'OFF DIAGONAL', IP, i, jp, sum(B_JAC(:,IP)), sum(eSum), SUM(ASPAR_JAC(:,i)), SUM(VA(:,JP)) +#endif +#ifdef W3_DEBUGSOLVERCOH + eOff=eOff + abs(ASPAR_JAC(:,i)) +#endif END IF END DO ENDIF ! IMEM -!/DEBUGSOLVERCOH OffDiag(:, IP)=REAL(eOff) -!/DEBUGSOLVERCOH WRITE(740+IAPROC,*) 'Step 2: sum(eSum)=', sum(eSum), ' eOff=', sum(eOff) +#ifdef W3_DEBUGSOLVERCOH + OffDiag(:, IP)=REAL(eOff) + WRITE(740+IAPROC,*) 'Step 2: sum(eSum)=', sum(eSum), ' eOff=', sum(eOff) +#endif IF (FSREFRACTION) THEN -!/DEBUGREFRACTION WRITE(740+IAPROC,*) 'Adding refraction terms to eSum' +#ifdef W3_DEBUGREFRACTION + WRITE(740+IAPROC,*) 'Adding refraction terms to eSum' +#endif CAD=CAD_THE(:,IP) DO ISP=1,NSPEC ISPprevDir=ListISPprevDir(ISP) @@ -5894,7 +6456,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) eSum(ISP) = eSum(ISP) - eC_THE * VA(ISPnextDir,IP) END DO END IF -!/DEBUGSRC WRITE(740+IAPROC,*) 'Step 3: sum(eSum)=', sum(eSum) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'Step 3: sum(eSum)=', sum(eSum) +#endif IF (FSFREQSHIFT) THEN IF (FreqShiftMethod .eq. 1) THEN CAS=CAS_SIG(:,IP) @@ -5926,7 +6490,9 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) DO IK=1, NK DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) END DO -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'Before FreqShift oper eSum=', sum(abs(eSum)) +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'Before FreqShift oper eSum=', sum(abs(eSum)) +#endif DO ITH=1,NTH DO IK=2,NK ISP = ITH + (IK -1)*NTH @@ -5943,57 +6509,65 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) eSum(ISP) = eSum(ISP) - eC_SIG*VA(ISPp1,IP) END DO END DO -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) ' after FreqShift oper eSum=', sum(abs(eSum)) +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) ' after FreqShift oper eSum=', sum(abs(eSum)) +#endif END IF END IF -!/DEBUGSRC WRITE(740+IAPROC,*) 'Step 4: sum(eSum)=', sum(eSum) -!/DEBUGSOLVERCOH PRE_VA(:, IP)=REAL(eSum) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'Step 4: sum(eSum)=', sum(eSum) +#endif +#ifdef W3_DEBUGSOLVERCOH + PRE_VA(:, IP)=REAL(eSum) +#endif eSum=eSum/ASPAR_DIAG -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' nbIter=', nbIter -!/DEBUGFREQSHIFT DO ISP=1,NSPEC -!/DEBUGFREQSHIFT IK=MAPWN(ISP) -!/DEBUGFREQSHIFT VAnew(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * eSum(ISP) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT DO ISP=1,NSPEC -!/DEBUGFREQSHIFT VAAnew(ISP) = VAnew(ISP) -!/DEBUGFREQSHIFT VAAacloc(ISP) = VAacloc(ISP) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT DO ITH=1,NTH -!/DEBUGFREQSHIFT VAAnew(ITH + NSPEC) = FACHFA * VAAnew(ITH + NSPEC - NTH) -!/DEBUGFREQSHIFT VAAnew(ITH - NTH ) = 0. -!/DEBUGFREQSHIFT VAAacloc(ITH + NSPEC) = FACHFA * VAAacloc(ITH + NSPEC - NTH) -!/DEBUGFREQSHIFT VAAacloc(ITH - NTH ) = 0. -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT DO ISP=1-NTH,NSPEC -!/DEBUGFREQSHIFT VFLWN(ISP) = MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAnew(ISP + NTH) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT DO ISP=1,NSPEC -!/DEBUGFREQSHIFT eDiff(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (VFLWN(ISP-NTH) - VFLWN(ISP) ) -!/DEBUGFREQSHIFT eVal1=MAX(CWNB_M2(ISP-NTH),0.) * VAAacloc(ISP-NTH) + MIN(CWNB_M2(ISP-NTH),0.) * VAAnew(ISP) -!/DEBUGFREQSHIFT eVal2=MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAacloc(ISP + NTH) -!/DEBUGFREQSHIFT eDiffB(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (eVal1 - eVal2) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT IF (ISEA .eq. 190) THEN -!/DEBUGFREQSHIFT DO IK=1,NK -!/DEBUGFREQSHIFT DO ITH=1,NTH -!/DEBUGFREQSHIFT ISP = ITH + (IK-1)*NTH -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'ISP/ITH/IK=', ISP, ITH, IK -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'eDiff(A/B)=', eDiff(ISP), eDiffB(ISP) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT END IF -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'NK=', NK, ' NTH=', NTH -!/DEBUGFREQSHIFT eSumPart=0 -!/DEBUGFREQSHIFT DO IK=1,NK -!/DEBUGFREQSHIFT DO ITH=1,NTH -!/DEBUGFREQSHIFT ISP = ITH + (IK-1)*NTH -!/DEBUGFREQSHIFT eSumPart = eSumPart + abs(eDiff(ISP)) -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT IF (ISEA .eq. 190) THEN -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'IK=', IK, ' eSumDiff=', eSumPart -!/DEBUGFREQSHIFT END IF -!/DEBUGFREQSHIFT END DO -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'sum(eDiff/VAnew/VAold)=', sum(abs(eDiff)), sum(abs(VAnew)), sum(abs(VAold)) +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' nbIter=', nbIter + DO ISP=1,NSPEC + IK=MAPWN(ISP) + VAnew(ISP) = DBLE(CG(IK,ISEA)/CLATS(ISEA)) * eSum(ISP) + END DO + DO ISP=1,NSPEC + VAAnew(ISP) = VAnew(ISP) + VAAacloc(ISP) = VAacloc(ISP) + END DO + DO ITH=1,NTH + VAAnew(ITH + NSPEC) = FACHFA * VAAnew(ITH + NSPEC - NTH) + VAAnew(ITH - NTH ) = 0. + VAAacloc(ITH + NSPEC) = FACHFA * VAAacloc(ITH + NSPEC - NTH) + VAAacloc(ITH - NTH ) = 0. + END DO + DO ISP=1-NTH,NSPEC + VFLWN(ISP) = MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAnew(ISP + NTH) + END DO + DO ISP=1,NSPEC + eDiff(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (VFLWN(ISP-NTH) - VFLWN(ISP) ) + eVal1=MAX(CWNB_M2(ISP-NTH),0.) * VAAacloc(ISP-NTH) + MIN(CWNB_M2(ISP-NTH),0.) * VAAnew(ISP) + eVal2=MAX(CWNB_M2(ISP),0.) * VAAnew(ISP) + MIN(CWNB_M2(ISP),0.) * VAAacloc(ISP + NTH) + eDiffB(ISP) = VAnew(ISP) - VAold(ISP) - DWNI_M2(MAPWN(ISP)) * (eVal1 - eVal2) + END DO + IF (ISEA .eq. 190) THEN + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + WRITE(740+IAPROC,*) 'ISP/ITH/IK=', ISP, ITH, IK + WRITE(740+IAPROC,*) 'eDiff(A/B)=', eDiff(ISP), eDiffB(ISP) + END DO + END DO + END IF + WRITE(740+IAPROC,*) 'NK=', NK, ' NTH=', NTH + eSumPart=0 + DO IK=1,NK + DO ITH=1,NTH + ISP = ITH + (IK-1)*NTH + eSumPart = eSumPart + abs(eDiff(ISP)) + END DO + IF (ISEA .eq. 190) THEN + WRITE(740+IAPROC,*) 'IK=', IK, ' eSumDiff=', eSumPart + END IF + END DO + WRITE(740+IAPROC,*) 'sum(eDiff/VAnew/VAold)=', sum(abs(eDiff)), sum(abs(VAnew)), sum(abs(VAold)) +#endif Sum_New=sum(eSum) IF (B_JGS_LIMITER) THEN CALL ACTION_LIMITER_LOCAL(IP, eSum, ACLOC, DTG) @@ -6014,34 +6588,46 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) IF (B_JGS_TERMINATE_DIFFERENCE) THEN if (Sum_new .gt. thr8) then DiffNew=sum(abs(ACLOC - eSum)) -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'DiffNew=', DiffNew, ' Sum_new=', Sum_new +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'DiffNew=', DiffNew, ' Sum_new=', Sum_new +#endif !DiffOld=abs(Sum_prev - Sum_new) p_is_converged = DiffNew/Sum_new -!/DEBUGSOLVER write(740+IAPROC,'(10E20.10)') p_is_converged, sum(ASPAR_DIAG), SUM(B_JAC(:,IP)), DiffNew, Sum_new, sum(ACLOC), sum(esum) +#ifdef W3_DEBUGSOLVER + write(740+IAPROC,'(10E20.10)') p_is_converged, sum(ASPAR_DIAG), SUM(B_JAC(:,IP)), DiffNew, Sum_new, sum(ACLOC), sum(esum) +#endif else p_is_converged = zero endif -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'p_is_converged=', p_is_converged +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'p_is_converged=', p_is_converged +#endif IF (p_is_converged .lt. B_JGS_DIFF_THR) then is_converged = is_converged + 1 lconverged(ip) = .true. ENDIF END IF !IF (IP == 2) STOP -!/DEBUGSRC WRITE(740+IAPROC,*) 'sum(VA)out=', sum(VA(:,IP)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'sum(VA)out=', sum(VA(:,IP)) +#endif END DO ! IP -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif -!/DEBUGSOLVERCOH WRITE(740+IAPROC,*) 'sum(OffDiag)=', sum(OffDiag) -!/DEBUGSOLVERCOH WRITE (eFile,40) nbIter -!/DEBUGSOLVERCOH 40 FORMAT ('PRE_VA_',i4.4,'.txt') -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(OffDiag, "OffDiag(np) just check", np) -!/DEBUGSOLVERCOH ! CALL WRITE_VAR_TO_TEXT_FILE(PRE_VA, eFile) -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(PRE_VA, "PRE_VA(np) just check", np) -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) before exchanges", np) +#ifdef W3_DEBUGSOLVERCOH + WRITE(740+IAPROC,*) 'sum(OffDiag)=', sum(OffDiag) + WRITE (eFile,40) nbIter + 40 FORMAT ('PRE_VA_',i4.4,'.txt') + CALL CHECK_ARRAY_INTEGRAL_NX_R8(OffDiag, "OffDiag(np) just check", np) + ! CALL WRITE_VAR_TO_TEXT_FILE(PRE_VA, eFile) + CALL CHECK_ARRAY_INTEGRAL_NX_R8(PRE_VA, "PRE_VA(np) just check", np) + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) before exchanges", np) +#endif IF (B_JGS_BLOCK_GAUSS_SEIDEL) THEN extmp = VA(:,1:NPA) CALL PDLIB_exchange2DREAL(extmp) @@ -6050,9 +6636,11 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) CALL PDLIB_exchange2DREAL(U_JAC) VA(:,1:NPA) = U_JAC END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif !!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after exchanges", npa) ! @@ -6061,14 +6649,18 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) IF (B_JGS_TERMINATE_MAXITER) THEN nbIter=nbIter+1 IF (nbIter .gt. B_JGS_MAXITER) THEN -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Exiting by TERMINATE_MAXITER' +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_MAXITER' +#endif EXIT END IF END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! Terminate via differences ! @@ -6078,20 +6670,26 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) prop_conv = (DBLE(NX) - DBLE(is_converged))/DBLE(NX) * 100. !write(*,*) prop_conv, nbIter, is_converged if (myrank == 0) WRITE(*,*) 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'solver', nbiter, is_converged, prop_conv, B_JGS_PMIN + FLUSH(740+IAPROC) +#endif IF (prop_conv .le. B_JGS_PMIN) THEN -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'prop_conv=', prop_conv -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'NX=', NX -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'is_converged=', is_converged -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'Exiting by TERMINATE_DIFFERENCE' +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'prop_conv=', prop_conv + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'is_converged=', is_converged + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_DIFFERENCE' +#endif EXIT END IF END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! Terminate via norm ! @@ -6148,92 +6746,118 @@ SUBROUTINE PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK(FACX, FACY, DTG, VGX, VGY) END IF END DO CALL MPI_ALLREDUCE(Sum_L2, Sum_L2_GL, 1, rtype, MPI_SUM, MPI_COMM_WCMP, ierr) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'Sum_L2_gl=', Sum_L2_gl -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'Sum_L2_gl=', Sum_L2_gl + FLUSH(740+IAPROC) +#endif IF (Sum_L2_gl .le. B_JGS_NORM_THR) THEN -!/DEBUGFREQSHIFT WRITE(740+IAPROC,*) 'Exiting by TERMINATE_NORM' +#ifdef W3_DEBUGFREQSHIFT + WRITE(740+IAPROC,*) 'Exiting by TERMINATE_NORM' +#endif EXIT END IF END IF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION SOLVER LOOP 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif END DO ! Open Do Loop ... End of Time Interval -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' B_JGS_MAXITER=', B_JGS_MAXITER -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' B_JGS_MAXITER=', B_JGS_MAXITER + FLUSH(740+IAPROC) +#endif ! Tihs is below also goes into the matrix ... like the wave boundary ... DO IP = 1, npa IP_glob=iplg(IP) -!/DEBUGSRC WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) +#endif DO ISP=1,NSPEC ITH = 1 + MOD(ISP-1,NTH) VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP(IP_glob)*DBLE(IOBPD(ITH,IP_glob)) END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) +#endif END DO !!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after loop", npa) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FLBPI=', FLBPI -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + FLUSH(740+IAPROC) +#endif DO JSEA=1, NSEAL IP = JSEA IP_glob = iplg(IP) ISEA=MAPFS(1,IP_glob) ! -!/DEBUGSRC IntDiff=0 -!/DEBUGSRC SumVS=0 -!/DEBUGSRC SumVD=0 -!/DEBUGSRC SumVAin=0 -!/DEBUGSRC SumVAout=0 -!/DEBUGSRC SumVAw3srce=0 -!/DEBUGSRC SumACout=0 +#ifdef W3_DEBUGSRC + IntDiff=0 + SumVS=0 + SumVD=0 + SumVAin=0 + SumVAout=0 + SumVAw3srce=0 + SumACout=0 +#endif ! DO ISP=1,NSPEC IK = 1 + (ISP-1)/NTH eVA = MAX ( ZERO ,CG(IK,ISEA)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) -!/DEBUGSRC SumACout=SumACout + REAL(VA(ISP,IP)) -!/DEBUGSRC VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) -!/DEBUGSRC eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) -!/DEBUGSRC IntDiff = IntDiff + abs(eVA - eVA_w3srce) -!/DEBUGSRC ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) -!/DEBUGSRC eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) -!/DEBUGSRC eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) -!/DEBUGSRC VAsolve(ISP)=eVAsolve -!/DEBUGSRC SumVS = SumVS + abs(VSTOT(ISP,JSEA)) -!/DEBUGSRC SumVD = SumVD + abs(VDTOT(ISP,JSEA)) -!/DEBUGSRC SumVAin = SumVAin + abs(VA(ISP,JSEA)) -!/DEBUGSRC SumVAout = SumVAout + abs(eVA) -!/DEBUGSRC SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#ifdef W3_DEBUGSRC + SumACout=SumACout + REAL(VA(ISP,IP)) + VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) + eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) + IntDiff = IntDiff + abs(eVA - eVA_w3srce) + ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) + eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) + eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) + VAsolve(ISP)=eVAsolve + SumVS = SumVS + abs(VSTOT(ISP,JSEA)) + SumVD = SumVD + abs(VDTOT(ISP,JSEA)) + SumVAin = SumVAin + abs(VA(ISP,JSEA)) + SumVAout = SumVAout + abs(eVA) + SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#endif VA(ISP,JSEA) = eVA END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG -!/DEBUGSRC IF (ISEA .eq. TESTNODE) THEN -!/DEBUGSRC DO ISP=1,NSPEC -!/DEBUGSRC WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) -!/DEBUGSRC END DO -!/DEBUGSRC END IF -!/DEBUGSRC WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) -!/DEBUGSRC WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) -!/DEBUGSRC WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce -!/DEBUGSRC WRITE(740+IAPROC,*) 'SumACout=', SumACout +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG + IF (ISEA .eq. TESTNODE) THEN + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) + END DO + END IF + WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) + WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD + WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) + WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce + WRITE(740+IAPROC,*) 'SumACout=', SumACout +#endif END DO ! JSEA -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -!/DEBUGSRC DO JSEA=1,NSEAL -!/DEBUGSRC WRITE(740+IAPROC,*) 'JSEA=', JSEA -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) -!/DEBUGSRC END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_PROP SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +#ifdef W3_DEBUGSRC + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) 'JSEA=', JSEA + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + END DO + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) +#endif -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) @@ -6282,7 +6906,9 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: MAPSTA USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT, FSSOURCE, NX, DSIP @@ -6306,7 +6932,9 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) USE W3TIMEMD, ONLY: DSEC21 USE W3GDATMD, ONLY: NSEAL, CLATS, FACHFA USE W3IDATMD, ONLY: FLCUR -!/DEBUGSRC USE W3WDATMD, ONLY: SHAVETOT +#ifdef W3_DEBUGSRC + USE W3WDATMD, ONLY: SHAVETOT +#endif USE W3WDATMD, ONLY: VA, VSTOT, VDTOT USE W3ADATMD, ONLY: CG, CX, CY, MPI_COMM_WCMP USE W3ODATMD, ONLY: TBPIN, FLBPI, IAPROC @@ -6341,16 +6969,20 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) REAL :: KELEMGL(NSPEC,3,NTRI), FLALLGL(NSPEC,3,NTRI) REAL :: eVal1, eVal2,thr REAL :: eVA -!/DEBUGSRC REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout -!/DEBUGSRC REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce -!/DEBUGSRC REAL :: VAsolve(NSPEC) -!/DEBUGSRC REAL*8 :: ACsolve -!/DEBUGSRC REAL :: eB +#ifdef W3_DEBUGSRC + REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout + REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce + REAL :: VAsolve(NSPEC) + REAL*8 :: ACsolve + REAL :: eB +#endif REAL :: ASPAR_DIAG(NSPEC) -!/DEBUGSOLVERCOH REAL*8 :: PRE_VA(NSPEC, npa) -!/DEBUGSOLVERCOH REAL*8 :: OffDIAG(NSPEC, npa) -!/DEBUGSOLVERCOH REAL*8 :: eOff(NSPEC) -!/DEBUGSOLVERCOH REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) +#ifdef W3_DEBUGSOLVERCOH + REAL*8 :: PRE_VA(NSPEC, npa) + REAL*8 :: OffDIAG(NSPEC, npa) + REAL*8 :: eOff(NSPEC) + REAL*8 :: eSum1(NSPEC), eSum2(NSPEC) +#endif CHARACTER(len=128) eFile INTEGER ierr, i INTEGER JP_glob @@ -6358,13 +6990,15 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) thr = dble(tiny(1.)) CCURX = FACX CCURY = FACY -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, begin' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NX=', NX -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NP=', NP -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NPA=', NPA -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NSEA=', NSEA -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'NSEAL=', NSEAL -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, begin' + WRITE(740+IAPROC,*) 'NX=', NX + WRITE(740+IAPROC,*) 'NP=', NP + WRITE(740+IAPROC,*) 'NPA=', NPA + WRITE(740+IAPROC,*) 'NSEA=', NSEA + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + FLUSH(740+IAPROC) +#endif ! ! 1.b Initialize arrays ! @@ -6372,9 +7006,11 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) ! ! 2. Calculate velocities ---------------- * ! -!/DEBUGSRC WRITE(740+IAPROC,*) 'NSEAL =', NSEAL -!/DEBUGSRC WRITE(740+IAPROC,*) 'NP =', NP -!/DEBUGSRC WRITE(740+IAPROC,*) 'NPA =', NPA +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'NSEAL =', NSEAL + WRITE(740+IAPROC,*) 'NP =', NP + WRITE(740+IAPROC,*) 'NPA =', NPA +#endif DO JSEA=1,NSEAL IP = JSEA IP_glob=iplg(IP) @@ -6388,24 +7024,32 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) CCOS = FACX * ECOS(ITH) CSIN = FACY * ESIN(ITH) VA(ISP,IP) = DBLE(VA(ISP,JSEA) / CG(IK,ISEA) * CLATS(ISEA)) -!/MGP VLCFLX(ISP,IP) = VLCFLX(ISP,IP) - CCURX*VGX/CLATS(ISEA) -!/MGP VLCFLY(ISP,IP) = VLCFLY(ISP,IP) - CCURY*VGY +#ifdef W3_MGP + VLCFLX(ISP,IP) = VLCFLX(ISP,IP) - CCURX*VGX/CLATS(ISEA) + VLCFLY(ISP,IP) = VLCFLY(ISP,IP) - CCURY*VGY +#endif END DO END DO -!/DEBUGSRC DO IP=1,NP -!/DEBUGSRC WRITE(740+IAPROC,*) 'IP=', IP -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) -!/DEBUGSRC END DO +#ifdef W3_DEBUGSRC + DO IP=1,NP + WRITE(740+IAPROC,*) 'IP=', IP + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) + END DO +#endif -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) just defined", np) -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) just defined", npa) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 3' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FLCUR=', FLCUR -!/DEBUGSOLVER FLUSH(740+IAPROC) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, step 4' -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'min,max(0)=', 0 -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'min,max(0)=', 0 -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVERCOH + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(np) just defined", np) + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) just defined", npa) +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'JACOBI_SOLVER, step 3' + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'EXPLICIT BLOCK SOLVER, step 4' + WRITE(740+IAPROC,*) 'min,max(0)=', 0 + WRITE(740+IAPROC,*) 'min,max(0)=', 0 + FLUSH(740+IAPROC) +#endif DO IE = 1, NE I1 = INE(1,IE) @@ -6490,74 +7134,92 @@ SUBROUTINE PDLIB_EXPLICIT_BLOCK(FACX, FACY, DTG, VGX, VGY) DO IP = 1, npa IP_glob=iplg(IP) -!/DEBUGSRC WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IOBPD loop, Before, sum(VA)=', sum(VA(:,IP)) +#endif DO ISP=1,NSPEC ITH = 1 + MOD(ISP-1,NTH) VA(ISP,IP)=MAX(ZERO, VA(ISP,IP))*IOBDP(IP_glob)*DBLE(IOBPD(ITH,IP_glob)) END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'IOBPD loop, After, sum(VA)=', sum(VA(:,IP)) +#endif END DO -!/DEBUGSOLVERCOH CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after loop", npa) -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'FLBPI=', FLBPI -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVERCOH + CALL CHECK_ARRAY_INTEGRAL_NX_R8(VA, "VA(npa) after loop", npa) +#endif +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + FLUSH(740+IAPROC) +#endif DO JSEA=1, NSEAL IP=JSEA IP_glob=iplg(IP) ISEA=MAPFS(1,IP_glob) ! -!/DEBUGSRC IntDiff=0 -!/DEBUGSRC SumVS=0 -!/DEBUGSRC SumVD=0 -!/DEBUGSRC SumVAin=0 -!/DEBUGSRC SumVAout=0 -!/DEBUGSRC SumVAw3srce=0 -!/DEBUGSRC SumACout=0 +#ifdef W3_DEBUGSRC + IntDiff=0 + SumVS=0 + SumVD=0 + SumVAin=0 + SumVAout=0 + SumVAw3srce=0 + SumACout=0 +#endif ! DO ISP=1,NSPEC IK = 1 + (ISP-1)/NTH eVA = MAX ( 0. ,CG(IK,ISEA)/CLATS(ISEA)*REAL(VA(ISP,IP)) ) -!/DEBUGSRC SumACout=SumACout + REAL(VA(ISP,IP)) -!/DEBUGSRC VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) -!/DEBUGSRC eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) -!/DEBUGSRC IntDiff = IntDiff + abs(eVA - eVA_w3srce) -!/DEBUGSRC ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) -!/DEBUGSRC eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) -!/DEBUGSRC eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) -!/DEBUGSRC VAsolve(ISP)=eVAsolve -!/DEBUGSRC SumVS = SumVS + abs(VSTOT(ISP,JSEA)) -!/DEBUGSRC SumVD = SumVD + abs(VDTOT(ISP,JSEA)) -!/DEBUGSRC SumVAin = SumVAin + abs(VA(ISP,JSEA)) -!/DEBUGSRC SumVAout = SumVAout + abs(eVA) -!/DEBUGSRC SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#ifdef W3_DEBUGSRC + SumACout=SumACout + REAL(VA(ISP,IP)) + VS_w3srce = VSTOT(ISP,JSEA) * DTG / MAX(1., (1. - DTG*VDTOT(ISP,JSEA))) + eVA_w3srce = MAX(0., VA(ISP,JSEA) + VS_w3srce) + IntDiff = IntDiff + abs(eVA - eVA_w3srce) + ACsolve=B_JAC(ISP,IP)/ASPAR_JAC(ISP,PDLIB_I_DIAG(IP)) + eB=VA(ISP,JSEA) + DTG*(VSTOT(ISP,JSEA) - VDTOT(ISP,JSEA)*VA(ISP,JSEA)) + eVAsolve=MAX(0., CG(IK,ISEA)/CLATS(ISEA)*ACsolve) + VAsolve(ISP)=eVAsolve + SumVS = SumVS + abs(VSTOT(ISP,JSEA)) + SumVD = SumVD + abs(VDTOT(ISP,JSEA)) + SumVAin = SumVAin + abs(VA(ISP,JSEA)) + SumVAout = SumVAout + abs(eVA) + SumVAw3srce = SumVAw3srce + abs(eVA_w3srce) +#endif VA(ISP,JSEA) = eVA END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG -!/DEBUGSRC IF (ISEA .eq. TESTNODE) THEN -!/DEBUGSRC DO ISP=1,NSPEC -!/DEBUGSRC WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) -!/DEBUGSRC END DO -!/DEBUGSRC END IF -!/DEBUGSRC WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) -!/DEBUGSRC WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) -!/DEBUGSRC WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce -!/DEBUGSRC WRITE(740+IAPROC,*) 'SumACout=', SumACout +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' IntDiff=', IntDiff, ' DTG=', DTG + IF (ISEA .eq. TESTNODE) THEN + DO ISP=1,NSPEC + WRITE(740+IAPROC,*) 'ISP=', ISP, 'VA/VAsolve=', VA(ISP,JSEA), VAsolve(ISP) + END DO + END IF + WRITE(740+IAPROC,*) 'SHAVE=', SHAVETOT(JSEA) + WRITE(740+IAPROC,*) 'Sum(VS/VD)=', SumVS, SumVD + WRITE(740+IAPROC,*) 'min/max/sum(VS)=', minval(VSTOT(:,JSEA)), maxval(VSTOT(:,JSEA)), sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VD)=', minval(VDTOT(:,JSEA)), maxval(VDTOT(:,JSEA)), sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,JSEA)), maxval(VA(:,JSEA)), sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VAsolve)=', minval(VAsolve), maxval(VAsolve), sum(VAsolve) + WRITE(740+IAPROC,*) 'SumVA(in/out/w3srce)=', SumVAin, SumVAout, SumVAw3srce + WRITE(740+IAPROC,*) 'SumACout=', SumACout +#endif + END DO +#ifdef W3_DEBUGSRC + DO IP=1,NP + WRITE(740+IAPROC,*) 'IP=', IP + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) END DO -!/DEBUGSRC DO IP=1,NP -!/DEBUGSRC WRITE(740+IAPROC,*) 'IP=', IP -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA(:,IP)), maxval(VA(:,IP)), sum(VA(:,IP)) -!/DEBUGSRC END DO -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) +#endif -!/DEBUGSOLVER WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' -!/DEBUGSOLVER FLUSH(740+IAPROC) +#ifdef W3_DEBUGSOLVER + WRITE(740+IAPROC,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE BLOCK_SOLVER_INIT @@ -6605,7 +7267,9 @@ SUBROUTINE BLOCK_SOLVER_INIT ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX @@ -6628,12 +7292,16 @@ SUBROUTINE BLOCK_SOLVER_INIT INTEGER ISP, ITH, IK, ISPprevFreq, ISPnextFreq INTEGER NewISP, JTH, istat -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 1' + FLUSH(740+IAPROC) +#endif ALLOCATE(ListISPnextDir(NSPEC), ListISPprevDir(NSPEC), ListISPnextFreq(NSPEC), ListISPprevFreq(NSPEC),stat=istat) IF (istat /= 0) CALL PDLIB_ABORT(8) -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 2' + FLUSH(740+IAPROC) +#endif DO ISP=1,NSPEC ITH = 1 + MOD(ISP-1,NTH) IK = 1 + (ISP-1)/NTH @@ -6665,17 +7333,25 @@ SUBROUTINE BLOCK_SOLVER_INIT NewISP=JTH + (IK-1)*NTH ListISPnextDir(ISP)=NewISP END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 3' + FLUSH(740+IAPROC) +#endif IF (FSTOTALIMP .and. B_JGS_USE_JACOBI) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 4' + FLUSH(740+IAPROC) +#endif CALL JACOBI_INIT -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 5' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 5' + FLUSH(740+IAPROC) +#endif END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'BLOCK_SOLVER_INIT, step 6' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------ / SUBROUTINE SETDEPTH_PDLIB @@ -6723,7 +7399,9 @@ SUBROUTINE SETDEPTH_PDLIB ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY: MAPSF, NSEAL, DMIN, IOBDP, MAPSTA, IOBP, MAPFS, NX USE W3ADATMD, ONLY: DW @@ -6738,14 +7416,18 @@ SUBROUTINE SETDEPTH_PDLIB !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ ! INTEGER :: JSEA, ISEA, IX, IP, IP_glob REAL*8, PARAMETER :: DTHR = 10E-6 -!/S CALL STRACE (IENT, 'SETDEPTH_PDLIB') +#ifdef W3_S + CALL STRACE (IENT, 'SETDEPTH_PDLIB') +#endif IOBDP = 1 DO JSEA=1,NSEAL IP=JSEA @@ -6804,7 +7486,9 @@ SUBROUTINE BLOCK_SOLVER_FINALIZE ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY: B_JGS_USE_JACOBI !/ IMPLICIT NONE @@ -6815,12 +7499,16 @@ SUBROUTINE BLOCK_SOLVER_FINALIZE !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ ! -!/S CALL STRACE (IENT, 'BLOCK_SOLVER_FINALIZE') +#ifdef W3_S + CALL STRACE (IENT, 'BLOCK_SOLVER_FINALIZE') +#endif IF (B_JGS_USE_JACOBI) THEN CALL JACOBI_FINALIZE END IF @@ -6874,13 +7562,17 @@ SUBROUTINE JACOBI_INIT ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY: NSPEC, B_JGS_BLOCK_GAUSS_SEIDEL use YOWNODEPOOL, ONLY: PDLIB_NNZ, npa, np USE yowfunction, ONLY: pdlib_abort USE W3GDATMD, ONLY: NTH, NK, NSEAL USE W3PARALL, ONLY: IMEM -!/DEBUGINIT USE W3ODATMD, ONLY : IAPROC +#ifdef W3_DEBUGINIT + USE W3ODATMD, ONLY : IAPROC +#endif !/ IMPLICIT NONE !/ @@ -6890,58 +7582,82 @@ SUBROUTINE JACOBI_INIT !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER istat -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 1' + FLUSH(740+IAPROC) +#endif IF (IMEM == 1) THEN ALLOCATE(ASPAR_JAC(NSPEC, PDLIB_NNZ), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(9) ENDIF -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 2' + FLUSH(740+IAPROC) +#endif ALLOCATE(B_JAC(NSPEC,npa), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(10) ALLOCATE(ASPAR_DIAG_SOURCES(NSPEC,npa), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(10) -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 3' + FLUSH(740+IAPROC) +#endif ALLOCATE(CAD_THE(NSPEC,NSEAL), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(11) -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 4' + FLUSH(740+IAPROC) +#endif CAD_THE = 0 IF (FreqShiftMethod .eq. 1) THEN ALLOCATE(CAS_SIG(NSPEC,NSEAL), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(11) CAS_SIG = 0 END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 5, FreqShiftMethod=', FreqShiftMethod -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 5, FreqShiftMethod=', FreqShiftMethod + FLUSH(740+IAPROC) +#endif IF (FreqShiftMethod .eq. 2) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before CWNB_SIG_M2 allocation, NTH=', NTH -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before CWNB_SIG_M2 allocation, NTH=', NTH + FLUSH(740+IAPROC) +#endif ALLOCATE(CWNB_SIG_M2(1-NTH:NSPEC,NSEAL), stat=istat) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After CWNB_SIG_M2 allocation, istat=', istat -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After CWNB_SIG_M2 allocation, istat=', istat + FLUSH(740+IAPROC) +#endif if(istat /= 0) CALL PDLIB_ABORT(11) -!/DEBUGINIT WRITE(740+IAPROC,*) 'After istat test' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After istat test' + FLUSH(740+IAPROC) +#endif CWNB_SIG_M2(:,:) = 0 -!/DEBUGINIT WRITE(740+IAPROC,*) 'After CWNB_SIG_M2 setting to zero' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'After CWNB_SIG_M2 setting to zero' + FLUSH(740+IAPROC) +#endif END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 6' + FLUSH(740+IAPROC) +#endif IF (.NOT. B_JGS_BLOCK_GAUSS_SEIDEL) THEN ALLOCATE(U_JAC(NSPEC,npa), stat=istat) if(istat /= 0) CALL PDLIB_ABORT(12) END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'JACOBI_INIT, step 7' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JACOBI_INIT, step 7' + FLUSH(740+IAPROC) +#endif !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ @@ -6992,7 +7708,9 @@ SUBROUTINE JACOBI_FINALIZE ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -7002,11 +7720,15 @@ SUBROUTINE JACOBI_FINALIZE !/ ------------------------------------------------------------------- / !/ Local PARAMETER !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'JACOBI_FINALIZE') +#ifdef W3_S + CALL STRACE (IENT, 'JACOBI_FINALIZE') +#endif DEALLOCATE(ASPAR_JAC, B_JAC) !/ !/ End of JACOBI_FINALIZE -------------------------------------------- / diff --git a/model/ftn/w3psmcmd.ftn b/model/src/w3psmcmd.F90 similarity index 87% rename from model/ftn/w3psmcmd.ftn rename to model/src/w3psmcmd.F90 index fc290b433..c3012b796 100644 --- a/model/ftn/w3psmcmd.ftn +++ b/model/src/w3psmcmd.F90 @@ -235,7 +235,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & ISBPI, BBPI0, BBPIN ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -254,7 +256,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) IY, IY0, IP, IBI, LvR INTEGER :: i, j, k, L, M, N, LL, MM, NN, LMN, & iuf, juf, ivf, jvf, icl, jcl -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: CG0, CGA, CGN, CGX, CGY, FMR, RD1, & RD2, CXMIN, CXMAX, CYMIN, CYMAX, & CXC, CYC, DTLDX, DTLDY @@ -273,7 +277,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3PSMC') +#ifdef W3_S + CALL STRACE (IENT, 'W3PSMC') +#endif ! ! 1. Preparations --------------------------------------------------- * @@ -357,37 +363,51 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) ! ! 1.b Initialize arrays ! -!/T WRITE (NDST,9010) +#ifdef W3_T + WRITE (NDST,9010) +#endif ! ULCFLX = 0. VLCFLY = 0. !Li Pass spectral element VQ to CQ and define size-1 cell CFL -!/OMPG/!$OMP Parallel DO Private(ISEA) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ISEA) +#endif DO ISEA=1, NSEA !Li Transported variable is divided by CG as in WW3 (???) CQ(ISEA) = VQ(ISEA)/CG(IK,ISEA) !Li Resetting NaNQ VQ to zero if any. JGLi18Mar2013 IF( .NOT. (CQ(ISEA) .EQ. CQ(ISEA)) ) CQ(ISEA) = 0.0 END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !Li Add current components if any to wave velocity. IF ( FLCUR ) THEN -!/OMPG/!$OMP Parallel DO Private(ISEA) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ISEA) +#endif DO ISEA=1, NSEA CXTOT(ISEA) = (CGCOS * CG(IK,ISEA) + CX(ISEA)) CYTOT(ISEA) = (CGSIN * CG(IK,ISEA) + CY(ISEA)) ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ELSE !Li No current case use group speed only. -!/OMPG/!$OMP Parallel DO Private(ISEA) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ISEA) +#endif DO ISEA=1, NSEA CXTOT(ISEA) = CGCOS * CG(IK,ISEA) CYTOT(ISEA) = CGSIN * CG(IK,ISEA) END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !Li End of IF( FLCUR ) block. ENDIF @@ -410,12 +430,16 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) !Li Convert velocity components into CFL factors. -!/OMPG/!$OMP Parallel DO Private(ISEA) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ISEA) +#endif DO ISEA=1, NSEA UCFL(ISEA) = DTLDX*CXTOT(ISEA)/CLATS(ISEA) VCFL(ISEA) = DTLDY*CYTOT(ISEA) ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !Li Initialise boundary cell CQ and Velocity values. CQ(-9:0)=0.0 @@ -443,7 +467,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) ENDIF ! Store conservative flux in FCNt advective one in AFCN -!/OMPG/!$OMP Parallel DO Private(i, M, N, FUTRN) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i, M, N, FUTRN) +#endif DO i=1, NUFc M=IJKUFc(5,i) N=IJKUFc(6,i) @@ -456,17 +482,25 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) !! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 IF( M > 0 ) THEN IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) - FUTRN ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) - FUTRN*CTRNX(M) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) - FUTRN*CTRNX(N)*CTRNX(M) ENDIF ! Also divided by another cell length as UCFL is in basic unit. -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif ! ChrisB: Re-arranged the RHS term below to make it ! valid for OMP ATMOIC directive. AFCN(M) = AFCN(M) - (FUMD(i)*UCFL(M) - FUDIFX(i)) @@ -474,33 +508,47 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) IF( N > 0 ) THEN IF( (CTRNX(M)+CTRNX(N)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(N) = FCNt(N) + FUTRN ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(N) = FCNt(N) + FUTRN*CTRNX(M)*CTRNX(N) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(N) = FCNt(N) + FUTRN*CTRNX(N) ENDIF ! Also divided by another cell length as UCFL is in basic unit. -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AFCN(N) = AFCN(N) + (FUMD(i)*UCFL(N) - FUDIFX(i)) ENDIF !! !$OMP END CRITICAL ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Store conservative update in CQA and advective update in CQ ! The side length in MF value has to be cancelled with cell length ! Note ULCFLX has been divided by the cell size inside SMCxUNO2. -!/OMPG/!$OMP Parallel DO Private(n) +#ifdef W3_OMPG +!$OMP Parallel DO Private(n) +#endif DO n=1, NSEA CQA(n)=CQ(n) + FCNt(n)/FLOAT(IJKCel(3,n)) CQ (n)=CQ(n) + AFCN(n)/FLOAT(IJKCel(3,n)) ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Call advection subs. IF( FUNO3 ) THEN @@ -511,7 +559,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) CALL SMCyUNO2r(1, NVFc, CQ, VCFL, VLCFLY, DSSD, FVMD, FVDIFY) ENDIF -!/OMPG/!$OMP Parallel DO Private(j, M, N, FVTRN) +#ifdef W3_OMPG +!$OMP Parallel DO Private(j, M, N, FVTRN) +#endif DO j=1, NVFc M=IJKVFc(5,j) N=IJKVFc(6,j) @@ -524,40 +574,58 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) !! Remove boundary cell flux update or M N > 0. JGLi28Mar2019 IF( M > 0 ) THEN IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) - FVTRN ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) - FVTRN*CTRNY(M) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) - FVTRN*CTRNY(N)*CTRNY(M) ENDIF ENDIF IF( N > 0 ) THEN IF( (CTRNY(M)+CTRNY(N)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(N) = BCNt(N) + FVTRN ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(N) = BCNt(N) + FVTRN*CTRNY(M)*CTRNY(N) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(N) = BCNt(N) + FVTRN*CTRNY(N) ENDIF ENDIF !! !$OMP END CRITICAL ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Store conservative update of CQA in CQ ! The v side length in MF value has to be cancelled with cell length !! One cosine factor is also needed to be divided for SMC grid -!/OMPG/!$OMP Parallel DO Private(n) +#ifdef W3_OMPG +!$OMP Parallel DO Private(n) +#endif DO n=1, NSEA CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)*FLOAT(IJKCel(3,n)) ) ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Polar cell needs a special area factor, one-level case. IF( ARCTC ) CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea @@ -597,7 +665,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) ENDIF ! Store fineset level conservative flux in FCNt advective one in AFCN -!/OMPG/!$OMP Parallel DO Private(i, L, M, FUTRN) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i, L, M, FUTRN) +#endif DO i=iuf, juf L=IJKUFc(5,i) M=IJKUFc(6,i) @@ -608,16 +678,24 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) IF( L > 0 ) THEN !! Add sub-grid blocking for refined cells. JGLi18Apr2018 IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(L) = FCNt(L) - FUTRN ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(L) = FCNt(L) - FUTRN*CTRNX(L) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(L) = FCNt(L) - FUTRN*CTRNX(L)*CTRNX(M) ENDIF -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif ! ChrisB: Re-arranged the RHS term below to make it ! valid for OMP ATMOIC directive. AFCN(L) = AFCN(L) - (FUMD(i)*UCFL(L)*FMR - FUDIFX(i)) @@ -625,33 +703,47 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) IF( M > 0 ) THEN !! Add sub-grid blocking for refined cells. JGLi18Apr2018 IF( (CTRNX(M)+CTRNX(L)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) + FUTRN ELSE IF( ULCFLX(i) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) + FUTRN*CTRNX(M)*CTRNX(L) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif FCNt(M) = FCNt(M) + FUTRN*CTRNX(M) ENDIF -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AFCN(M) = AFCN(M) + (FUMD(i)*UCFL(M)*FMR - FUDIFX(i)) ENDIF !! !$OMP END CRITICAL ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Store conservative update in CQA and advective update in CQ ! The side length in MF value has to be cancelled with cell y-length. ! Also divided by another cell x-size as UCFL is in size-1 unit. -!/OMPG/!$OMP Parallel DO Private(n) +#ifdef W3_OMPG +!$OMP Parallel DO Private(n) +#endif DO n=icl, jcl CQA(n)=CQ(n) + FCNt(n)/FLOAT( IJKCel(3, n)*IJKCel(4, n) ) CQ (n)=CQ(n) + AFCN(n)/FLOAT( IJKCel(3, n)*IJKCel(4, n) ) FCNt(n)=0.0 AFCN(n)=0.0 ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! ! Use 3rd order UNO3 scheme. JGLi03Sep2015 IF( FUNO3 ) THEN @@ -662,7 +754,9 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) ENDIF ! ! Store conservative flux in BCNt -!/OMPG/!$OMP Parallel DO Private(j, L, M, FVTRN) +#ifdef W3_OMPG +!$OMP Parallel DO Private(j, L, M, FVTRN) +#endif DO j=ivf, jvf L=IJKVFc(5,j) M=IJKVFc(6,j) @@ -673,44 +767,62 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) IF( L > 0 ) THEN !! Add sub-grid blocking for refined cells. JGLi18Apr2018 IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(L) = BCNt(L) - FVTRN ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(L) = BCNt(L) - FVTRN*CTRNY(L) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(L) = BCNt(L) - FVTRN*CTRNY(L)*CTRNY(M) ENDIF ENDIF IF( M > 0 ) THEN !! Add sub-grid blocking for refined cells. JGLi18Apr2018 IF( (CTRNY(M)+CTRNY(L)) .GE. 1.96 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) + FVTRN ELSE IF( VLCFLY(j) .GE. 0.0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) + FVTRN*CTRNY(M)*CTRNY(L) ELSE -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif BCNt(M) = BCNt(M) + FVTRN*CTRNY(M) ENDIF ENDIF !! !$OMP END CRITICAL ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! Store conservative update of CQA in CQ ! The v side length in MF value has to be cancelled with x-size. ! Also divided by cell y-size as VCFL is in size-1 unit. !! One cosine factor is also needed to be divided for SMC grid. -!/OMPG/!$OMP Parallel DO Private(n) +#ifdef W3_OMPG +!$OMP Parallel DO Private(n) +#endif DO n=icl, jcl CQ(n)=CQA(n) + BCNt(n)/( CLATS(n)* & & FLOAT( IJKCel(3, n)*IJKCel(4, n) ) ) BCNt(n)=0.0 ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !Li Polar cell needs a special area factor, multi-level case. IF( ARCTC .AND. jcl .EQ. NSEA ) THEN CQ(NSEA) = CQA(NSEA) + BCNt(NSEA)*PCArea @@ -756,28 +868,46 @@ SUBROUTINE W3PSMC ( ISP, DTG, VQ ) ! ! 4. Store results in VQ in proper format --------------------------- * ! -!/OMPG/!$OMP Parallel DO Private(ISEA) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ISEA) +#endif DO ISEA=1, NSEA VQ(ISEA) = MAX ( 0. , CQ(ISEA)*CG(IK,ISEA) ) END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif ! RETURN ! ! Formats ! -!/T 9001 FORMAT (' TEST W3PSMC : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) -!/T 9003 FORMAT (' TEST W3PSMC : NO DISPERSION CORRECTION ') -! -!/T 9010 FORMAT (' TEST W3PSMC : INITIALIZE ARRAYS') -! -!/T 9020 FORMAT (' TEST W3PSMC : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & -!/T I6,')') -!/T1 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) -!/T 9022 FORMAT (' TEST W3PSMC : CORRECTING FOR CURRENT') -! -!/T 9040 FORMAT (' TEST W3PSMC : FIELD AFTER PROP. (NSEA=',I6,')') -!/T2 9041 FORMAT (1X,I6,2I5,E12.4) +#ifdef W3_T + 9001 FORMAT (' TEST W3PSMC : ISP, ITH, IK, COS-SIN :',I8,2I4,2F7.3) + 9003 FORMAT (' TEST W3PSMC : NO DISPERSION CORRECTION ') +#endif +! +#ifdef W3_T + 9010 FORMAT (' TEST W3PSMC : INITIALIZE ARRAYS') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3PSMC : CALCULATING LCFLX/Y AND DSS/NN (NSEA=', & + I6,')') +#endif +#ifdef W3_T1 + 9021 FORMAT (1X,I6,2I5,E12.4,2f7.3) +#endif +#ifdef W3_T + 9022 FORMAT (' TEST W3PSMC : CORRECTING FOR CURRENT') +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3PSMC : FIELD AFTER PROP. (NSEA=',I6,')') +#endif +#ifdef W3_T2 + 9041 FORMAT (1X,I6,2I5,E12.4) +#endif !/ !/ End of W3PSMC ----------------------------------------------------- / !/ @@ -900,7 +1030,9 @@ SUBROUTINE W3KRTN ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & USE W3ADATMD, ONLY: ITIME USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, ONLY: NDSE, NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -908,7 +1040,9 @@ SUBROUTINE W3KRTN ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ Parameter list !/ INTEGER, INTENT(IN) :: ISEA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, INTENT(IN) :: FACTH, FACK, CTHG0, CG(0:NK+1), & WN(0:NK+1), DEPTH, DDDX, DDDY, & ALFLMT(NTH), CX, CY, DCXDX, DCXDY, & @@ -929,7 +1063,9 @@ SUBROUTINE W3KRTN ( ISEA, FACTH, FACK, CTHG0, CG, WN, DEPTH, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3KRTN') +#ifdef W3_S + CALL STRACE (IENT, 'W3KRTN') +#endif ! ! 1. Preparation for point ------------------------------------------ * ! Array with partial derivative of sigma versus depth @@ -1113,14 +1249,18 @@ SUBROUTINE SMCxUNO2(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 ! CNST0=AKDif*MRFct*FTS -!/OMPG/!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8,CNST9) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & +!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8,CNST9) +#endif ! Notice an extra side length L is multiplied to mid-flux to give correct ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO i=NUA, NUB @@ -1188,9 +1328,13 @@ SUBROUTINE SMCxUNO2(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCxUNO2 ended.' @@ -1225,10 +1369,14 @@ SUBROUTINE SMCyUNO2(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 ! CNST0=AKDif*MRFct*FTS -!/OMPG/!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & +!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST8) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO j=NVA, NVB @@ -1303,9 +1451,13 @@ SUBROUTINE SMCyUNO2(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCyUNO2 ended.' @@ -1336,10 +1488,14 @@ SUBROUTINE SMCxUNO2r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & +!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO i=NUA, NUB @@ -1400,9 +1556,13 @@ SUBROUTINE SMCxUNO2r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCxUNO2r ended.' @@ -1429,10 +1589,14 @@ SUBROUTINE SMCyUNO2r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST8) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & +!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST8) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO j=NVA, NVB @@ -1490,9 +1654,13 @@ SUBROUTINE SMCyUNO2r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCyUNO2r ended.' @@ -1530,10 +1698,14 @@ SUBROUTINE SMCxUNO3(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & +!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO i=NUA, NUB @@ -1630,9 +1802,13 @@ SUBROUTINE SMCxUNO3(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX, FTS) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCxUNO3 ended.' @@ -1668,10 +1844,14 @@ SUBROUTINE SMCyUNO3(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) ! Uniform diffusion coefficient for all sizes. JGLi24Feb2012 ! CNST0=AKDif*MRFct*FTS -!/OMPG/!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & +!$OMP& Private(CNST,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO j=NVA, NVB @@ -1778,9 +1958,13 @@ SUBROUTINE SMCyUNO3(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY, FTS) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCyUNO3 ended.' @@ -1811,10 +1995,14 @@ SUBROUTINE SMCxUNO3r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, ij, K, L, M, N), & +!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO i=NUA, NUB @@ -1894,9 +2082,13 @@ SUBROUTINE SMCxUNO3r(NUA, NUB, CF, UC, UFLX, AKDif, FU, FX) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCxUNO3r ended.' @@ -1924,10 +2116,14 @@ SUBROUTINE SMCyUNO3r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) ! proportion of flux into the cells. This length will be removed by the ! cell length when the tracer concentration is updated. -!/OMPG/!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(j, K, L, M, N), & +!$OMP& Private(CNST,CNST4,CNST5,CNST6,CNST7,CNST8,CNST9) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO j=NVA, NVB @@ -2008,9 +2204,13 @@ SUBROUTINE SMCyUNO3r(NVA, NVB, CF, VC, VFLY, AKDif, FV, FY) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif ! 999 PRINT*, ' Sub SMCyUNO3r ended.' @@ -2063,10 +2263,14 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) DX0I = MRFct/ ( SX * DERA * RADIUS ) DY0I = MRFct/ ( SY * DERA * RADIUS ) -!/OMPG/!$OMP Parallel Default(Shared), Private(i, j, K, L, M, N), & -!/OMPG/!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, j, K, L, M, N), & +!$OMP& Private(CNST,CNST0,CNST1,CNST2,CNST3,CNST4,CNST5,CNST6) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif !! Calculate x-gradient by averaging U-face gradients. DO i=1, NUFc @@ -2088,18 +2292,26 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) ! Side gradients over 2 cell lengths for central cell. ! Face size factor is also included for average. CNST5=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) -!/B4B!/OMPG CNST5=INT(CNST5 * 1.0e6) ! CB: B4B +#ifdef W3_B4B +#ifdef W3_OMPG + CNST5=INT(CNST5 * 1.0e6) ! CB: B4B +#endif +#endif !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 !! !$OMP CRITICAL ! Store side gradient in two neighbouring cells !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 IF( L > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AUN(L) = AUN(L) + CNST5 ENDIF IF( M > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AUN(M) = AUN(M) + CNST5 ENDIF !! !$OMP END CRITICAL @@ -2107,17 +2319,25 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) ENDIF END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/B4B!/OMPG/!$OMP SINGLE -!/B4B!/OMPG AUN = AUN / 1.0e6 ! CB B4B -!/B4B!/OMPG/!$OMP END SINGLE +#ifdef W3_B4B +#ifdef W3_OMPG +!$OMP SINGLE + AUN = AUN / 1.0e6 ! CB B4B +!$OMP END SINGLE +#endif +#endif ! Assign averaged side-gradient to GrdX, plus latitude factor ! Note averaging over 2 times of cell y-width factor but AUN ! has already been divied by two cell lengths. -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif DO n=1, NSEA ! Cell y-size IJKCel(4,i) is used to cancel the face size-factor in AUN. @@ -2127,9 +2347,13 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) ENDDO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif !! Calculate y-gradient by averaging V-face gradients. DO j=1, NVFc @@ -2151,18 +2375,26 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) ! Side gradients over 2 cell lengths for central cell. ! Face size factor is also included for average. CNST6=CNST1*(CVF(M)-CVF(L))/(CNST2+CNST3) -!/B4B!/OMPG CNST6 = int(CNST6 * 1.0e6) ! CB B4B +#ifdef W3_B4B +#ifdef W3_OMPG + CNST6 = int(CNST6 * 1.0e6) ! CB B4B +#endif +#endif !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 !! !$OMP CRITICAL !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 IF( L > 0 ) THEN ! Store side gradient in two neighbouring cells -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AVN(L) = AVN(L) + CNST6 ENDIF IF( M > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AVN(M) = AVN(M) + CNST6 ENDIF !! !$OMP END CRITICAL @@ -2170,13 +2402,21 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) ENDIF END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/B4B!/OMPG/!$OMP SINGLE -!/B4B!/OMPG AVN = AVN / 1.0e6 !CB B4B -!/B4B!/OMPG/!$OMP END SINGLE +#ifdef W3_B4B +#ifdef W3_OMPG +!$OMP SINGLE + AVN = AVN / 1.0e6 !CB B4B +!$OMP END SINGLE +#endif +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif ! Assign averaged side-gradient to GrdY. DO n=1, NSEA @@ -2186,9 +2426,13 @@ SUBROUTINE SMCGradn(CVQ, GrdX, GrdY, L0r1) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif !!Li Y-gradient for polar cell in Arctic part is set to zero. IF( ARCTC ) GrdY(NSEA) = 0.0 @@ -2230,10 +2474,14 @@ SUBROUTINE SMCAverg(CVQ) !!Li Save polar cell value if any. CNST0 = CVQ(NSEA) -!/OMPG/!$OMP Parallel Default(Shared), Private(i, j, L, M, n), & -!/OMPG/!$OMP& Private(CNST3,CNST4,CNST5,CNST6) +#ifdef W3_OMPG +!$OMP Parallel Default(Shared), Private(i, j, L, M, n), & +!$OMP& Private(CNST3,CNST4,CNST5,CNST6) +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif !! Calculate x-gradient by averaging U-face gradients. DO i=1, NUFc @@ -2244,31 +2492,45 @@ SUBROUTINE SMCAverg(CVQ) ! Multi-resolution SMC grid requires flux multiplied by face factor. CNST5=Real( IJKUFc(3,i) )*(CVF(M)+CVF(L)) -!/B4B/!OMPG CNST5=int(CNST5 * 1.0e6) +#ifdef W3_B4B +!OMPG CNST5=int(CNST5 * 1.0e6) +#endif !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 !! !$OMP CRITICAL ! Store side gradient in two neighbouring cells !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 IF( L > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AUN(L) = AUN(L) + CNST5 ENDIF IF( M > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AUN(M) = AUN(M) + CNST5 ENDIF !! !$OMP END CRITICAL END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/B4B!/OMPG/!$OMP SINGLE -!/B4B!/OMPG AUN = AUN / 1.0e6 !CB B4B -!/B4B!/OMPG/!$OMP END SINGLE +#ifdef W3_B4B +#ifdef W3_OMPG +!$OMP SINGLE + AUN = AUN / 1.0e6 !CB B4B +!$OMP END SINGLE +#endif +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif !! Calculate y-gradient by averaging V-face gradients. DO j=1, NVFc @@ -2279,31 +2541,47 @@ SUBROUTINE SMCAverg(CVQ) ! Face size is required for multi-resolution grid. CNST6=Real( IJKVfc(3,j) )*(CVF(M)+CVF(L)) -!/B4B!/OMPG CNST6=INT(CNST6 * 1e6) +#ifdef W3_B4B +#ifdef W3_OMPG + CNST6=INT(CNST6 * 1e6) +#endif +#endif !! Replace CRITICAL with ATOMIC. JGLi15Jan2019 !! !$OMP CRITICAL ! Store side gradient in two neighbouring cells !! Remove boundary cell flux update or L M > 0. JGLi28Mar2019 IF( L > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AVN(L) = AVN(L) + CNST6 ENDIF IF( M > 0 ) THEN -!/OMPG/!$OMP ATOMIC +#ifdef W3_OMPG +!$OMP ATOMIC +#endif AVN(M) = AVN(M) + CNST6 ENDIF !! !$OMP END CRITICAL END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/B4B!/OMPG/!$OMP SINGLE -!/B4B!/OMPG AVN = AVN / 1.0e6 !CB B4B -!/B4B!/OMPG/!$OMP END SINGLE +#ifdef W3_B4B +#ifdef W3_OMPG +!$OMP SINGLE + AVN = AVN / 1.0e6 !CB B4B +!$OMP END SINGLE +#endif +#endif -!/OMPG/!$OMP DO +#ifdef W3_OMPG +!$OMP DO +#endif ! Assign averaged value back to CVQ. DO n=1, NSEA @@ -2316,9 +2594,13 @@ SUBROUTINE SMCAverg(CVQ) END DO -!/OMPG/!$OMP END DO +#ifdef W3_OMPG +!$OMP END DO +#endif -!/OMPG/!$OMP END Parallel +#ifdef W3_OMPG +!$OMP END Parallel +#endif !!Li Polar cell (if any) keep original value. IF( ARCTC ) CVQ(NSEA) = CNST0 @@ -2526,11 +2808,15 @@ SUBROUTINE SMCDHXY HCel(1:NSEA)= DW(1:NSEA) !! Reset shallow water depth with minimum depth -!/OMPG/!$OMP Parallel DO Private(k) +#ifdef W3_OMPG +!$OMP Parallel DO Private(k) +#endif DO k=1, NSEA IF(DW(k) .LT. DMIN) HCel(k)=DMIN ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !! Initialize full grid gradient arrays DDDX = 0. @@ -2547,7 +2833,9 @@ SUBROUTINE SMCDHXY DHDY(1:NSEA) = GrHy !! Apply limiter to depth-gradient and copy to full grid. -!/OMPG/!$OMP Parallel DO Private(i,j,k,m,n, CNST0, CNST1, CNST2) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i,j,k,m,n, CNST0, CNST1, CNST2) +#endif DO n=1,NSEA ! A limiter of gradient <= 0.1 is applied. @@ -2573,12 +2861,18 @@ SUBROUTINE SMCDHXY ENDIF END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !! Calculate the depth gradient limiter for refraction. -!/T L = 0 !CB - added T switch +#ifdef W3_T + L = 0 !CB - added T switch +#endif -!/OMPG/!$OMP Parallel DO Private(i, n, CNST4, CNST6) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i, n, CNST4, CNST6) +#endif DO n=1,NSEA !Li Work out magnitude of depth gradient @@ -2587,9 +2881,15 @@ SUBROUTINE SMCDHXY !Li Directional depedent depth gradient limiter. JGLi16Jun2011 IF ( CNST4 .GT. 1.0E-5 ) THEN -!/T!/OMPG/!$OMP ATOMIC Update !CB - added T switch -!/T L = L + 1 !CB - added T switch -!/T!/OMPG/!$OMP END ATOMIC !CB - added T switch +#ifdef W3_T +#ifdef W3_OMPG +!$OMP ATOMIC Update !CB - added T switch +#endif + L = L + 1 !CB - added T switch +#ifdef W3_OMPG +!$OMP END ATOMIC !CB - added T switch +#endif +#endif DO i=1, NTH !Li Refraction is done only when depth gradient is non-zero. @@ -2599,19 +2899,27 @@ SUBROUTINE SMCDHXY DHLMT(i,n)=MIN(Refran, 0.75*MIN(CNST6,ABS(PI-CNST6)))/DTH END DO !Li Output some values for inspection. JGLi22Jul2011 -!/T IF( MOD(n, 1000) .EQ. 0 ) & -!/T & WRITE(NDST,'(i8,18F5.1)' ) n, (DHLMT(i,n), i=1,18) +#ifdef W3_T + IF( MOD(n, 1000) .EQ. 0 ) & + & WRITE(NDST,'(i8,18F5.1)' ) n, (DHLMT(i,n), i=1,18) +#endif ELSE DHLMT(:,n) = 0.0 ENDIF ENDDO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif -!/T WRITE(NDST,*) ' No. Refraction points =', L +#ifdef W3_T + WRITE(NDST,*) ' No. Refraction points =', L +#endif -!/T 999 PRINT*, ' Sub SMCDHXY ended.' +#ifdef W3_T + 999 PRINT*, ' Sub SMCDHXY ended.' +#endif RETURN END SUBROUTINE SMCDHXY @@ -2643,7 +2951,9 @@ SUBROUTINE SMCDCXY CXCY(1:NSEA)= CX(1:NSEA) !! Initialize full grid gradient arrays -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'Before assigning DCXDX to ZERO' +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'Before assigning DCXDX to ZERO' +#endif DCXDX = 0.0 DCXDY = 0.0 @@ -2651,7 +2961,9 @@ SUBROUTINE SMCDCXY CALL SMCGradn(CXCY, GrHx, GrHy, L) !! Apply limiter to CX-gradient and copy to full grid. -!/OMPG/!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) +#endif DO n=1,NSEA ! A limiter of gradient <= 0.01 is applied. @@ -2677,9 +2989,13 @@ SUBROUTINE SMCDCXY DCXDY(j:j+m-1,i:i+k-1) = GrHy(n) END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif -!/DEBUGDCXDX WRITE(740+IAPROC,*) 'After non-trivial assination to DCXDX array' +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'After non-trivial assination to DCXDX array' +#endif !! Assign current CY speed to CXCY and set negative cells. ! CXCY(-9:0) = 0.0 @@ -2695,7 +3011,9 @@ SUBROUTINE SMCDCXY CALL SMCGradn(CXCY, GrHx, GrHy, L) !! Apply limiter to CX-gradient and copy to full grid. -!/OMPG/!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) +#ifdef W3_OMPG +!$OMP Parallel DO Private(i, j, k, m, n, CNST0, CNST1, CNST2) +#endif DO n=1,NSEA !! A limiter of gradient <= 0.1 is applied. @@ -2721,9 +3039,13 @@ SUBROUTINE SMCDCXY DCYDY(j:j+m-1,i:i+k-1) = GrHy(n) END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif -!/T 999 PRINT*, ' Sub SMCDCXY ended.' +#ifdef W3_T + 999 PRINT*, ' Sub SMCDCXY ended.' +#endif RETURN END SUBROUTINE SMCDCXY @@ -2818,17 +3140,23 @@ SUBROUTINE W3GATHSMC ( ISPEC, FIELD ) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, NCel, MAPSF USE W3WDATMD, ONLY: A => VA -!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & -!/MPI NSPLOC, NRQSG2, IRQSG2, GSTORE -!/MPI USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, GSTORE + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -2839,94 +3167,124 @@ SUBROUTINE W3GATHSMC ( ISPEC, FIELD ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/SHRD INTEGER :: ISEA, IXY -!/MPI INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & -!/MPI IOFF, IERR_MPI, JSEA, ISEA, & -!/MPI IXY, IS0, IB0, NPST, J -!/S INTEGER, SAVE :: IENT +#ifdef W3_SHRD + INTEGER :: ISEA, IXY +#endif +#ifdef W3_MPI + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & + IOFF, IERR_MPI, JSEA, ISEA, & + IXY, IS0, IB0, NPST, J +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3GATH') +#ifdef W3_S + CALL STRACE (IENT, 'W3GATH') +#endif ! ! FIELD = 0. ! ! 1. Shared memory version ------------------------------------------ / ! -!/SHRD DO ISEA=1, NSEA -!/SHRD FIELD(ISEA) = A(ISPEC,ISEA) -!/SHRD END DO +#ifdef W3_SHRD + DO ISEA=1, NSEA + FIELD(ISEA) = A(ISPEC,ISEA) + END DO +#endif ! -!/SHRD RETURN +#ifdef W3_SHRD + RETURN +#endif ! ! 2. Distributed memory version ( MPI ) ----------------------------- / ! 2.a Update counters ! -!/MPI ISPLOC = ISPLOC + 1 -!/MPI IBFLOC = IBFLOC + 1 -!/MPI IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 +#ifdef W3_MPI + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 +#endif ! ! 2.b Check status of present buffer ! 2.b.1 Scatter (send) still in progress, wait to end ! -!/MPI IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI BSTAT(IBFLOC) = 0 -!/MPI END IF +#ifdef W3_MPI + IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IBFLOC) = 0 + END IF +#endif ! ! 2.b.2 Gather (recv) not yet posted, post now ! -!/MPI IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN -!/MPI BSTAT(IBFLOC) = 1 -!/MPI BISPL(IBFLOC) = ISPLOC -!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) -!/MPI END IF +#ifdef W3_MPI + IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN + BSTAT(IBFLOC) = 1 + BISPL(IBFLOC) = ISPLOC + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + END IF +#endif ! ! 2.c Put local spectral densities in store ! -!/MPI DO JSEA=1, NSEAL -!/MPI GSTORE(IAPROC+(JSEA-1)*NAPROC,IBFLOC) = A(ISPEC,JSEA) -!/MPI END DO +#ifdef W3_MPI + DO JSEA=1, NSEAL + GSTORE(IAPROC+(JSEA-1)*NAPROC,IBFLOC) = A(ISPEC,JSEA) + END DO +#endif ! ! 2.d Wait for remote spectral densities ! -!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) +#ifdef W3_MPI + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) +#endif ! ! 2.e Convert storage array to field. ! -!/MPI DO ISEA=1, NSEA -!/MPI FIELD(ISEA) = GSTORE(ISEA,IBFLOC) -!/MPI END DO +#ifdef W3_MPI + DO ISEA=1, NSEA + FIELD(ISEA) = GSTORE(ISEA,IBFLOC) + END DO +#endif ! ! 2.f Pre-fetch data in available buffers ! -!/MPI IS0 = ISPLOC -!/MPI IB0 = IBFLOC -!/MPI NPST = 0 -! -!/MPI DO J=1, MPIBUF-1 -!/MPI IS0 = IS0 + 1 -!/MPI IF ( IS0 .GT. NSPLOC ) EXIT -!/MPI IB0 = 1 + MOD(IB0,MPIBUF) -!/MPI IF ( BSTAT(IB0) .EQ. 0 ) THEN -!/MPI BSTAT(IB0) = 1 -!/MPI BISPL(IB0) = IS0 -!/MPI IOFF = 1 + (IS0-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) -!/MPI NPST = NPST + 1 -!/MPI END IF -!/MPI IF ( NPST .GE. 2 ) EXIT -!/MPI END DO +#ifdef W3_MPI + IS0 = ISPLOC + IB0 = IBFLOC + NPST = 0 +#endif +! +#ifdef W3_MPI + DO J=1, MPIBUF-1 + IS0 = IS0 + 1 + IF ( IS0 .GT. NSPLOC ) EXIT + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 0 ) THEN + BSTAT(IB0) = 1 + BISPL(IB0) = IS0 + IOFF = 1 + (IS0-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + NPST = NPST + 1 + END IF + IF ( NPST .GE. 2 ) EXIT + END DO +#endif ! -!/MPI RETURN +#ifdef W3_MPI + RETURN +#endif ! !/ End of W3GATHSMC ----------------------------------------------------- / !/ @@ -3012,18 +3370,26 @@ SUBROUTINE W3SCATSMC ( ISPEC, MAPSTA, FIELD ) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NCel, NSEAL, MAPSF USE W3WDATMD, ONLY: A => VA -!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & -!/MPI NSPLOC, NRQSG2, IRQSG2, SSTORE +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, SSTORE +#endif USE W3ODATMD, ONLY: NDST -!/MPI USE W3ODATMD, ONLY: IAPROC, NAPROC +#ifdef W3_MPI + USE W3ODATMD, ONLY: IAPROC, NAPROC +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -3034,94 +3400,128 @@ SUBROUTINE W3SCATSMC ( ISPEC, MAPSTA, FIELD ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/SHRD INTEGER :: ISEA, IXY -!/MPI INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & -!/MPI STATUS(MPI_STATUS_SIZE,NSPEC), & -!/MPI JSEA, IB0 -!/S INTEGER, SAVE :: IENT -!/MPI LOGICAL :: DONE +#ifdef W3_SHRD + INTEGER :: ISEA, IXY +#endif +#ifdef W3_MPI + INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & + STATUS(MPI_STATUS_SIZE,NSPEC), & + JSEA, IB0 +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_MPI + LOGICAL :: DONE +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SCAT') +#ifdef W3_S + CALL STRACE (IENT, 'W3SCAT') +#endif ! ! 1. Shared memory version ------------------------------------------ * ! -!/SHRD DO ISEA=1, NSEA -!/SHRD IXY = MAPSF(ISEA,3) -!/SHRD IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(ISEA) -!/SHRD END DO +#ifdef W3_SHRD + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(ISEA) + END DO +#endif ! -!/SHRD RETURN +#ifdef W3_SHRD + RETURN +#endif ! ! 2. Distributed memory version ( MPI ) ----------------------------- * ! 2.a Initializations ! ! 2.b Convert full grid to sea grid, active points only ! -!/MPI DO ISEA=1, NSEA -!/MPI IXY = MAPSF(ISEA,3) -!/MPI IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(ISEA) -!/MPI END DO +#ifdef W3_MPI + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(ISEA) + END DO +#endif ! ! 2.c Send spectral densities to appropriate remote ! -!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) -!/MPI BSTAT(IBFLOC) = 2 +#ifdef W3_MPI + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) + BSTAT(IBFLOC) = 2 +#endif ! ! 2.d Save locally stored results ! -!/MPI DO JSEA=1, NSEAL -!/MPI !!Li ISEA = IAPROC+(JSEA-1)*NAPROC -!/MPI ISEA = MIN( IAPROC+(JSEA-1)*NAPROC, NSEA ) -!/MPI A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) -!/MPI END DO +#ifdef W3_MPI + DO JSEA=1, NSEAL + !!Li ISEA = IAPROC+(JSEA-1)*NAPROC + ISEA = MIN( IAPROC+(JSEA-1)*NAPROC, NSEA ) + A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) + END DO +#endif ! ! 2.e Check if any sends have finished ! -!/MPI IB0 = IBFLOC -! -!/MPI DO J=1, MPIBUF -!/MPI IB0 = 1 + MOD(IB0,MPIBUF) -!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) THEN -!/MPI CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & -!/MPI STATUS, IERR_MPI ) -!/MPI ELSE -!/MPI DONE = .TRUE. -!/MPI END IF -!/MPI IF ( DONE .AND. NRQSG2.GT.0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI IF ( DONE ) THEN -!/MPI BSTAT(IB0) = 0 -!/MPI END IF -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + IB0 = IBFLOC +#endif +! +#ifdef W3_MPI + DO J=1, MPIBUF + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) THEN + CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & + STATUS, IERR_MPI ) + ELSE + DONE = .TRUE. + END IF + IF ( DONE .AND. NRQSG2.GT.0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + IF ( DONE ) THEN + BSTAT(IB0) = 0 + END IF + END IF + END DO +#endif ! ! 2.f Last component, finish message passing, reset buffer control ! -!/MPI IF ( ISPLOC .EQ. NSPLOC ) THEN -! -!/MPI DO IB0=1, MPIBUF -!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN -!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 -!/MPI IF ( NRQSG2 .GT. 0 ) CALL & -!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & -!/MPI STATUS, IERR_MPI ) -!/MPI BSTAT(IB0) = 0 -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + IF ( ISPLOC .EQ. NSPLOC ) THEN +#endif +! +#ifdef W3_MPI + DO IB0=1, MPIBUF + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IB0) = 0 + END IF + END DO +#endif ! -!/MPI ISPLOC = 0 -!/MPI IBFLOC = 0 +#ifdef W3_MPI + ISPLOC = 0 + IBFLOC = 0 +#endif ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! -!/MPI RETURN +#ifdef W3_MPI + RETURN +#endif ! ! Formats ! @@ -3190,7 +3590,9 @@ SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) USE W3GDATMD USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -3205,8 +3607,10 @@ SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) REAL :: XI0, YJ0, DXG, DYG, DX1, DY1 INTEGER :: I1, I3, J2, J4, MRF, ij, ijp, NSEM -!/S INTEGER :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SMCELL') +#ifdef W3_S + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'W3SMCELL') +#endif !! 1. Convert regular grid parameters into SMC grid origin and increments. DXG = GRIDS(IMOD)%SX @@ -3220,7 +3624,9 @@ SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) !! 2. Loop over listed cells and work out their centre coordinates. -!/OMPG/!$OMP Parallel DO Private(ij, ijp, I1, J2, I3, J4 ) +#ifdef W3_OMPG +!$OMP Parallel DO Private(ij, ijp, I1, J2, I3, J4 ) +#endif DO ij = 1, NC ijp = IDCL(ij) !!Li Return South Pole lon-lat values for any ids < 1 or > NSEA @@ -3240,7 +3646,9 @@ SUBROUTINE W3SMCELL( IMOD, NC, IDCl, XLon, YLat ) YLat(ij) = YJ0 + ( FLOAT(J2) + 0.5*FLOAT(J4) )*DY1 ENDIF END DO -!/OMPG/!$OMP END Parallel DO +#ifdef W3_OMPG +!$OMP END Parallel DO +#endif !! 3. Wrap negative logitudes into [0, 360) range. WHERE( XLon < 0.0 ) XLon = XLon + 360.0 @@ -3304,7 +3712,9 @@ SUBROUTINE W3SMCGMP( IMOD, NC, XLon, YLat, IDCl ) USE W3GDATMD USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -3318,8 +3728,10 @@ SUBROUTINE W3SMCGMP( IMOD, NC, XLon, YLat, IDCl ) INTEGER, Dimension(NC) :: IX1, JY1 REAL :: XI0, YJ0, DXG, DYG, DX1, DY1, XLow(NC) INTEGER :: I1, I3, J2, J4, ij, ijp, MRF, NSEM, NFund -!/S INTEGER :: IENT = 0 -!/S CALL STRACE (IENT, 'W3SMCGMP') +#ifdef W3_S + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'W3SMCGMP') +#endif !! 1. Convert XLon YLat into SMC grid indexes in present SMC grid. DXG = GRIDS(IMOD)%SX diff --git a/model/ftn/w3ref1md.ftn b/model/src/w3ref1md.F90 similarity index 74% rename from model/ftn/w3ref1md.ftn rename to model/src/w3ref1md.F90 index 4cc61aa50..87a54d1a1 100644 --- a/model/ftn/w3ref1md.ftn +++ b/model/src/w3ref1md.F90 @@ -152,11 +152,15 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & SIG2, DSII, IOBPD, GTYPE, UNGTYPE, MAPFS, & CLGTYPE, RLGTYPE, SMCTYPE USE W3GDATMD, ONLY : XYB, CLATS, HPFAC, HQFAC, SX, SY, SI -!/IG1 USE W3GDATMD, ONLY : IGPARS -!/IG1 USE W3GIG1MD -!/IG1 USE W3CANOMD, ONLY : W3ADD2NDORDER -!/IG1 USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_IG1 + USE W3GDATMD, ONLY : IGPARS + USE W3GIG1MD + USE W3CANOMD, ONLY : W3ADD2NDORDER + USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ ! IMPLICIT NONE @@ -178,7 +182,9 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & INTEGER :: ISPECI, ISPEC, IK, ITH, ITH2, ITH3, ITH2X, ITH2Y, & NRS, IK1 INTEGER :: ISEA, ICALC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: IGBCOVERWRITE, IGSWELLMAX REAL :: R1, R2, R3, R4, R2X, R2Y, DEPTHIG REAL :: DELA, DELX, DELY, FACX @@ -186,22 +192,30 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & RAMP1, RAMP2, RAMP4, MICHEFAC, SLOPE REAL :: HS, HIG, HIG1, HIG2, EB, SB, EMEANA, FMEAN2, & FMEANA, FREQIG, EFIG, EFIG1, SQRTH, SMEANA -!/IG1 INTEGER :: NKIG,NSPECIG,NSPECIGSTART, I1, I2 -!/IG1 REAL :: ATMP(NSPEC),ATMP2(NSPEC), STMP1(NSPEC), & -!/IG1 STMP2(NSPEC), WNB(NK), CGB(NK), SIX, IGFAC1, IGFAC2 +#ifdef W3_IG1 + INTEGER :: NKIG,NSPECIG,NSPECIGSTART, I1, I2 + REAL :: ATMP(NSPEC),ATMP2(NSPEC), STMP1(NSPEC), & + STMP2(NSPEC), WNB(NK), CGB(NK), SIX, IGFAC1, IGFAC2 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SREF') +#ifdef W3_S + CALL STRACE (IENT, 'W3SREF') +#endif ! ! 0. Initializations ------------------------------------------------ * ! -!/IG1 IGBCOVERWRITE =(MOD( NINT(IGPARS(4)),2).EQ.1) -!/IG1 IGSWELLMAX =( NINT(IGPARS(4)).GE.2) +#ifdef W3_IG1 + IGBCOVERWRITE =(MOD( NINT(IGPARS(4)),2).EQ.1) + IGSWELLMAX =( NINT(IGPARS(4)).GE.2) +#endif ! This following line is a quick fix before the bug is understood .... -!/IG1 IF (GTYPE.EQ.UNGTYPE) IGSWELLMAX =.FALSE. -!/IG1 IGFAC1 = 0.25 -!/IG1 IGFAC2 = 0.25 +#ifdef W3_IG1 + IF (GTYPE.EQ.UNGTYPE) IGSWELLMAX =.FALSE. + IGFAC1 = 0.25 + IGFAC2 = 0.25 +#endif EMEANA = 0. FMEANA = 0. FMEAN2 = 0. @@ -233,8 +247,10 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & END IF IK1=1 -!/IG1 IK1=NINT(IGPARS(5))+1 -!/IG1 NSPECIGSTART = NINT(IGPARS(5))*NTH +#ifdef W3_IG1 + IK1=NINT(IGPARS(5))+1 + NSPECIGSTART = NINT(IGPARS(5))*NTH +#endif DO IK=IK1, NK EB = 0. DO ITH=1, NTH @@ -252,121 +268,127 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & ! 1. Sets reflection term to zero ! ICALC=1 -!/IG1 STMP1 = 0. -!/IG1 STMP2 = 0. +#ifdef W3_IG1 + STMP1 = 0. + STMP2 = 0. +#endif HS=4.*SQRT(EMEANA) -!/IG1 ATMP(:)=A(:) ! the IG energy will be added to this ATMP -!/IG1 ATMP2(:)=A(:) ! this is really to keep in memory the original spectrum -!/IG1 IF (IGBCOVERWRITE.AND.REFLC(1).GT.0) THEN -!/IG1 IGFAC1 = 1. -!/IG1 ATMP2(1:NSPECIGSTART)=0. -!/IG1 END IF -!/IG1! -!/IG1! resets IG band energy to zero -!/IG1! -!/IG1 DO ICALC=1,2 +#ifdef W3_IG1 + ATMP(:)=A(:) ! the IG energy will be added to this ATMP + ATMP2(:)=A(:) ! this is really to keep in memory the original spectrum + IF (IGBCOVERWRITE.AND.REFLC(1).GT.0) THEN + IGFAC1 = 1. + ATMP2(1:NSPECIGSTART)=0. + END IF +! +! resets IG band energy to zero +! + DO ICALC=1,2 +#endif S = 0. -!/IG1 IF (IGBCOVERWRITE) A(1:NSPECIGSTART)=0. -!/IG1 IF (ICALC.EQ.1) A=ATMP2 -!/IG1 IF (ICALC.EQ.2) THEN -!/IG1! -!/IG1! 1.1 Replaces IG part by forced IG -!/IG1! -!/IG1! determines highest IG frequency -!/IG1! -!/IG1 IF (IGSWELLMAX) THEN -!/IG1 NKIG=NK -!/IG1 ELSE -!/IG1 NKIG=NINT(IGPARS(5)) -!/IG1 ENDIF -!/IG1 FREQIG=SIG(NINT(IGPARS(5)))*TPIINV -!/IG1! -!/IG1 NSPECIG=NKIG*NTH -!/IG1 ATMP(1:NSPECIGSTART)=0. ! flat bottom approximation (Hasselmann 1962) -!/IG1 ! is not valid for long waves -!/IG1 IF (NINT(IGPARS(3)).EQ.1) THEN ! IGPARS(3) = IGSOURCE -!/IG1 IF (NINT(IGPARS(8)).EQ.1) THEN ! in this case, uses depth at break point -!/IG1 DEPTHIG=MAX(1.,HS/0.3) ! to be modified later with a proper gamma -!/IG1 ELSE -!/IG1 DEPTHIG=DEPTH -!/IG1 END IF -!/IG1 IF (IGPARS(10).GT.0.) DEPTHIG = IGPARS(10) ! fixed depth for 2nd order calculation -!/IG1! -!/IG1!/ --- INLINED WAVNU1 (START) ---------------------------------------- / -!/IG1! -!/IG1 DO IK=1, NK -!/IG1 SQRTH = SQRT(DEPTHIG) -!/IG1 SIX = SIG(IK) * SQRTH -!/IG1 I1 = INT(SIX/DSIE) -!/IG1 IF (I1.LE.N1MAX) THEN -!/IG1 I2 = I1 + 1 -!/IG1 R1 = SIX/DSIE - REAL(I1) -!/IG1 R2 = 1. - R1 -!/IG1 WNB(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH -!/IG1 CGB(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH -!/IG1 ELSE -!/IG1 WNB(IK) = SIG(IK)*SIG(IK)/GRAV -!/IG1 CGB(IK) = 0.5 * GRAV / SIG(IK) -!/IG1 END IF -!/IG1 END DO -!/IG1! -!/IG1!/ --- INLINED WAVNU1 (END) ------------------------------------------ / -!/IG1! -!/IG1 IF (NINT(IGPARS(1)).EQ.1) THEN ! IGPARS(1) = IGMETHOD -!/IG1 CALL W3ADDIG(ATMP,DEPTHIG,WNB,CGB,1) -!/IG1 ELSE -!/IG1 CALL W3ADD2NDORDER(ATMP,DEPTHIG,WNB,CGB,1) -!/IG1 END IF -!/IG1! Transforms energy back to proper depth -!/IG1 DO IK=1,NKIG -!/IG1 ATMP(1+(IK-1)*NTH:IK*NTH)=ATMP(1+(IK-1)*NTH:IK*NTH)*(CGB(IK)*WN(IK))/(CG(IK)*WNB(IK)) -!/IG1 END DO -!/IG1 A(1:NSPECIG)=ATMP(1:NSPECIG) -!/IG1 IF (IGSWELLMAX) THEN -!/IG1 DO ISPEC=1,NSPECIG -!/IG1 A(ISPEC)=MAX(ATMP(ISPEC)-A(ISPEC),0.) -!/IG1 END DO -!/IG1 ELSE -!/IG1 A(1:NSPECIG)=ATMP(1:NSPECIG) -!/IG1 ENDIF -!/IG1! -!/IG1 ELSEIF (NINT(IGPARS(3)).EQ.2) THEN ! Empirical source of IG energy -!/IG1! -!/IG1! This empirical source was adjusted to Waimea and Duck data -!/IG1! When applied to deep water the 1/Depth must be replaced with k/Cg -!/IG1! Hence the proper coefficient is WN(IK)/CG(IK)*GRAV**2/SIG(IK) -!/IG1! -!/IG1! The empirical form is HIG = IGEMPIRICAL * ... -!/IG1! this is not quite yet a wave height: multiplied below by MIN(0.0036, ... -!/IG1! -!/IG1 HIG= HS/(MAX(FMEAN2,FREQIG)**2) -!/IG1 EFIG=(HIG*0.25)**2/0.0279 ! this is (HsIG/4)^2 / df -!/IG1 HIG2 = 0. -!/IG1 DO IK=1,NKIG -!/IG1! -!/IG1! First approximation: constant IG spectrum with frequency -!/IG1! -!/IG1 EFIG1=EFIG*MIN(0.0036,IGPARS(11)*WN(IK)/CG(IK)*GRAV**2/SIG(IK)) -!/IG1! -!/IG1! Correction: gives a frequency shape ... -!/IG1! -!/IG1 IF (IK.LT.IK1) THEN -!/IG1 ! The 1.5 exponent of Ardhuin et al. 2014 (see figure 8.a) was probably too high ... now reduced to 1.0 -!/IG1 EFIG1=EFIG1*IGFAC1*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 -!/IG1 ELSE -!/IG1 EFIG1=EFIG1*IGFAC2*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 -!/IG1 END IF -!/IG1! -!/IG1! Conversion to action spectral density A(k,theta), assuming isotropic dir. -!/IG1! -!/IG1 A(1+(IK-1)*NTH:IK*NTH)=EFIG1*CG(IK)/((SIG(IK)*TPI)*TPI) -!/IG1 HIG2 = HIG2 + EFIG1*DSII(IK)*TPIINV -!/IG1 END DO -!/IG1 ELSE -!/IG1 NSPECIG=0 -!/IG1 END IF -!/IG1! -!/IG1 END IF ! ICALC EQ 2 +#ifdef W3_IG1 + IF (IGBCOVERWRITE) A(1:NSPECIGSTART)=0. + IF (ICALC.EQ.1) A=ATMP2 + IF (ICALC.EQ.2) THEN +! +! 1.1 Replaces IG part by forced IG +! +! determines highest IG frequency +! + IF (IGSWELLMAX) THEN + NKIG=NK + ELSE + NKIG=NINT(IGPARS(5)) + ENDIF + FREQIG=SIG(NINT(IGPARS(5)))*TPIINV +! + NSPECIG=NKIG*NTH + ATMP(1:NSPECIGSTART)=0. ! flat bottom approximation (Hasselmann 1962) + ! is not valid for long waves + IF (NINT(IGPARS(3)).EQ.1) THEN ! IGPARS(3) = IGSOURCE + IF (NINT(IGPARS(8)).EQ.1) THEN ! in this case, uses depth at break point + DEPTHIG=MAX(1.,HS/0.3) ! to be modified later with a proper gamma + ELSE + DEPTHIG=DEPTH + END IF + IF (IGPARS(10).GT.0.) DEPTHIG = IGPARS(10) ! fixed depth for 2nd order calculation +! +!/ --- INLINED WAVNU1 (START) ---------------------------------------- / +! + DO IK=1, NK + SQRTH = SQRT(DEPTHIG) + SIX = SIG(IK) * SQRTH + I1 = INT(SIX/DSIE) + IF (I1.LE.N1MAX) THEN + I2 = I1 + 1 + R1 = SIX/DSIE - REAL(I1) + R2 = 1. - R1 + WNB(IK) = ( R2*EWN1(I1) + R1*EWN1(I2) ) / DEPTH + CGB(IK) = ( R2*ECG1(I1) + R1*ECG1(I2) ) * SQRTH + ELSE + WNB(IK) = SIG(IK)*SIG(IK)/GRAV + CGB(IK) = 0.5 * GRAV / SIG(IK) + END IF + END DO +! +!/ --- INLINED WAVNU1 (END) ------------------------------------------ / +! + IF (NINT(IGPARS(1)).EQ.1) THEN ! IGPARS(1) = IGMETHOD + CALL W3ADDIG(ATMP,DEPTHIG,WNB,CGB,1) + ELSE + CALL W3ADD2NDORDER(ATMP,DEPTHIG,WNB,CGB,1) + END IF +! Transforms energy back to proper depth + DO IK=1,NKIG + ATMP(1+(IK-1)*NTH:IK*NTH)=ATMP(1+(IK-1)*NTH:IK*NTH)*(CGB(IK)*WN(IK))/(CG(IK)*WNB(IK)) + END DO + A(1:NSPECIG)=ATMP(1:NSPECIG) + IF (IGSWELLMAX) THEN + DO ISPEC=1,NSPECIG + A(ISPEC)=MAX(ATMP(ISPEC)-A(ISPEC),0.) + END DO + ELSE + A(1:NSPECIG)=ATMP(1:NSPECIG) + ENDIF +! + ELSEIF (NINT(IGPARS(3)).EQ.2) THEN ! Empirical source of IG energy +! +! This empirical source was adjusted to Waimea and Duck data +! When applied to deep water the 1/Depth must be replaced with k/Cg +! Hence the proper coefficient is WN(IK)/CG(IK)*GRAV**2/SIG(IK) +! +! The empirical form is HIG = IGEMPIRICAL * ... +! this is not quite yet a wave height: multiplied below by MIN(0.0036, ... +! + HIG= HS/(MAX(FMEAN2,FREQIG)**2) + EFIG=(HIG*0.25)**2/0.0279 ! this is (HsIG/4)^2 / df + HIG2 = 0. + DO IK=1,NKIG +! +! First approximation: constant IG spectrum with frequency +! + EFIG1=EFIG*MIN(0.0036,IGPARS(11)*WN(IK)/CG(IK)*GRAV**2/SIG(IK)) +! +! Correction: gives a frequency shape ... +! + IF (IK.LT.IK1) THEN + ! The 1.5 exponent of Ardhuin et al. 2014 (see figure 8.a) was probably too high ... now reduced to 1.0 + EFIG1=EFIG1*IGFAC1*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 + ELSE + EFIG1=EFIG1*IGFAC2*1.2*MIN(1.,0.013/(SIG(IK)*TPIINV))**1.0 + END IF +! +! Conversion to action spectral density A(k,theta), assuming isotropic dir. +! + A(1+(IK-1)*NTH:IK*NTH)=EFIG1*CG(IK)/((SIG(IK)*TPI)*TPI) + HIG2 = HIG2 + EFIG1*DSII(IK)*TPIINV + END DO + ELSE + NSPECIG=0 + END IF +! + END IF ! ICALC EQ 2 +#endif ! NRS=NINT(REFPARS(8)) IF (REFPARS(6).GT.0) THEN @@ -576,16 +598,18 @@ SUBROUTINE W3SREF(A, CG, WN, EMEAN, FMEAN, DEPTH, CX1, CY1, REFLC, REFLD, & END DO END IF -!/IG1 IF (ICALC.EQ.1) THEN -!/IG1 STMP1(NSPECIGSTART+1:NSPEC) = S(NSPECIGSTART+1:NSPEC) -!/IG1 ELSE -!/IG1 STMP2 = S -!/IG1 DO ISPEC = 1, NSPEC -!/IG1 S(ISPEC) = MAX(STMP2(ISPEC),STMP1(ISPEC)) -!/IG1 END DO -!/IG1 END IF -!/IG1 ENDDO ! ICALC = 1,2 -!/IG1 A(1:NSPECIG)=ATMP2(1:NSPECIG) ! removes bound IG components ... +#ifdef W3_IG1 + IF (ICALC.EQ.1) THEN + STMP1(NSPECIGSTART+1:NSPEC) = S(NSPECIGSTART+1:NSPEC) + ELSE + STMP2 = S + DO ISPEC = 1, NSPEC + S(ISPEC) = MAX(STMP2(ISPEC),STMP1(ISPEC)) + END DO + END IF + ENDDO ! ICALC = 1,2 + A(1:NSPECIG)=ATMP2(1:NSPECIG) ! removes bound IG components ... +#endif !/ !/ End of W3SREF ----------------------------------------------------- / !/ diff --git a/model/ftn/w3sbs1md.ftn b/model/src/w3sbs1md.F90 similarity index 97% rename from model/ftn/w3sbs1md.ftn rename to model/src/w3sbs1md.F90 index ee0c16d18..31f82a7b7 100644 --- a/model/ftn/w3sbs1md.ftn +++ b/model/src/w3sbs1md.F90 @@ -145,7 +145,9 @@ SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, & ECOS, ESIN, EC2, MAPTH, MAPWN, & SIG2, DSII -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ ! IMPLICIT NONE @@ -163,7 +165,9 @@ SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & !/ Local parameters !/ INTEGER :: ISPEC, IK, NSCUT, ITH, ITH2, i, j,iajust,iajust2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL, SAVE :: FIRST = .TRUE. INTEGER :: MATRICES = 0 @@ -190,7 +194,9 @@ SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SBS1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SBS1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -400,11 +406,15 @@ SUBROUTINE W3SBS1(A, CG, WN, DEPTH, CX1, CY1, & integral3=integral3+ABS(S(ISPEC))*DTH*DSII(MAPWN(ISPEC))/CG(MAPWN(ISPEC)) END DO END IF -!/T print*,'BOTTOM SCAT CHECKSUM:',integral2,integral3,integral1,integral1b +#ifdef W3_T + print*,'BOTTOM SCAT CHECKSUM:',integral2,integral3,integral1,integral1b +#endif -!/T DO ITH=1,120 -!/T WRITE(6,'(120G15.7)') SMATRIX(ITH,:) -!/T END DO +#ifdef W3_T + DO ITH=1,120 + WRITE(6,'(120G15.7)') SMATRIX(ITH,:) + END DO +#endif END IF !/ @@ -468,7 +478,9 @@ SUBROUTINE INSBS1( inistep ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, ECOS, ESIN USE W3SERVMD, ONLY: DIAGONALIZE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -480,7 +492,9 @@ SUBROUTINE INSBS1( inistep ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: I, J, K1, K2, IK, JK, NROT REAL :: kbotx, kboty, kcurr, kcutoff, variance REAL :: kbotxi, kbotyi, xk, yk @@ -489,7 +503,9 @@ SUBROUTINE INSBS1( inistep ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSBS1') +#ifdef W3_S + CALL STRACE (IENT, 'INSBS1') +#endif ! IF (inistep.EQ.1) THEN ! diff --git a/model/ftn/w3sbt1md.ftn b/model/src/w3sbt1md.F90 similarity index 86% rename from model/ftn/w3sbt1md.ftn rename to model/src/w3sbt1md.F90 index 6e37c02ab..385fae9eb 100644 --- a/model/ftn/w3sbt1md.ftn +++ b/model/src/w3sbt1md.F90 @@ -128,10 +128,18 @@ SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, SBTC1 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -145,14 +153,22 @@ SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) !/ Local parameters !/ INTEGER :: IS, IK, NSCUT -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: ITH +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: ITH +#endif REAL :: FACTOR, CBETA(NK) -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SBT1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SBT1') +#endif ! ! 1. Deep water ===================================================== * ! @@ -169,7 +185,9 @@ SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) ! FACTOR = SBTC1 / DEPTH ! -!/T WRITE (NDST,9000) FACTOR, DEPTH +#ifdef W3_T + WRITE (NDST,9000) FACTOR, DEPTH +#endif ! ! 2.b Wavenumber dependent part. ! @@ -197,22 +215,30 @@ SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sbt', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sbt', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sbt') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sbt') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SBT1 : FACTOR, DEPTH : ',2E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SBT1 : FACTOR, DEPTH : ',2E10.3) +#endif !/ !/ End of W3SBT1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3sbt4md.ftn b/model/src/w3sbt4md.F90 similarity index 98% rename from model/ftn/w3sbt4md.ftn rename to model/src/w3sbt4md.F90 index ff4201f4f..b239ae07c 100644 --- a/model/ftn/w3sbt4md.ftn +++ b/model/src/w3sbt4md.F90 @@ -170,7 +170,9 @@ SUBROUTINE INSBT4 ! !/ ------------------------------------------------------------------- / ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -182,11 +184,15 @@ SUBROUTINE INSBT4 !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSIN3') +#ifdef W3_S + CALL STRACE (IENT, 'INSIN3') +#endif ! ! 1. .... ----------------------------------------------------------- * ! @@ -350,7 +356,9 @@ SUBROUTINE W3SBT4 (A, CG, WN, DEPTH, D50, PSIC, TAUBBL, BEDFORM, S, D, IX, IY ) USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, & SBTCX, ECOS, ESIN, DTH -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / @@ -360,7 +368,9 @@ SUBROUTINE W3SBT4 (A, CG, WN, DEPTH, D50, PSIC, TAUBBL, BEDFORM, S, D, IX, IY ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ LOGICAL, SAVE :: FIRST = .TRUE. REAL, INTENT(IN) :: CG(NK), WN(NK), DEPTH, A(NSPEC), D50 @@ -387,7 +397,9 @@ SUBROUTINE W3SBT4 (A, CG, WN, DEPTH, D50, PSIC, TAUBBL, BEDFORM, S, D, IX, IY ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SBT4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SBT4') +#endif ! ! 0. Initializations ------------------------------------------------ * IF ( FIRST ) THEN diff --git a/model/ftn/w3sbt8md.ftn b/model/src/w3sbt8md.F90 similarity index 98% rename from model/ftn/w3sbt8md.ftn rename to model/src/w3sbt8md.F90 index 30b4c2fc3..94d855ca1 100644 --- a/model/ftn/w3sbt8md.ftn +++ b/model/src/w3sbt8md.F90 @@ -144,7 +144,9 @@ SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE USE W3DISPMD, ONLY: WAVNU1 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -159,7 +161,9 @@ SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif COMPLEX :: K COMPLEX :: SHH @@ -233,7 +237,9 @@ SUBROUTINE W3SBT8(AC,H_WDEPTH,S,D,IX,IY) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SBT8') +#ifdef W3_S + CALL STRACE (IENT, 'W3SBT8') +#endif ! ! 0. Initializations ------------------------------------------------ * ! diff --git a/model/ftn/w3sbt9md.ftn b/model/src/w3sbt9md.F90 similarity index 99% rename from model/ftn/w3sbt9md.ftn rename to model/src/w3sbt9md.F90 index 08062825a..cd4da206e 100644 --- a/model/ftn/w3sbt9md.ftn +++ b/model/src/w3sbt9md.F90 @@ -151,7 +151,9 @@ SUBROUTINE W3SBT9(AC,H_WDEPTH,S,D,IX,IY) USE CONSTANTS, ONLY: PI,GRAV,DWAT,NU_WATER USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -166,7 +168,9 @@ SUBROUTINE W3SBT9(AC,H_WDEPTH,S,D,IX,IY) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! LOCAL VARIABLES REAL :: DMW(NK) @@ -209,7 +213,9 @@ SUBROUTINE W3SBT9(AC,H_WDEPTH,S,D,IX,IY) !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SBT9') +#ifdef W3_S + CALL STRACE (IENT, 'W3SBT9') +#endif ! ! 0. Initializations ------------------------------------------------ * ! diff --git a/model/ftn/w3sdb1md.ftn b/model/src/w3sdb1md.F90 similarity index 86% rename from model/ftn/w3sdb1md.ftn rename to model/src/w3sdb1md.F90 index b8fffb92c..99d844616 100644 --- a/model/ftn/w3sdb1md.ftn +++ b/model/src/w3sdb1md.F90 @@ -144,9 +144,15 @@ SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) USE W3ODATMD, ONLY: NDST USE W3GDATMD, ONLY: SIG USE W3ODATMD, only : IAPROC -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif !/ IMPLICIT NONE !/ @@ -165,16 +171,24 @@ SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) !/ Local parameters !/ INTEGER :: IS -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: IK, ITH +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: IK, ITH +#endif REAL*8 :: HM, BB, ARG, Q0, QB, B, CBJ, HRMS, EB(NK) REAL*8 :: AUX, CBJ2, RATIO, S0, S1, THR, BR1, BR2, FAK REAL :: ETOT, FMEAN2 -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDB1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDB1') +#endif ! ! 0. Initialzations ------------------------------------------------- / ! Never touch this 4 lines below ... otherwise my exceptionhandling will not work. @@ -186,7 +200,9 @@ SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) D = 0. IWB = 1 ! -!/T WRITE (NDST,9000) SDBC1, SDBC2, FDONLY +#ifdef W3_T + WRITE (NDST,9000) SDBC1, SDBC2, FDONLY +#endif ! ! 1. Integral quantities. AR: make sure mean quantities are computed, need to move upward ! @@ -212,9 +228,11 @@ SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) ! 1.a. Maximum wave height ! 1.a.1. Simple limit ! -!/DEBUGDB1 WRITE(740+IAPROC,*) 'FDONLY=', FDONLY -!/DEBUGDB1 WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE -!/DEBUGDB1 FLUSH(740+IAPROC) +#ifdef W3_DEBUGDB1 + WRITE(740+IAPROC,*) 'FDONLY=', FDONLY + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + FLUSH(740+IAPROC) +#endif IF ( FDONLY ) THEN HM = DBLE(SDBC2) * DBLE(DEPTH) ELSE @@ -292,32 +310,44 @@ SUBROUTINE W3SDB1 (IX, A, DEPTH, EMEAN, FMEAN, WNMEAN, CG, LBREAK, S, D ) LBREAK = .FALSE. ENDIF -!/DEBUGRUN IF (IX == DEBUG_NODE) THEN -!/DEBUGRUN WRITE(*,'(A200)') 'IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, HS' -!/DEBUGRUN WRITE(*,'(I10,20F20.10)') IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, 4*SQRT(ETOT) -!/DEBUGRUN ENDIF +#ifdef W3_DEBUGRUN + IF (IX == DEBUG_NODE) THEN + WRITE(*,'(A200)') 'IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, HS' + WRITE(*,'(I10,20F20.10)') IX, DEPTH, CBJ, BB, QB, SDBC1, SDBC2, FMEAN, FMEAN2, 4*SQRT(ETOT) + ENDIF +#endif -!/DEBUGDB1 WRITE(740+IAPROC,*) 'CBJ=', CBJ -!/DEBUGDB1 FLUSH(740+IAPROC) +#ifdef W3_DEBUGDB1 + WRITE(740+IAPROC,*) 'CBJ=', CBJ + FLUSH(740+IAPROC) +#endif ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG, ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sdb', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG, ' ', 1., & + 0.0, 0.001, 'Diag Sdb', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sdb') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sdb') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SDB1 : PARAMETERS :',2F7.3,L4) +#ifdef W3_T + 9000 FORMAT (' TEST W3SDB1 : PARAMETERS :',2F7.3,L4) +#endif !/ !/ End of W3SDB1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3servmd.ftn b/model/src/w3servmd.F90 similarity index 84% rename from model/ftn/w3servmd.ftn rename to model/src/w3servmd.F90 index fe01722b4..a9ca65826 100644 --- a/model/ftn/w3servmd.ftn +++ b/model/src/w3servmd.F90 @@ -275,14 +275,18 @@ SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IERR CHARACTER(128) :: MSG CHARACTER(256) :: LINE, TEST !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'NEXTLN') +#ifdef W3_S + CALL STRACE (IENT, 'NEXTLN') +#endif ! 100 CONTINUE ! read line @@ -791,7 +795,9 @@ SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) !/ ------------------------------------------------------------------- / IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -805,8 +811,10 @@ SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) !/ !/ ------------------------------------------------------------------- / !/ -!/MPI INTEGER :: IERR_MPI -!/MPI LOGICAL :: RUN +#ifdef W3_MPI + INTEGER :: IERR_MPI + LOGICAL :: RUN +#endif INTEGER :: IUN CHARACTER(256) :: LMSG = "" CHARACTER(6) :: LSTR @@ -838,41 +846,53 @@ SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) !/ !/ Handle MPI exit !/ -!/MPI CALL MPI_INITIALIZED ( RUN, IERR_MPI ) -!/MPI IF ( RUN ) THEN -!/MPI IF ( IEXIT.EQ.0 ) THEN ! non-error state -!/MPI IF ( PRESENT(COMM) ) CALL MPI_BARRIER ( COMM, IERR_MPI ) -!/MPI CALL MPI_FINALIZE (IERR_MPI ) -!/MPI ELSE ! error state -!/MPI WRITE(*,'(/A,I6/)') 'EXTCDE MPI_ABORT, IEXIT=', IEXIT -!/MPI IF (PRESENT(UNIT)) THEN -!/MPI WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT +#ifdef W3_MPI + CALL MPI_INITIALIZED ( RUN, IERR_MPI ) + IF ( RUN ) THEN + IF ( IEXIT.EQ.0 ) THEN ! non-error state + IF ( PRESENT(COMM) ) CALL MPI_BARRIER ( COMM, IERR_MPI ) + CALL MPI_FINALIZE (IERR_MPI ) + ELSE ! error state + WRITE(*,'(/A,I6/)') 'EXTCDE MPI_ABORT, IEXIT=', IEXIT + IF (PRESENT(UNIT)) THEN + WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT +#endif !!/MPI ELSE !!/MPI WRITE(*,'(A)') 'EXTCDE UNIT missing' -!/MPI END IF -!/MPI IF (PRESENT(MSG)) THEN -!/MPI WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG +#ifdef W3_MPI + END IF + IF (PRESENT(MSG)) THEN + WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG +#endif !!/MPI ELSE !!/MPI WRITE(*,'(A)') 'EXTCDE MSG missing' -!/MPI END IF -!/MPI IF (PRESENT(FILE)) THEN -!/MPI WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE +#ifdef W3_MPI + END IF + IF (PRESENT(FILE)) THEN + WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE +#endif !!/MPI ELSE !!/MPI WRITE(*,'(A)') 'EXTCDE FILE missing' -!/MPI END IF -!/MPI IF (PRESENT(LINE)) THEN -!/MPI WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE +#ifdef W3_MPI + END IF + IF (PRESENT(LINE)) THEN + WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE +#endif !!/MPI ELSE !!/MPI WRITE(*,'(A)') 'EXTCDE LINE missing' -!/MPI END IF -!/MPI IF (PRESENT(COMM)) THEN -!/MPI WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM +#ifdef W3_MPI + END IF + IF (PRESENT(COMM)) THEN + WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM +#endif !!/MPI ELSE !!/MPI WRITE(*,'(A)') 'EXTCDE COMM missing' -!/MPI END IF -!/MPI CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) -!/MPI END IF -!/MPI END IF +#ifdef W3_MPI + END IF + CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) + END IF + END IF +#endif !/ !/ Handle non-MPI exit !/ @@ -1537,326 +1557,328 @@ END SUBROUTINE STR_TO_UPPER !********************************************************************** !* * -!/T!********************************************************************** -!/T SUBROUTINE SSORT1 (X, Y, N, KFLAG) -!/T!***BEGIN PROLOGUE SSORT -!/T!***PURPOSE Sort an array and optionally make the same interchanges in -!/T! an auxiliary array. The array may be sorted in increasing -!/T! or decreasing order. A slightly modified QUICKSORT -!/T! algorithm is used. -!/T!***LIBRARY SLATEC -!/T!***CATEGORY N6A2B -!/T!***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -!/T!***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -!/T!***AUTHOR Jones, R. E., (SNLA) -!/T! Wisniewski, J. A., (SNLA) -!/T!***DESCRIPTION -!/T! -!/T! SSORT sorts array X and optionally makes the same interchanges in -!/T! array Y. The array X may be sorted in increasing order or -!/T! decreasing order. A slightly modified quicksort algorithm is used. -!/T! -!/T! Description of Parameters -!/T! X - array of values to be sorted (usually abscissas) -!/T! Y - array to be (optionally) carried along -!/T! N - number of values in array X to be sorted -!/T! KFLAG - control parameter -!/T! = 2 means sort X in increasing order and carry Y along. -!/T! = 1 means sort X in increasing order (ignoring Y) -!/T! = -1 means sort X in decreasing order (ignoring Y) -!/T! = -2 means sort X in decreasing order and carry Y along. -!/T! -!/T!***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -!/T! for sorting with minimal storage, Communications of -!/T! the ACM, 12, 3 (1969), pp. 185-187. -!/T!***REVISION HISTORY (YYMMDD) -!/T! 761101 DATE WRITTEN -!/T! 761118 Modified to use the Singleton quicksort algorithm. (JAW) -!/T! 890531 Changed all specific intrinsics to generic. (WRB) -!/T! 890831 Modified array declarations. (WRB) -!/T! 891009 Removed unreferenced statement labels. (WRB) -!/T! 891024 Changed category. (WRB) -!/T! 891024 REVISION DATE from Version 3.2 -!/T! 891214 Prologue converted to Version 4.0 format. (BAB) -!/T! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -!/T! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) -!/T! 920501 Reformatted the REFERENCES section. (DWL, WRB) -!/T! 920519 Clarified error messages. (DWL) -!/T! 920801 Declarations section rebuilt and code restructured to use -!/T! IF-THEN-ELSE-ENDIF. (RWC, WRB) -!/T!***END PROLOGUE SSORT -!/T! .. Scalar Arguments .. -!/T INTEGER KFLAG, N -!/T! .. Array Arguments .. -!/T REAL*4 X(*), Y(*) -!/T! .. Local Scalars .. -!/T REAL*4 R, T, TT, TTY, TY -!/T INTEGER I, IJ, J, K, KK, L, M, NN -!/T! .. Local Arrays .. -!/T INTEGER IL(21), IU(21) -!/T! .. External Subroutines .. -!/T! None -!/T! .. Intrinsic Functions .. -!/T INTRINSIC ABS, INT -!/T!***FIRST EXECUTABLE STATEMENT SSORT -!/T NN = N -!/T IF (NN .LT. 1) THEN -!/T WRITE (*,*) 'The number of values to be sorted is not positive.' -!/T RETURN -!/T ENDIF -!/T! -!/T KK = ABS(KFLAG) -!/T IF (KK.NE.1 .AND. KK.NE.2) THEN -!/T WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' -!/T RETURN -!/T ENDIF -!/T! -!/T! Alter array X to get decreasing order if needed -!/T! -!/T IF (KFLAG .LE. -1) THEN -!/T DO 10 I=1,NN -!/T X(I) = -X(I) -!/T 10 CONTINUE -!/T ENDIF -!/T! -!/T IF (KK .EQ. 2) GO TO 100 -!/T! -!/T! Sort X only -!/T! -!/T M = 1 -!/T I = 1 -!/T J = NN -!/T R = 0.375E0 -!/T! -!/T 20 IF (I .EQ. J) GO TO 60 -!/T IF (R .LE. 0.5898437E0) THEN -!/T R = R+3.90625E-2 -!/T ELSE -!/T R = R-0.21875E0 -!/T ENDIF -!/T! -!/T 30 K = I -!/T! -!/T! Select a central element of the array and save it in location T -!/T! -!/T IJ = I + INT((J-I)*R) -!/T T = X(IJ) -!/T! -!/T! If first element of array is greater than T, interchange with T -!/T! -!/T IF (X(I) .GT. T) THEN -!/T X(IJ) = X(I) -!/T X(I) = T -!/T T = X(IJ) -!/T ENDIF -!/T L = J -!/T! -!/T! If last element of array is less than than T, interchange with T -!/T! -!/T IF (X(J) .LT. T) THEN -!/T X(IJ) = X(J) -!/T X(J) = T -!/T T = X(IJ) -!/T! -!/T! If first element of array is greater than T, interchange with T -!/T! -!/T IF (X(I) .GT. T) THEN -!/T X(IJ) = X(I) -!/T X(I) = T -!/T T = X(IJ) -!/T ENDIF -!/T ENDIF -!/T! -!/T! Find an element in the second half of the array which is smaller -!/T! than T -!/T! -!/T 40 L = L-1 -!/T IF (X(L) .GT. T) GO TO 40 -!/T! -!/T! Find an element in the first half of the array which is greater -!/T! than T -!/T! -!/T 50 K = K+1 -!/T IF (X(K) .LT. T) GO TO 50 -!/T! -!/T! Interchange these elements -!/T! -!/T IF (K .LE. L) THEN -!/T TT = X(L) -!/T X(L) = X(K) -!/T X(K) = TT -!/T GO TO 40 -!/T ENDIF -!/T! -!/T! Save upper and lower subscripts of the array yet to be sorted -!/T! -!/T IF (L-I .GT. J-K) THEN -!/T IL(M) = I -!/T IU(M) = L -!/T I = K -!/T M = M+1 -!/T ELSE -!/T IL(M) = K -!/T IU(M) = J -!/T J = L -!/T M = M+1 -!/T ENDIF -!/T GO TO 70 -!/T! -!/T! Begin again on another portion of the unsorted array -!/T! -!/T 60 M = M-1 -!/T IF (M .EQ. 0) GO TO 190 -!/T I = IL(M) -!/T J = IU(M) -!/T! -!/T 70 IF (J-I .GE. 1) GO TO 30 -!/T IF (I .EQ. 1) GO TO 20 -!/T I = I-1 -!/T! -!/T 80 I = I+1 -!/T IF (I .EQ. J) GO TO 60 -!/T T = X(I+1) -!/T IF (X(I) .LE. T) GO TO 80 -!/T K = I -!/T! -!/T 90 X(K+1) = X(K) -!/T K = K-1 -!/T IF (T .LT. X(K)) GO TO 90 -!/T X(K+1) = T -!/T GO TO 80 -!/T! -!/T! Sort X and carry Y along -!/T! -!/T 100 M = 1 -!/T I = 1 -!/T J = NN -!/T R = 0.375E0 -!/T! -!/T 110 IF (I .EQ. J) GO TO 150 -!/T IF (R .LE. 0.5898437E0) THEN -!/T R = R+3.90625E-2 -!/T ELSE -!/T R = R-0.21875E0 -!/T ENDIF -!/T! -!/T 120 K = I -!/T! -!/T! Select a central element of the array and save it in location T -!/T! -!/T IJ = I + INT((J-I)*R) -!/T T = X(IJ) -!/T TY = Y(IJ) -!/T! -!/T! If first element of array is greater than T, interchange with T -!/T! -!/T IF (X(I) .GT. T) THEN -!/T X(IJ) = X(I) -!/T X(I) = T -!/T T = X(IJ) -!/T Y(IJ) = Y(I) -!/T Y(I) = TY -!/T TY = Y(IJ) -!/T ENDIF -!/T L = J -!/T! -!/T! If last element of array is less than T, interchange with T -!/T! -!/T IF (X(J) .LT. T) THEN -!/T X(IJ) = X(J) -!/T X(J) = T -!/T T = X(IJ) -!/T Y(IJ) = Y(J) -!/T Y(J) = TY -!/T TY = Y(IJ) -!/T! -!/T! If first element of array is greater than T, interchange with T -!/T! -!/T IF (X(I) .GT. T) THEN -!/T X(IJ) = X(I) -!/T X(I) = T -!/T T = X(IJ) -!/T Y(IJ) = Y(I) -!/T Y(I) = TY -!/T TY = Y(IJ) -!/T ENDIF -!/T ENDIF -!/T! -!/T! Find an element in the second half of the array which is smaller -!/T! than T -!/T! -!/T 130 L = L-1 -!/T IF (X(L) .GT. T) GO TO 130 -!/T! -!/T! Find an element in the first half of the array which is greater -!/T! than T -!/T! -!/T 140 K = K+1 -!/T IF (X(K) .LT. T) GO TO 140 -!/T! -!/T! Interchange these elements -!/T! -!/T IF (K .LE. L) THEN -!/T TT = X(L) -!/T X(L) = X(K) -!/T X(K) = TT -!/T TTY = Y(L) -!/T Y(L) = Y(K) -!/T Y(K) = TTY -!/T GO TO 130 -!/T ENDIF -!/T! -!/T! Save upper and lower subscripts of the array yet to be sorted -!/T! -!/T IF (L-I .GT. J-K) THEN -!/T IL(M) = I -!/T IU(M) = L -!/T I = K -!/T M = M+1 -!/T ELSE -!/T IL(M) = K -!/T IU(M) = J -!/T J = L -!/T M = M+1 -!/T ENDIF -!/T GO TO 160 -!/T! -!/T! Begin again on another portion of the unsorted array -!/T! -!/T 150 M = M-1 -!/T IF (M .EQ. 0) GO TO 190 -!/T I = IL(M) -!/T J = IU(M) -!/T! -!/T 160 IF (J-I .GE. 1) GO TO 120 -!/T IF (I .EQ. 1) GO TO 110 -!/T I = I-1 -!/T! -!/T 170 I = I+1 -!/T IF (I .EQ. J) GO TO 150 -!/T T = X(I+1) -!/T TY = Y(I+1) -!/T IF (X(I) .LE. T) GO TO 170 -!/T K = I -!/T! -!/T 180 X(K+1) = X(K) -!/T Y(K+1) = Y(K) -!/T K = K-1 -!/T IF (T .LT. X(K)) GO TO 180 -!/T X(K+1) = T -!/T Y(K+1) = TY -!/T GO TO 170 -!/T! -!/T! Clean up -!/T! -!/T 190 IF (KFLAG .LE. -1) THEN -!/T DO 200 I=1,NN -!/T X(I) = -X(I) -!/T 200 CONTINUE -!/T ENDIF -!/T RETURN -!/T END SUBROUTINE SSORT1 -!/T +#ifdef W3_T +!********************************************************************** + SUBROUTINE SSORT1 (X, Y, N, KFLAG) +!***BEGIN PROLOGUE SSORT +!***PURPOSE Sort an array and optionally make the same interchanges in +! an auxiliary array. The array may be sorted in increasing +! or decreasing order. A slightly modified QUICKSORT +! algorithm is used. +!***LIBRARY SLATEC +!***CATEGORY N6A2B +!***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) +!***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +!***AUTHOR Jones, R. E., (SNLA) +! Wisniewski, J. A., (SNLA) +!***DESCRIPTION +! +! SSORT sorts array X and optionally makes the same interchanges in +! array Y. The array X may be sorted in increasing order or +! decreasing order. A slightly modified quicksort algorithm is used. +! +! Description of Parameters +! X - array of values to be sorted (usually abscissas) +! Y - array to be (optionally) carried along +! N - number of values in array X to be sorted +! KFLAG - control parameter +! = 2 means sort X in increasing order and carry Y along. +! = 1 means sort X in increasing order (ignoring Y) +! = -1 means sort X in decreasing order (ignoring Y) +! = -2 means sort X in decreasing order and carry Y along. +! +!***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +! for sorting with minimal storage, Communications of +! the ACM, 12, 3 (1969), pp. 185-187. +!***REVISION HISTORY (YYMMDD) +! 761101 DATE WRITTEN +! 761118 Modified to use the Singleton quicksort algorithm. (JAW) +! 890531 Changed all specific intrinsics to generic. (WRB) +! 890831 Modified array declarations. (WRB) +! 891009 Removed unreferenced statement labels. (WRB) +! 891024 Changed category. (WRB) +! 891024 REVISION DATE from Version 3.2 +! 891214 Prologue converted to Version 4.0 format. (BAB) +! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) +! 920501 Reformatted the REFERENCES section. (DWL, WRB) +! 920519 Clarified error messages. (DWL) +! 920801 Declarations section rebuilt and code restructured to use +! IF-THEN-ELSE-ENDIF. (RWC, WRB) +!***END PROLOGUE SSORT +! .. Scalar Arguments .. + INTEGER KFLAG, N +! .. Array Arguments .. + REAL*4 X(*), Y(*) +! .. Local Scalars .. + REAL*4 R, T, TT, TTY, TY + INTEGER I, IJ, J, K, KK, L, M, NN +! .. Local Arrays .. + INTEGER IL(21), IU(21) +! .. External Subroutines .. +! None +! .. Intrinsic Functions .. + INTRINSIC ABS, INT +!***FIRST EXECUTABLE STATEMENT SSORT + NN = N + IF (NN .LT. 1) THEN + WRITE (*,*) 'The number of values to be sorted is not positive.' + RETURN + ENDIF +! + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN + WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' + RETURN + ENDIF +! +! Alter array X to get decreasing order if needed +! + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + X(I) = -X(I) + 10 CONTINUE + ENDIF +! + IF (KK .EQ. 2) GO TO 100 +! +! Sort X only +! + M = 1 + I = 1 + J = NN + R = 0.375E0 +! + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +! + 30 K = I +! +! Select a central element of the array and save it in location T +! + IJ = I + INT((J-I)*R) + T = X(IJ) +! +! If first element of array is greater than T, interchange with T +! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + ENDIF + L = J +! +! If last element of array is less than than T, interchange with T +! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T + T = X(IJ) +! +! If first element of array is greater than T, interchange with T +! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + ENDIF + ENDIF +! +! Find an element in the second half of the array which is smaller +! than T +! + 40 L = L-1 + IF (X(L) .GT. T) GO TO 40 +! +! Find an element in the first half of the array which is greater +! than T +! + 50 K = K+1 + IF (X(K) .LT. T) GO TO 50 +! +! Interchange these elements +! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + GO TO 40 + ENDIF +! +! Save upper and lower subscripts of the array yet to be sorted +! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +! +! Begin again on another portion of the unsorted array +! + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +! + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +! + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = X(I+1) + IF (X(I) .LE. T) GO TO 80 + K = I +! + 90 X(K+1) = X(K) + K = K-1 + IF (T .LT. X(K)) GO TO 90 + X(K+1) = T + GO TO 80 +! +! Sort X and carry Y along +! + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +! + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +! + 120 K = I +! +! Select a central element of the array and save it in location T +! + IJ = I + INT((J-I)*R) + T = X(IJ) + TY = Y(IJ) +! +! If first element of array is greater than T, interchange with T +! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) + ENDIF + L = J +! +! If last element of array is less than T, interchange with T +! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T + T = X(IJ) + Y(IJ) = Y(J) + Y(J) = TY + TY = Y(IJ) +! +! If first element of array is greater than T, interchange with T +! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) + ENDIF + ENDIF +! +! Find an element in the second half of the array which is smaller +! than T +! + 130 L = L-1 + IF (X(L) .GT. T) GO TO 130 +! +! Find an element in the first half of the array which is greater +! than T +! + 140 K = K+1 + IF (X(K) .LT. T) GO TO 140 +! +! Interchange these elements +! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + TTY = Y(L) + Y(L) = Y(K) + Y(K) = TTY + GO TO 130 + ENDIF +! +! Save upper and lower subscripts of the array yet to be sorted +! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +! +! Begin again on another portion of the unsorted array +! + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +! + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +! + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = X(I+1) + TY = Y(I+1) + IF (X(I) .LE. T) GO TO 170 + K = I +! + 180 X(K+1) = X(K) + Y(K+1) = Y(K) + K = K-1 + IF (T .LT. X(K)) GO TO 180 + X(K+1) = T + Y(K+1) = TY + GO TO 170 +! +! Clean up +! + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + X(I) = -X(I) + 200 CONTINUE + ENDIF + RETURN + END SUBROUTINE SSORT1 + +#endif !********************************************************************* SUBROUTINE DIAGONALIZE(a1,d,v,nrot) diff --git a/model/ftn/w3sic1md.ftn b/model/src/w3sic1md.F90 similarity index 91% rename from model/ftn/w3sic1md.ftn rename to model/src/w3sic1md.F90 index 1e7b4320e..5985aa6db 100644 --- a/model/ftn/w3sic1md.ftn +++ b/model/src/w3sic1md.F90 @@ -206,10 +206,18 @@ SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) USE W3SERVMD, ONLY: EXTCDE USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, INFLAGS2 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -222,9 +230,13 @@ SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: ITH -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: ITH + REAL :: DOUT(NK,NTH) +#endif INTEGER :: IKTH, IK REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & @@ -233,7 +245,9 @@ SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIC1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIC1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -267,7 +281,9 @@ SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) ! ! (none) ! -!/T38 WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#ifdef W3_T38 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#endif ! ! 2.b Make calculations ---------------------------------------------- / WN_I = ICECOEF1 ! uniform in k @@ -290,23 +306,31 @@ SUBROUTINE W3SIC1 (A, DEPTH, CG, IX, IY, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#endif ! ! Formats ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC1 : '/ & ' ',A,' REQUIRED BUT NOT SELECTED'/) ! -!/T 9000 FORMAT (' TEST W3SIC1 : DEPTH,ICECOEF1 : ',2E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIC1 : DEPTH,ICECOEF1 : ',2E10.3) +#endif !/ !/ End of W3SIC1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3sic2md.ftn b/model/src/w3sic2md.F90 similarity index 93% rename from model/ftn/w3sic2md.ftn rename to model/src/w3sic2md.F90 index 7de98b751..50c104c3b 100644 --- a/model/ftn/w3sic2md.ftn +++ b/model/src/w3sic2md.F90 @@ -236,10 +236,18 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, IC2PARS, DDEN, & FLAGLL, YGRD, GTYPE, RLGTYPE USE W3IDATMD, ONLY: INFLAGS2,ICEP1,ICEP2,ICEP3,ICEP4,ICEP5,ICEI -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -257,9 +265,13 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: ITH -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: ITH + REAL :: DOUT(NK,NTH) +#endif INTEGER :: IKTH, IK REAL :: D1D(NK) !In SBT1: D1D was named "CBETA" REAL :: ICECOEF1, ICECOEF2, ICECONC @@ -275,7 +287,9 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIC2') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIC2') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -310,7 +324,9 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & ! ! (none) ! -!/T38 WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2 +#ifdef W3_T38 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2 +#endif ! ! 2.b Make calculations ---------------------------------------------- / @@ -362,10 +378,12 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & ! of the water relative to the ice ... this is only correct if the ice layer ! does not move. This should is changed by taking into account DMAX when IC2DMAX > 0: ! -!/IS2 IF (IC2PARS(8).GT.0) THEN -!/IS2 WLG_R(IK)=TPI/WN_R(IK) -!/IS2 SMOOTH_DMAX(IK)= (0.5*(1+TANH((ICEF-IC2PARS(8)*WLG_R(IK))/(ICEF*0.5))))**2 -!/IS2 END IF +#ifdef W3_IS2 + IF (IC2PARS(8).GT.0) THEN + WLG_R(IK)=TPI/WN_R(IK) + SMOOTH_DMAX(IK)= (0.5*(1+TANH((ICEF-IC2PARS(8)*WLG_R(IK))/(ICEF*0.5))))**2 + END IF +#endif ! IF (R(IK).GT.1.) THEN UORB = UORB + EB * SMOOTH_DMAX(IK)* SIG(IK)**2 * DDEN(IK) / CG(IK) & @@ -420,23 +438,31 @@ SUBROUTINE W3SIC2 (A, DEPTH, ICEH, ICEF, CG, WN, IX, IY, S, D, WN_R, & ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#endif ! ! Formats ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC2 : '/ & ' ',A,' REQUIRED BUT NOT SELECTED'/) ! -!/T38 9000 FORMAT (' TEST W3SIC2 : DEPTH,ICECOEF1 : ',2E10.3) +#ifdef W3_T38 + 9000 FORMAT (' TEST W3SIC2 : DEPTH,ICECOEF1 : ',2E10.3) +#endif !/ !/ End of W3SIC2 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3sic3md.ftn b/model/src/w3sic3md.F90 similarity index 99% rename from model/ftn/w3sic3md.ftn rename to model/src/w3sic3md.F90 index 40156b70a..07751eef2 100644 --- a/model/ftn/w3sic3md.ftn +++ b/model/src/w3sic3md.F90 @@ -341,10 +341,18 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) FLAGLL, YGRD, GTYPE, RLGTYPE USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, ICEI, & INFLAGS2 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -358,9 +366,13 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: ITH -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif INTEGER :: IKTH, IK REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & ICECOEF4, ICECOEF5, ICECONC @@ -380,7 +392,9 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIC3') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIC3') +#endif ! ! 0. Initializations ------------------------------------------------ / ! @@ -494,7 +508,9 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) ((ICECOEF1.LE.MAXTHK).OR.(ICECONC.LE.MAXCNC)) ) THEN ! 2.a Write test output ---------------------------------------------- / -!/T38 WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#ifdef W3_T38 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#endif ! 2.b Make calculations using Cheng routines ------------------------- / @@ -522,7 +538,9 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) !...............or concentration is .le. 1.0 ! ! 2.a Write test output ---------------------------------------------- / -!/T38 WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#ifdef W3_T38 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#endif ! ! 2.b Make calculations using original routines ---------------------- / ! --- Input to routine (part 1): 6 ice parameters from single @@ -607,16 +625,22 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#endif ! ! Formats ! @@ -624,7 +648,9 @@ SUBROUTINE W3SIC3 (A, DEPTH, CG, WN, IX, IY, S, D) ' ',A,' REQUIRED ONCE, BUT WAS PROVIDED BY USER '/ & ' ',I4,' TIMES.'/) ! -!/T 9000 FORMAT (' TEST W3SIC3 : depth and 4 ice coef. : ',5E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIC3 : depth and 4 ice coef. : ',5E10.3) +#endif !/ !/ End of W3SIC3 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3sic4md.ftn b/model/src/w3sic4md.F90 similarity index 94% rename from model/ftn/w3sic4md.ftn rename to model/src/w3sic4md.F90 index 22408286c..8661b42af 100644 --- a/model/ftn/w3sic4md.ftn +++ b/model/src/w3sic4md.F90 @@ -280,10 +280,18 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) USE W3IDATMD, ONLY: ICEP1, ICEP2, ICEP3, ICEP4, ICEP5, & MUDT, MUDV, MUDD, INFLAGS2 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -296,9 +304,13 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: ITH -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: ITH + REAL :: DOUT(NK,NTH) +#endif INTEGER :: IKTH, IK, ITH, IC4METHOD, IFC REAL :: D1D(NK), EB(NK) REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & @@ -314,7 +326,9 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIC4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIC4') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -363,10 +377,14 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) IF (INFLAGS2(-3)) ICECOEF5 = ICEP5(IX,IY) ! Borrow from Smud (error if BT8 or BT9) -!/BT8 WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' -!/BT8 CALL EXTCDE(202) -!/BT9 WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' -!/BT9 CALL EXTCDE(202) +#ifdef W3_BT8 + WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' + CALL EXTCDE(202) +#endif +#ifdef W3_BT9 + WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' + CALL EXTCDE(202) +#endif IF (INFLAGS2(-2)) ICECOEF6 = MUDD(IX,IY) ! a.k.a. MDN IF (INFLAGS2(-1)) ICECOEF7 = MUDT(IX,IY) ! a.k.a. MTH IF (INFLAGS2(0 )) ICECOEF8 = MUDV(IX,IY) ! a.k.a. MVS @@ -386,7 +404,9 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! ! (none) ! -!/T38 WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#ifdef W3_T38 + WRITE (NDST,9000) DEPTH,ICECOEF1,ICECOEF2,ICECOEF3,ICECOEF4 +#endif ! ! 1. Make calculations ---------------------------------------------- / ! @@ -522,23 +542,31 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#endif ! ! Formats ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SIC4 : '/ & ' ',A,' REQUIRED BUT NOT SELECTED'/) ! -!/T 9000 FORMAT (' TEST W3SIC4 : DEPTH,ICECOEF1 : ',2E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIC4 : DEPTH,ICECOEF1 : ',2E10.3) +#endif !/ !/ End of W3SIC4 --------------------------------------------------- / !/ diff --git a/model/ftn/w3sic5md.ftn b/model/src/w3sic5md.F90 similarity index 96% rename from model/ftn/w3sic5md.ftn rename to model/src/w3sic5md.F90 index fad3faadd..bef13c519 100644 --- a/model/ftn/w3sic5md.ftn +++ b/model/src/w3sic5md.F90 @@ -267,10 +267,18 @@ SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) ! 10. Source code : !/ ------------------------------------------------------------------- / !/ -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif !/ USE CONSTANTS, ONLY: TPI USE W3SERVMD, ONLY: EXTCDE @@ -290,9 +298,13 @@ SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: ITH -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: ITH + REAL :: DOUT(NK,NTH) +#endif !/ REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & ICECOEF4, ICECONC @@ -302,7 +314,9 @@ SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) LOGICAL :: NOICE !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIC5') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIC5') +#endif ! ! 0. Initializations ------------------------------------------------ / D = 0. @@ -391,16 +405,22 @@ SUBROUTINE W3SIC5 (A, DEPTH, CG, WN, IX, IY, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sice', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sice') +#endif ! ! Formats ! @@ -487,7 +507,9 @@ SUBROUTINE W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, & ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS, ONLY: TPI USE W3GDATMD, ONLY: NK, SIG USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR @@ -507,11 +529,15 @@ SUBROUTINE W3IC5WNCG(WN_R, WN_I, CG, HICE, IVISC, RHOI, ISMODG, & INTEGER :: KL, KU, IK REAL :: TWN_R, TWN_I !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3IC5WNCG') +#ifdef W3_S + CALL STRACE (IENT, 'W3IC5WNCG') +#endif !/ ! Initialize SIGMA {in w3gdatmd: SIG (0: NK+1)} IF (ALLOCATED(SIGMA)) DEALLOCATE(SIGMA); ALLOCATE(SIGMA(SIZE(CG))) @@ -628,7 +654,9 @@ SUBROUTINE FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE CONSTANTS, ONLY: GRAV, TPI USE W3DISPMD, ONLY: WAVNU1 @@ -662,11 +690,15 @@ SUBROUTINE FSDISP(HICE, IVISC, RHOI, ISMODG, HWAT, WT, WNR, WNI) COMPLEX(KDPC) :: GUESS, CROOT, C1D, C2D REAL(KDP) :: HWATD !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'FSDISP') +#ifdef W3_S + CALL STRACE (IENT, 'FSDISP') +#endif ! Note, same as W3IC3WNCG_xx in w3sic3md : ! HICE → ICE1 ! IVISC → ICE2 @@ -926,7 +958,9 @@ SUBROUTINE BALANCING_MATRIX(NMAT, MATRIX) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -936,14 +970,18 @@ SUBROUTINE BALANCING_MATRIX(NMAT, MATRIX) REAL, INTENT(INOUT) :: MATRIX(NMAT, NMAT) !/ ------------------------------------------------------------------- / !/ Local parameter -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! the parameter radx is the machine's floating-point radix REAL, PARAMETER :: RADX = RADIX(MATRIX), & SQRADX = RADX ** 2 INTEGER :: I, LAST REAL :: C, F, G, R, S !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'BALANCING_MATRIX') +#ifdef W3_S + CALL STRACE (IENT, 'BALANCING_MATRIX') +#endif ! DO LAST = 1 @@ -1081,7 +1119,9 @@ SUBROUTINE EIG_HQR (NMAT, HMAT, EIGR, EIGI) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR @@ -1098,14 +1138,18 @@ SUBROUTINE EIG_HQR (NMAT, HMAT, EIGR, EIGI) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ INTEGER :: I, ITS, K, L, M, NN, MNNK, IDIAG REAL :: ANORM, P, Q, R, S, T, U, V, W, X, Y, Z REAL :: PP(NMAT) !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'EIG_HQR') +#ifdef W3_S + CALL STRACE (IENT, 'EIG_HQR') +#endif ! ! Compute matrix norm for possible use in locating single small ! subdiagonal element. @@ -1379,7 +1423,9 @@ SUBROUTINE POLYROOTS(NPC, PCVEC, RTRL, RTIM) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR @@ -1395,13 +1441,17 @@ SUBROUTINE POLYROOTS(NPC, PCVEC, RTRL, RTIM) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: HESS(NPC-1, NPC-1) INTEGER :: J !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'POLYROOTS') +#ifdef W3_S + CALL STRACE (IENT, 'POLYROOTS') +#endif ! ! IF (ABS(PCVEC(1)) < ERRTOL) THEN @@ -1521,7 +1571,9 @@ FUNCTION NR_CORR(K, C1, C2, H) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -1537,14 +1589,18 @@ FUNCTION NR_CORR(K, C1, C2, H) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! A rough value to differentiate deep water case from finite water case REAL(KDP), PARAMETER :: KH_LIM = 7.5 COMPLEX(KDPC) :: LAM, LAMPR, FV, DF, TKH !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'NR_CORR') +#ifdef W3_S + CALL STRACE (IENT, 'NR_CORR') +#endif ! f(k) = (c1 * k**4 + c2) * k * tanh(k*H) - 1 ! = lam * k * tanh(k*H) - 1 ! @@ -1649,7 +1705,9 @@ FUNCTION NR_ROOT(C1, C2, H, GUESS) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, IAPROC, NAPROC, NAPERR @@ -1669,7 +1727,9 @@ FUNCTION NR_ROOT(C1, C2, H, GUESS) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif COMPLEX(KDPC) :: K0, K1, DK INTEGER :: ITER REAL :: TRANVAL @@ -1677,7 +1737,9 @@ FUNCTION NR_ROOT(C1, C2, H, GUESS) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'NR_ROOT') +#ifdef W3_S + CALL STRACE (IENT, 'NR_ROOT') +#endif !/ Set parameters IC5MAXITER = IC5PARS(6) IC5RKICK = IC5PARS(7) ! 0: False, 1: True @@ -1797,7 +1859,9 @@ FUNCTION CMPLX_SINH(X) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -1810,10 +1874,14 @@ FUNCTION CMPLX_SINH(X) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'CMPLX_SINH') +#ifdef W3_S + CALL STRACE (IENT, 'CMPLX_SINH') +#endif !/ CMPLX_SINH = (EXP(X) - EXP(-X)) * 0.5 !/ @@ -1888,7 +1956,9 @@ FUNCTION CMPLX_COSH(X) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -1901,10 +1971,14 @@ FUNCTION CMPLX_COSH(X) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'CMPLX_COSH') +#ifdef W3_S + CALL STRACE (IENT, 'CMPLX_COSH') +#endif !/ CMPLX_COSH = (EXP(X) + EXP(-X)) * 0.5 !/ @@ -1981,7 +2055,9 @@ FUNCTION CMPLX_TANH2(X) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -1994,10 +2070,14 @@ FUNCTION CMPLX_TANH2(X) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'CMPLX_TANH2') +#ifdef W3_S + CALL STRACE (IENT, 'CMPLX_TANH2') +#endif !/ CMPLX_TANH2 = (1 - EXP(-2*X)) / (1 + EXP(-2*X)) !/ @@ -2056,19 +2136,25 @@ SUBROUTINE INIT_RANDOM_SEED() ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ INTEGER :: I, N, CLOCK INTEGER, DIMENSION(:), ALLOCATABLE :: SEED !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'INIT_RANDOM_SEED') +#ifdef W3_S + CALL STRACE (IENT, 'INIT_RANDOM_SEED') +#endif !/ CALL RANDOM_SEED(SIZE = N) ALLOCATE(SEED(N)) diff --git a/model/ftn/w3sis1md.ftn b/model/src/w3sis1md.F90 similarity index 87% rename from model/ftn/w3sis1md.ftn rename to model/src/w3sis1md.F90 index 08f725e96..263f6962d 100644 --- a/model/ftn/w3sis1md.ftn +++ b/model/src/w3sis1md.F90 @@ -111,9 +111,15 @@ SUBROUTINE W3SIS1 (A, ICE, S) USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN2 USE W3GDATMD, ONLY: DTMIN, TH, DTH, ECOS, DTMIN USE W3GDATMD, ONLY: IS1C1, IS1C2 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ARRYMD, ONLY: PRT2DS +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ARRYMD, ONLY: PRT2DS +#endif ! IMPLICIT NONE !/ @@ -125,23 +131,33 @@ SUBROUTINE W3SIS1 (A, ICE, S) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, ITH, ITH2, IS, IS2 REAL :: ALPHA -!/T REAL :: SOUT(NK,NTH) +#ifdef W3_T + REAL :: SOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIS1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIS1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! S = 0. -!/T SOUT = 0. +#ifdef W3_T + SOUT = 0. +#endif ! ! Calculate scattering coefficient (linear transfer function) ---- * ALPHA = MAX(0., IS1C1 * ICE + IS1C2) -!/T WRITE(NDST,8000) ALPHA +#ifdef W3_T + WRITE(NDST,8000) ALPHA +#endif ! IF (ALPHA.GT.0. .AND. ICE.GT.0.) THEN ! 1. Calculate the derivative ---------------------------------------- * @@ -162,15 +178,19 @@ SUBROUTINE W3SIS1 (A, ICE, S) ! S = S / DTMIN ! -!/T DO IK = 1, NK -!/T DO ITH = 1, NTH -!/T IS = ITH+(IK-1)*NTH -!/T SOUT(IK,ITH) = S(IS) -!/T END DO -!/T END DO +#ifdef W3_T + DO IK = 1, NK + DO ITH = 1, NTH + IS = ITH+(IK-1)*NTH + SOUT(IK,ITH) = S(IS) + END DO + END DO +#endif ! -!/T CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & -!/T 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') +#ifdef W3_T + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') +#endif ! END IF ! Formats diff --git a/model/ftn/w3sis2md.ftn b/model/src/w3sis2md.F90 similarity index 98% rename from model/ftn/w3sis2md.ftn rename to model/src/w3sis2md.F90 index 25288357c..66a5a6c79 100644 --- a/model/ftn/w3sis2md.ftn +++ b/model/src/w3sis2md.F90 @@ -115,7 +115,9 @@ SUBROUTINE INSIS2 EC2, ES2, ESC, ESIN, ECOS USE CONSTANTS, ONLY: TPI, TPIINV USE W3SERVMD, ONLY: DIAGONALIZE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -126,11 +128,15 @@ SUBROUTINE INSIS2 REAL :: SIS1HTABLE(20), SIS1FTABLE(25) REAL :: SIS1ALPHATABLE(NTHICK,25), X REAL :: SIS1ALPHATABLE2(NTHICK,25) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'SIS2ALPHATAB') +#ifdef W3_S + CALL STRACE (IENT, 'SIS2ALPHATAB') +#endif ! ! -------------------------------------------------------------------- / ! 1. Fills array of reflection as a function of frequency and ice thickness @@ -669,9 +675,15 @@ SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & USE W3SERVMD, ONLY: EXTCDE USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, DDEN, IS2PARS, XFR, & IICEHMIN,IICESMOOTH -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ARRYMD, ONLY: PRT2DS +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ARRYMD, ONLY: PRT2DS +#endif USE W3DISPMD ! IMPLICIT NONE @@ -688,7 +700,9 @@ SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, IKP1, IKM1, ITH, ITH2, IS, IS2, IND1, IND2 REAL :: W INTEGER :: IKBREAK, NSUM @@ -705,11 +719,15 @@ SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & REAL :: GAMMA_TOY REAL, DIMENSION(NK) :: WN_I, WN_RP, WSQ, WLG, WLG_I, CG_I, & CURV, CGRATIO, CG_EFF, DUMMY, ALPHA_DISP -!/T REAL :: SOUT(NK,NTH) +#ifdef W3_T + REAL :: SOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIS1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIS1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! @@ -769,7 +787,9 @@ SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & ENDIF ENDIF ! -!/T SOUT = 0. +#ifdef W3_T + SOUT = 0. +#endif ! IF (CICE .GT. 0) THEN ! @@ -978,15 +998,19 @@ SUBROUTINE W3SIS2 (A, DEPTH, CICE, ICEH, ICEF, ICEDMAX, IX, IY, & ICEF = 0. END IF ! end of test (CICE .GT. 0 .AND. ICEDAVE .GT. 0) ! -!/T DO IK = 1, NK -!/T DO ITH = 1, NTH -!/T IS = ITH+(IK-1)*NTH -!/T SOUT(IK,ITH) = S(IS) -!/T END DO -!/T END DO -! -!/T CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & -!/T 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') +#ifdef W3_T + DO IK = 1, NK + DO ITH = 1, NTH + IS = ITH+(IK-1)*NTH + SOUT(IK,ITH) = S(IS) + END DO + END DO +#endif +! +#ifdef W3_T + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Sir1', ' ', 'NONAME') +#endif ! ! Formats 8000 FORMAT (' TEST W3SIS2 : ALPHA :',E10.3) diff --git a/model/ftn/w3sln1md.ftn b/model/src/w3sln1md.F90 similarity index 95% rename from model/ftn/w3sln1md.ftn rename to model/src/w3sln1md.F90 index 211a42f53..266539262 100644 --- a/model/ftn/w3sln1md.ftn +++ b/model/src/w3sln1md.F90 @@ -139,7 +139,9 @@ SUBROUTINE W3SLN1 (K, FHIGH, USTAR, USDIR, S) USE W3GDATMD, ONLY: NTH, NK, ECOS, ESIN, SIG, SLNC1, FSPM, FSHF USE W3ODATMD, ONLY: NDSE, NDST USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -153,17 +155,23 @@ SUBROUTINE W3SLN1 (K, FHIGH, USTAR, USDIR, S) !/ Local parameters !/ INTEGER :: ITH, IK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: COSU, SINU, DIRF(NTH), FAC, FF1, FF2, & FFILT, RFR, WNF(NK) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SLN1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SLN1') +#endif ! ! 1. Set up factors ------------------------------------------------- * ! -!/T WRITE (NDST,900) USTAR, USDIR*RADE +#ifdef W3_T + WRITE (NDST,900) USTAR, USDIR*RADE +#endif ! COSU = COS(USDIR) SINU = SIN(USDIR) @@ -195,7 +203,9 @@ SUBROUTINE W3SLN1 (K, FHIGH, USTAR, USDIR, S) ! ! Formats ! -!/T 900 FORMAT ( ' TEST W3SLN1 : USTAR, DIR :',F6.3, F6.1) +#ifdef W3_T + 900 FORMAT ( ' TEST W3SLN1 : USTAR, DIR :',F6.3, F6.1) +#endif !/ !/ End of W3SLN1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3smcomd.ftn b/model/src/w3smcomd.F90 similarity index 98% rename from model/ftn/w3smcomd.ftn rename to model/src/w3smcomd.F90 index e48e4d56e..f07ecff87 100644 --- a/model/ftn/w3smcomd.ftn +++ b/model/src/w3smcomd.F90 @@ -569,14 +569,18 @@ SUBROUTINE CALC_INTERP() !-------------------------------------------------------------------------- USE W3GDATMD, ONLY: CLATS USE CONSTANTS, ONLY : DERA, RADIUS -!/RTD USE W3SERVMD, ONLY: W3LLTOEQ -!/RTD USE W3GDATMD, ONLY: POLON, POLAT +#ifdef W3_RTD + USE W3SERVMD, ONLY: W3LLTOEQ + USE W3GDATMD, ONLY: POLON, POLAT +#endif IMPLICIT NONE INTEGER :: IERR, I, J, ISEA, N, CFAC REAL :: mlon(NSEA), mlat(NSEA), olon(nxo,nyo), olat(nxo,nyo), & ang(nxo,nyo), lon, lat -!/RTD REAL :: tmplon(nxo,nyo), tmplat(nxo,nyo) +#ifdef W3_RTD + REAL :: tmplon(nxo,nyo), tmplat(nxo,nyo) +#endif ! Determine smallest cell size factor: cfac = 2**(NRLv - 1) @@ -601,12 +605,14 @@ SUBROUTINE CALC_INTERP() ENDDO ENDDO -!/RTD tmplat = olat -!/RTD tmplon = olon -!/RTD PRINT*,'Rotating coordinates' -!/RTD CALL W3LLTOEQ ( tmplat, tmplon, olat, olon, & -!/RTD ang, POLAT, POLON, NXO*NYO ) -!/RTD PRINT*,'Rotating coordinates complete' +#ifdef W3_RTD + tmplat = olat + tmplon = olon + PRINT*,'Rotating coordinates' + CALL W3LLTOEQ ( tmplat, tmplon, olat, olon, & + ang, POLAT, POLON, NXO*NYO ) + PRINT*,'Rotating coordinates complete' +#endif ! Cycle over output grid points and find containing SMC cell: ! NOTE : BRUTE FORCE! diff --git a/model/ftn/w3snl1md.ftn b/model/src/w3snl1md.F90 similarity index 94% rename from model/ftn/w3snl1md.ftn rename to model/src/w3snl1md.F90 index 41fbe1e0a..eed6fe455 100644 --- a/model/ftn/w3snl1md.ftn +++ b/model/src/w3snl1md.F90 @@ -232,11 +232,21 @@ SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 !!/DEBUGSRC USE W3ODATMD, only : IAPROC -!/T USE W3ODATMD, ONLY: NDST -!/T1 USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T1 + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -250,11 +260,15 @@ SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) !/ Local parameters !/ INTEGER :: ITH, IFR, ISP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: X, X2, CONS, CONX, FACTOR, & E00, EP1, EM1, EP2, EM2, & SA1A, SA1B, SA2A, SA2B -!/T0 REAL :: SOUT(NK,NFR), DOUT(NK,NFR) +#ifdef W3_T0 + REAL :: SOUT(NK,NFR), DOUT(NK,NFR) +#endif REAL :: UE (1-NTH:NSPECY), SA1 (1-NTH:NSPECX), & SA2 (1-NTH:NSPECX), DA1C(1-NTH:NSPECX), & DA1P(1-NTH:NSPECX), DA1M(1-NTH:NSPECX), & @@ -265,7 +279,9 @@ SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) !/ ! initialisations ! -!/S CALL STRACE (IENT, 'W3SNL1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL1') +#endif ! ! 1. Calculate prop. constant --------------------------------------- * ! @@ -273,7 +289,9 @@ SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) X2 = MAX ( -1.E15, SNLS3*X) CONS = SNLC1 * ( 1. + SNLS1/X * (1.-SNLS2*X) * EXP(X2) ) ! -!/T WRITE (NDST,9000) KDMEAN, CONS +#ifdef W3_T + WRITE (NDST,9000) KDMEAN, CONS +#endif ! ! 2. Prepare auxiliary spectrum and arrays -------------------------- * ! @@ -377,27 +395,35 @@ SUBROUTINE W3SNL1 (A, CG, KDMEAN, S, D) ! ! ... Test output : ! -!/T0 DO IFR=1, NFR -!/T0 DO ITH=1, NTH -!/T0 ISP = ITH + (IFR-1)*NTH -!/T0 SOUT(IFR,ITH) = S(ISP) * TPI * SIG(IFR) / CG(IFR) -!/T0 DOUT(IFR,ITH) = D(ISP) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IFR=1, NFR + DO ITH=1, NTH + ISP = ITH + (IFR-1)*NTH + SOUT(IFR,ITH) = S(ISP) * TPI * SIG(IFR) / CG(IFR) + DOUT(IFR,ITH) = D(ISP) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') +#ifdef W3_T1 + CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SNL1 : KDMEAN, CONS :',F8.2,F8.1) +#ifdef W3_T + 9000 FORMAT (' TEST W3SNL1 : KDMEAN, CONS :',F8.2,F8.1) +#endif !/ !/ End of W3SNL1 ----------------------------------------------------- / !/ @@ -486,7 +512,9 @@ SUBROUTINE INSNL1 ( IMOD ) AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, AWG7, AWG8, & SWG1, SWG2, SWG3, SWG4, SWG5, SWG6, SWG7, SWG8 USE W3ODATMD, ONLY: NDST, NDSE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -503,7 +531,9 @@ SUBROUTINE INSNL1 ( IMOD ) IF5(:), IF6(:), IF7(:), IF8(:), & IT1(:), IT2(:), IT3(:), IT4(:), & IT5(:), IT6(:), IT7(:), IT8(:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DELTH3, DELTH4, LAMM2, LAMP2, CTHP, & WTHP, WTHP1, CTHM, WTHM, WTHM1, & XFRLN, WFRP, WFRP1, WFRM, WFRM1, FR, & @@ -511,8 +541,12 @@ SUBROUTINE INSNL1 ( IMOD ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSNL1') -!/T WRITE (NDST,9000) IMOD +#ifdef W3_S + CALL STRACE (IENT, 'INSNL1') +#endif +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! NFR = NK ! @@ -692,7 +726,9 @@ SUBROUTINE INSNL1 ( IMOD ) ! ! Formats ! -!/T 9000 FORMAT (' TEST INSNL1 : IMOD :',I4) +#ifdef W3_T + 9000 FORMAT (' TEST INSNL1 : IMOD :',I4) +#endif !/ !/ End of INSNL1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3snl2md.ftn b/model/src/w3snl2md.F90 similarity index 83% rename from model/ftn/w3snl2md.ftn rename to model/src/w3snl2md.F90 index b755445fe..f2eb0c3d4 100644 --- a/model/ftn/w3snl2md.ftn +++ b/model/src/w3snl2md.F90 @@ -144,9 +144,15 @@ SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) USE W3GDATMD, ONLY: NK, NTH, SIG, TH, IQTPE USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif USE m_xnldata, ONLY: xnl_main !/ IMPLICIT NONE @@ -161,14 +167,22 @@ SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) !/ Local parameters !/ INTEGER :: IK, ITH, IERR = 0 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: A2(NK,NTH), S2(NK,NTH), D2(NK,NTH) -!/T0 REAL :: SOUT(NK,NK), DOUT(NK,NK) +#ifdef W3_T0 + REAL :: SOUT(NK,NK), DOUT(NK,NK) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SNL2') -!/T WRITE (NDST,9000) IQTPE +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL2') +#endif +#ifdef W3_T + WRITE (NDST,9000) IQTPE +#endif ! ! 1. Convert input spectrum ----------------------------------------- * ! (Action sigma spectrum, reversed indices) @@ -197,20 +211,26 @@ SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) ! ! ... Test output : ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 SOUT(IK,ITH) = S(IK,ITH) * TPI * SIG(IK) / CG(IK) -!/T0 DOUT(IK,ITH) = D(IK,ITH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + SOUT(IK,ITH) = S(IK,ITH) * TPI * SIG(IK) / CG(IK) + DOUT(IK,ITH) = D(IK,ITH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & -!/T0 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, SOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Snl(f,t)', ' ', 'NONAME') + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:NK), ' ', 1., & + 0.0, 0.001, 'Diag Snl', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') +#ifdef W3_T1 + CALL OUTMAT (NDST, S, NTH, NTH, NK, 'Snl') + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'Diag Snl') +#endif ! RETURN ! @@ -225,7 +245,9 @@ SUBROUTINE W3SNL2 ( A, CG, DEPTH, S, D ) 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3SNL2 :'/ & ' xnl_main RETURN CODE NON ZERO : ',I4,' ***'/) ! -!/T 9000 FORMAT (' TEST W3SNL2 : IQTPE :',I4) +#ifdef W3_T + 9000 FORMAT (' TEST W3SNL2 : IQTPE :',I4) +#endif !/ !/ End of W3SNL2 ----------------------------------------------------- / !/ @@ -292,7 +314,9 @@ SUBROUTINE INSNL2 NLTAIL, DPTHNL, NDPTHS, IQTPE USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPERR USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE m_xnldata USE m_constants, ONLY: init_constants !/ @@ -301,22 +325,28 @@ SUBROUTINE INSNL2 !/ Local parameters !/ INTEGER :: IGRD, IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: XGRAV !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSNL2') +#ifdef W3_S + CALL STRACE (IENT, 'INSNL2') +#endif ! ! 1. Set necessary values : ----------------------------------------- * ! XGRAV = GRAV IGRD = 3 ! -!/T WRITE (NDST,9000) NLTAIL, XGRAV, IQTPE, IGRD, NDPTHS -!/T WRITE (NDST,9001) DPTHNL -!/T WRITE (NDST,9002) SIG(1)*TPIINV, SIG(NK)*TPIINV, & -!/T TH(1)*RADE, TH(NTH)*RADE +#ifdef W3_T + WRITE (NDST,9000) NLTAIL, XGRAV, IQTPE, IGRD, NDPTHS + WRITE (NDST,9001) DPTHNL + WRITE (NDST,9002) SIG(1)*TPIINV, SIG(NK)*TPIINV, & + TH(1)*RADE, TH(NTH)*RADE +#endif ! ! 2. Call initialization routines : --------------------------------- * ! @@ -340,14 +370,16 @@ SUBROUTINE INSNL2 1000 FORMAT (/' *** WAVEWATCH III ERROR IN INSNL2 :'/ & ' xnl_init RETURN CODE NON ZERO : ',I8/) ! -!/T 9000 FORMAT (' TEST INSNL2 : NLTAIL :',F6.1/ & -!/T ' XGRAV :',F8.3/ & -!/T ' IQTPE :',I4/ & -!/T ' IGRD :',I4/ & -!/T ' NDPTHS :',I4,' (depths follow)') -!/T 9001 FORMAT (' ',5E10.3) -!/T 9002 FORMAT (' FREQS :',2F8.3/ & -!/T ' DIRS :',2F6.1) +#ifdef W3_T + 9000 FORMAT (' TEST INSNL2 : NLTAIL :',F6.1/ & + ' XGRAV :',F8.3/ & + ' IQTPE :',I4/ & + ' IGRD :',I4/ & + ' NDPTHS :',I4,' (depths follow)') + 9001 FORMAT (' ',5E10.3) + 9002 FORMAT (' FREQS :',2F8.3/ & + ' DIRS :',2F6.1) +#endif !/ !/ End of INSNL2 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3snl3md.ftn b/model/src/w3snl3md.F90 similarity index 92% rename from model/ftn/w3snl3md.ftn rename to model/src/w3snl3md.F90 index 4dc272d94..692fc35d6 100644 --- a/model/ftn/w3snl3md.ftn +++ b/model/src/w3snl3md.F90 @@ -276,7 +276,9 @@ SUBROUTINE W3SNL3 ( A, CG, WN, DEPTH, S, D ) ! USE W3SERVMD, ONLY: EXTCDE USE W3DISPMD, ONLY: WAVNU1 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -292,7 +294,9 @@ SUBROUTINE W3SNL3 ( A, CG, WN, DEPTH, S, D ) INTEGER :: IFR, IERR, IKD, JKD(NFRCUT), IQA, IF1MIN, & IF1MAX, IF2MIN, IF2MAX, ISP0, ISPX0, ITH, & ISP, ISPX -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: LQST1(16), LQST4(16) REAL :: XSITLN, SIT, FPROP, FQ1, FQ2, FQ3, FQ4, & AUX1, AUX2 @@ -305,7 +309,9 @@ SUBROUTINE W3SNL3 ( A, CG, WN, DEPTH, S, D ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SNL3') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL3') +#endif ! ! 1. Initialization ------------------------------------------------- * ! 1.a Constants and arrays @@ -771,7 +777,9 @@ SUBROUTINE INSNL3 ! USE W3DISPMD, ONLY: WAVNU2 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -785,7 +793,9 @@ SUBROUTINE INSNL3 NQS, J, IFR, IQA, JJ, JF, NTHMX2, & JIQ, JOF, JQR, IST INTEGER :: JFR(4), JFR1(4), JTH(4), JTH1(4) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: AST1(:,:,:), AST2(:,:,:) REAL :: SITMAX, XFRLN REAL :: OFF12, OFF34, TH12, DEPTH, & @@ -806,7 +816,9 @@ SUBROUTINE INSNL3 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSNL3') +#ifdef W3_S + CALL STRACE (IENT, 'INSNL3') +#endif ! ! 1. Initialization ------------------------------------------------- * ! 1.a Checks @@ -824,7 +836,9 @@ SUBROUTINE INSNL3 SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) ! -!/T WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT +#ifdef W3_T + WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT +#endif ! ! 2. Building quadruplet data base ---------------------------------- * ! For quadruplet and interaction strength evaluation @@ -850,7 +864,9 @@ SUBROUTINE INSNL3 ! DO IQ=1, SNLNQ ! -!/T1 WRITE (NDST,9020) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH +#ifdef W3_T1 + WRITE (NDST,9020) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH +#endif ! OFF12 = SNLM(IQ) OFF34 = SNLL(IQ) @@ -868,8 +884,10 @@ SUBROUTINE INSNL3 OFF34.GT.MAXLAM(OFF12,SNLT(IQ)) ) GOTO 802 END IF ! -!/T1 WRITE (NDST,9021) SNLT(IQ), OFF12, OFF34, & -!/T1 SNLCD(IQ), SNLCS(IQ) +#ifdef W3_T1 + WRITE (NDST,9021) SNLT(IQ), OFF12, OFF34, & + SNLCD(IQ), SNLCS(IQ) +#endif ! ! 2.c Offset angles ! @@ -912,7 +930,9 @@ SUBROUTINE INSNL3 DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) ! -!/T1 WRITE (NDST,9022) DELTH(:) * RADE +#ifdef W3_T1 + WRITE (NDST,9022) DELTH(:) * RADE +#endif ! ! 2.d Frequency indices ! @@ -926,10 +946,12 @@ SUBROUTINE INSNL3 IFRMIN = MIN ( IFRMIN , MINVAL(JFR1) ) IFRMAX = MAX ( IFRMAX , MAXVAL(JFR1) ) ! -!/T1 WRITE (NDST,9023) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) -!/T1 DO, J=2, 4 -!/T1 WRITE (NDST,9024) J, JFR(J), JFR1(J), WFR(J), WFR1(J) -!/T1 END DO +#ifdef W3_T1 + WRITE (NDST,9023) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) + DO, J=2, 4 + WRITE (NDST,9024) J, JFR(J), JFR1(J), WFR(J), WFR1(J) + END DO +#endif ! ! 2.e Directional indices ! @@ -943,10 +965,12 @@ SUBROUTINE INSNL3 ! NTHMAX = MAX ( NTHMAX , MAXVAL(ABS(JTH1)) ) ! -!/T1 WRITE (NDST,9025) 1, JTH(1), JTH1(1), WTH(1), WTH1(1) -!/T1 DO, J=2, 4 -!/T1 WRITE (NDST,9024) J, JTH(J), JTH1(J), WTH(J), WTH1(J) -!/T1 END DO +#ifdef W3_T1 + WRITE (NDST,9025) 1, JTH(1), JTH1(1), WTH(1), WTH1(1) + DO, J=2, 4 + WRITE (NDST,9024) J, JTH(J), JTH1(J), WTH(J), WTH1(J) + END DO +#endif ! ! 2.f Temp storage of data ! @@ -1006,8 +1030,12 @@ SUBROUTINE INSNL3 ! END DO ! -!/T1 WRITE (NDST,*) -!/T WRITE (NDST,9026) NQA, SNLNQ*4, NQD, NQS +#ifdef W3_T1 + WRITE (NDST,*) +#endif +#ifdef W3_T + WRITE (NDST,9026) NQA, SNLNQ*4, NQD, NQS +#endif ! ! 2.g Expanded spectral range ! @@ -1022,8 +1050,10 @@ SUBROUTINE INSNL3 NSPMAX = NFRMAX * NTHEXP - NTHMAX NSPMX2 = NFRCUT * NTHEXP - NTHMAX ! -!/T WRITE (NDST,9027) NFR, NFRMIN, NFRMAX, NFRCUT, NTH, & -!/T 1-NTHMAX, NTH+NTHMAX, NTHEXP +#ifdef W3_T + WRITE (NDST,9027) NFR, NFRMIN, NFRMAX, NFRCUT, NTH, & + 1-NTHMAX, NTH+NTHMAX, NTHEXP +#endif ! ALLOCATE ( MPARS(IGRID)%SNLPS%FRQ(NFRMAX), & MPARS(IGRID)%SNLPS%XSI(NFRMAX) ) @@ -1114,13 +1144,17 @@ SUBROUTINE INSNL3 ! DO IQ=1, SNLNQ ! -!/T2 WRITE (NDST,9030) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH +#ifdef W3_T2 + WRITE (NDST,9030) IKD, IQ, WN0*DEPTH, S0*TPIINV, DEPTH +#endif ! OFF12 = SNLM(IQ) OFF34 = SNLL(IQ) TH12 = SNLT(IQ) * DERA ! -!/T2 WRITE (NDST,9031) SNLT(IQ), OFF12, OFF34 +#ifdef W3_T2 + WRITE (NDST,9031) SNLT(IQ), OFF12, OFF34 +#endif ! ! 3.c Frequency indices ! @@ -1136,10 +1170,12 @@ SUBROUTINE INSNL3 WFR1(J) = 1. - WFR(J) END DO ! -!/T2 WRITE (NDST,9032) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) -!/T2 DO, J=2, 4 -!/T2 WRITE (NDST,9033) J, JFR(J), JFR1(J), WFR(J), WFR1(J) -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9032) 1, JFR(1), JFR1(1), WFR(1), WFR1(1) + DO, J=2, 4 + WRITE (NDST,9033) J, JFR(J), JFR1(J), WFR(J), WFR1(J) + END DO +#endif ! ! 3.d Loop over quadruplet components ! @@ -1174,7 +1210,9 @@ SUBROUTINE INSNL3 S4 = SIOFF * ( 1. - OFF34 ) CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) ! -!/T2 WRITE (NDST,9034) JIQ, JOF, IFR, WFROFF, SIOFF/S0 +#ifdef W3_T2 + WRITE (NDST,9034) JIQ, JOF, IFR, WFROFF, SIOFF/S0 +#endif ! IF ( TH12 .LT. 0. ) THEN BB = 2. * WN0 @@ -1201,7 +1239,9 @@ SUBROUTINE INSNL3 DELTH(3) = - ACOS( MAX ( 0. , MIN ( 1. , AUX1 ) ) ) DELTH(4) = ACOS( MAX ( 0. , MIN ( 1. , AUX2 ) ) ) ! -!/T2 WRITE (NDST,9035) DELTH(:) * RADE +#ifdef W3_T2 + WRITE (NDST,9035) DELTH(:) * RADE +#endif ! AUX1 = DELTH(JIQ) / DTH JTH (JIQ) = INT(AUX1) @@ -1211,8 +1251,10 @@ SUBROUTINE INSNL3 ! NTHMX2 = MAX ( NTHMX2 , ABS(JTH1(JIQ)) ) ! -!/T2 WRITE (NDST,9036) JIQ, JTH(JIQ), JTH1(JIQ), & -!/T2 WTH(JIQ), WTH1(JIQ) +#ifdef W3_T2 + WRITE (NDST,9036) JIQ, JTH(JIQ), JTH1(JIQ), & + WTH(JIQ), WTH1(JIQ) +#endif ! ! 3.f Loop over quadruplet realizations ! @@ -1266,15 +1308,17 @@ SUBROUTINE INSNL3 ! END DO ! -!/T3 DO JQR=1, JJ -!/T3 WRITE (NDST,9037) IKD, NQA+JQR -!/T3 DO IST=1, 16 -!/T3 WRITE (NDST,9038) IST, AST1(IST,NQA+JQR,IKD), & -!/T3 AST2(IST,NQA+JQR,IKD), & -!/T3 QST5(IST,NQA+JQR,IKD), & -!/T3 QST6(IST,NQA+JQR,IKD) -!/T3 END DO -!/T3 END DO +#ifdef W3_T3 + DO JQR=1, JJ + WRITE (NDST,9037) IKD, NQA+JQR + DO IST=1, 16 + WRITE (NDST,9038) IST, AST1(IST,NQA+JQR,IKD), & + AST2(IST,NQA+JQR,IKD), & + QST5(IST,NQA+JQR,IKD), & + QST6(IST,NQA+JQR,IKD) + END DO + END DO +#endif ! ! ... End loop 3.b ! @@ -1339,32 +1383,42 @@ SUBROUTINE INSNL3 1011 FORMAT (/' *** WAVEWATCH-III ERROR IN INSNL3 :'/ & ' NQA INCONSISTENT :', 2I8/) ! -!/T 9010 FORMAT (/' TEST INSNL3: NKD, KDMIN/MAX/X : ',I8,3F10.4) -! -!/T1 9020 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) -!/T1 9021 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & -!/T1 ' OFF12, OFF34 : ',3X,2F8.2/ & -!/T1 ' CD, CS : ',3X,2E10.2) -!/T1 9022 FORMAT ( ' ANGLES (DEGR) : ',1X,4F8.2) -!/T1 9023 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) -!/T1 9024 FORMAT ( ' : ',1X,3I4,2F6.2) -!/T1 9025 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) -!/T 9026 FORMAT ( ' TEST INSNL3: FILLING FIRST DATA TABLES :'/ & -!/T ' NQA AND MAXIMUM : ',2I8/ & -!/T ' NQD AND NQS : ',2I8) -!/T 9027 FORMAT ( ' NFR, MIN/MAX/CUT : ',4I8/ & -!/T ' NTH, MIN/MAX/EXP : ',4I8) -! -!/T2 9030 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) -!/T2 9031 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & -!/T2 ' OFF12, OFF34 : ',3X,2F8.2) -!/T2 9032 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) -!/T2 9033 FORMAT ( ' : ',1X,3I4,2F6.2) -!/T2 9034 FORMAT ( ' J,J,J, W, SIn : ',1X,3I4,2F6.2) -!/T2 9035 FORMAT ( ' ANGLES (DEGR) : ',3X,4F8.2) -!/T2 9036 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) -!/T3 9037 FORMAT (/' TEST INSNL3: STORAGE ARRAYS FOR IKD, IQA =',2I6) -!/T3 9038 FORMAT (23X,3I4,3F8.3) +#ifdef W3_T + 9010 FORMAT (/' TEST INSNL3: NKD, KDMIN/MAX/X : ',I8,3F10.4) +#endif +! +#ifdef W3_T1 + 9020 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) + 9021 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & + ' OFF12, OFF34 : ',3X,2F8.2/ & + ' CD, CS : ',3X,2E10.2) + 9022 FORMAT ( ' ANGLES (DEGR) : ',1X,4F8.2) + 9023 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) + 9024 FORMAT ( ' : ',1X,3I4,2F6.2) + 9025 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) +#endif +#ifdef W3_T + 9026 FORMAT ( ' TEST INSNL3: FILLING FIRST DATA TABLES :'/ & + ' NQA AND MAXIMUM : ',2I8/ & + ' NQD AND NQS : ',2I8) + 9027 FORMAT ( ' NFR, MIN/MAX/CUT : ',4I8/ & + ' NTH, MIN/MAX/EXP : ',4I8) +#endif +! +#ifdef W3_T2 + 9030 FORMAT (/' TEST INSNL3: IKD, IQ, KD, F, D: ',2I8,2F10.4,F10.2) + 9031 FORMAT (/' TEST INSNL3: TH12 : ',3X,F8.2/ & + ' OFF12, OFF34 : ',3X,2F8.2) + 9032 FORMAT ( ' FREQUENCY IND. : ',1X,3I4,2F6.2) + 9033 FORMAT ( ' : ',1X,3I4,2F6.2) + 9034 FORMAT ( ' J,J,J, W, SIn : ',1X,3I4,2F6.2) + 9035 FORMAT ( ' ANGLES (DEGR) : ',3X,4F8.2) + 9036 FORMAT ( ' DIRECTIONAL IND. : ',1X,3I4,2F6.2) +#endif +#ifdef W3_T3 + 9037 FORMAT (/' TEST INSNL3: STORAGE ARRAYS FOR IKD, IQA =',2I6) + 9038 FORMAT (23X,3I4,3F8.3) +#endif !/ !/ Embedded subroutines !/ diff --git a/model/ftn/w3snl4md.ftn b/model/src/w3snl4md.F90 similarity index 99% rename from model/ftn/w3snl4md.ftn rename to model/src/w3snl4md.F90 index 7507b4378..3819d0b18 100644 --- a/model/ftn/w3snl4md.ftn +++ b/model/src/w3snl4md.F90 @@ -301,9 +301,13 @@ SUBROUTINE INSNL4 !! ================================================================== !! !! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY: NDSE, NDST, NDSO -!/MPI USE WMMDATMD, ONLY: NMPSCR, IMPROC +#ifdef W3_MPI + USE WMMDATMD, ONLY: NMPSCR, IMPROC +#endif !! ------------------------------------------------------------------ !! ================================================================== !! @@ -313,7 +317,9 @@ SUBROUTINE INSNL4 !! !! Local variables & Parameters !! ---------------------------- -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !! integer :: irng !* dummy integer integer :: nd !* dummy integer @@ -338,7 +344,9 @@ SUBROUTINE INSNL4 !!============================================================================== !! !! -!/S CALL STRACE (IENT, 'W3SNL4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL4') +#endif !! !! ================================================================== !! @@ -378,9 +386,13 @@ SUBROUTINE INSNL4 !! !!-3 File exists open it and read it !! -!/MPI if ( improc .eq. nmpscr ) then +#ifdef W3_MPI + if ( improc .eq. nmpscr ) then +#endif write ( ndso, 900 ) grdfname -!/MPI end if +#ifdef W3_MPI + end if +#endif !! open (UNIT=io_unit, FILE=grdfname, STATUS='old', & ACCESS='sequential', ACTION='read', FORM='unformatted') @@ -396,9 +408,13 @@ SUBROUTINE INSNL4 !! !!-4 File does not exist, create it here !! -!/MPI if ( improc .eq. nmpscr ) then +#ifdef W3_MPI + if ( improc .eq. nmpscr ) then +#endif write ( ndso, 901 ) grdfname -!/MPI end if +#ifdef W3_MPI + end if +#endif !! ---------------------------------------------------------------- !! !!-4a Define Look-up tables depth array 'dep_tbl(ndep)' for ndep=37 @@ -499,7 +515,9 @@ SUBROUTINE INSNL4 !! !!-5 Ounce the Look-up tables arrays are full write it out to 'io_unit' !! -!/MPI if ( improc .eq. nmpscr ) then +#ifdef W3_MPI + if ( improc .eq. nmpscr ) then +#endif write( ndso,902 ) open (UNIT=io_unit, FILE=grdfname, STATUS='new', & ACCESS='sequential', ACTION='write', FORM='unformatted') @@ -509,7 +527,9 @@ SUBROUTINE INSNL4 pha_tbl, dep_tbl close (io_unit) write( ndso,903 ) grdfname -!/MPI end if +#ifdef W3_MPI + end if +#endif !! ---------------------------------------------------------------- !! ================================================================ !! @@ -711,7 +731,9 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! USE W3SERVMD, ONLY: EXTCDE USE W3ODATMD, ONLY: NDSE, NDST, NDSO -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !! ================================================================== !! IMPLICIT NONE @@ -727,7 +749,9 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! !! Local Parameters & variables !! ----------------------------- -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif integer :: irng, iang integer :: nd3 !* bin # corresp. to ww3 dep real :: dep !* depth (m), get it from WW3 DEPTH @@ -765,7 +789,9 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !!============================================================================== !! !! -!/S CALL STRACE (IENT, 'W3SNL4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL4') +#endif !! !!ini !! Initialization of the output arrays diff --git a/model/ftn/w3snl5md.ftn b/model/src/w3snl5md.F90 old mode 100755 new mode 100644 similarity index 93% rename from model/ftn/w3snl5md.ftn rename to model/src/w3snl5md.F90 index 44da364d1..594cfcf85 --- a/model/ftn/w3snl5md.ftn +++ b/model/src/w3snl5md.F90 @@ -151,7 +151,9 @@ SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & USE W3PARALL, ONLY: INIT_GET_ISEA USE W3TIMEMD, ONLY: DSEC21 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -184,12 +186,16 @@ SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & REAL :: PM_PREV, PM_IVAL, PM_DELT REAL :: WBT, BTINV INTEGER :: IUNT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SNL5') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNL5') +#endif ! !/ ------------------------------------------------------------------- / ! Read in wave info. @ the previous time step t0 @@ -208,15 +214,19 @@ SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & ! Three options for phase mixing IF (QI5PMX .EQ. 0) THEN ! 1) 0: no phase mixing -!/TS IF (IAPROC .EQ. NAPOUT) & -!/TS WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)') & -!/TS " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL:", & -!/TS QI5TBEG, T1ABS, T1REL +#ifdef W3_TS + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)') & + " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL:", & + QI5TBEG, T1ABS, T1REL +#endif ELSE -!/TS IF (IAPROC .EQ. NAPOUT) & -!/TS WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)', ADVANCE='no') & -!/TS " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL, T1REL[P]:", & -!/TS QI5TBEG, T1ABS, T1REL +#ifdef W3_TS + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, '(A, 2(I10.8, I7.6), E12.3)', ADVANCE='no') & + " ⊚ → [WW3 SNL₅] QI5TBEG, T1ABS, T1REL, T1REL[P]:", & + QI5TBEG, T1ABS, T1REL +#endif ! ! Calc. Phase mixing interval IF (QI5PMX .GT. 0) THEN @@ -252,10 +262,12 @@ SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & ELSE T1REL = PM_DELT END IF -!/TS IF (IAPROC .EQ. NAPOUT) THEN -!/TS WRITE(SCREEN, '(F9.1)') T1REL -!/TS IF (QI5PMX .LT. 0 ) WRITE(SCREEN, '(A, F6.3)') '↔ bT: ', WBT -!/TS ENDIF +#ifdef W3_TS + IF (IAPROC .EQ. NAPOUT) THEN + WRITE(SCREEN, '(F9.1)') T1REL + IF (QI5PMX .LT. 0 ) WRITE(SCREEN, '(A, F6.3)') '↔ bT: ', WBT + ENDIF +#endif END IF ! ! Calc. Cvk1 from A (C(\bm{k}) = g N(k, θ) / k) @@ -322,9 +334,11 @@ SUBROUTINE W3SNL5(A, CG, WN, FMEAN, T1ABS, U10, UDIR, JSEA, & PDIFF = ABS(PSEA(1:NSEL) - ISEA) IF (ANY(PDIFF .EQ. 0)) THEN JLOC = MINLOC(PDIFF, 1) -!/TS IF (IAPROC .EQ. NAPOUT) & -!/TS WRITE(SCREEN, '(3A, I10.8, I7.6)') & -!/TS '✓ Point output for |', PNMS(JLOC), '| @', T1ABS +#ifdef W3_TS + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, '(3A, I10.8, I7.6)') & + '✓ Point output for |', PNMS(JLOC), '| @', T1ABS +#endif ! N(θ, k) → F(f, θ) & S(θ, k) → S(f, θ) DO ITH = 1, NTH @@ -426,7 +440,9 @@ SUBROUTINE INSNL5 QI5IPL, QI5PMX USE W3ODATMD, ONLY: IAPROC, NAPOUT, SCREEN USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -437,11 +453,15 @@ SUBROUTINE INSNL5 !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSNL5') +#ifdef W3_S + CALL STRACE (IENT, 'INSNL5') +#endif ! ! Set important parameters for GKE module (QR[I]5DPT/OML/DIS/KEV are ! defined in ww3_grid.inp, and QI5NNZ is not known yet) @@ -508,7 +528,9 @@ FUNCTION CALC_WBTv2 (A, CG, WN, DPT, U10, UDIR) !/ ------------------------------------------------------------------- / USE W3DISPMD, ONLY: WAVNU1 USE W3GDATMD, ONLY: NK, NTH, SIG, ESIN, ECOS, DTH, DSII -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -526,7 +548,9 @@ FUNCTION CALC_WBTv2 (A, CG, WN, DPT, U10, UDIR) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! REAL, PARAMETER :: BETA = 1.2 ! @@ -538,7 +562,9 @@ FUNCTION CALC_WBTv2 (A, CG, WN, DPT, U10, UDIR) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'CALC_WBTv2') +#ifdef W3_S + CALL STRACE (IENT, 'CALC_WBTv2') +#endif ! ! Wind info. is required to select wind sea partition from the wave ! spectrum. @@ -673,7 +699,9 @@ SUBROUTINE INPOUT USE W3ODATMD, ONLY: NOPTS, PTNME, PTLOC, IPTINT, & IAPROC, NAPOUT, SCREEN USE W3SERVMD, ONLY: DIST_SPHERE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -725,17 +753,19 @@ SUBROUTINE INPOUT JY = IYS(JLOC) ISEA = MAPFS(JY, JX) ! Basic check -!/TS IF (FLAGLL) THEN -!/TS IF (IAPROC .EQ. NAPOUT) & -!/TS WRITE(SCREEN, "(A, 2F10.3, A, 2F10.3, A)") & -!/TS '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& -!/TS XGRD(JY, JX), YGRD(JY, JX), ')' -!/TS ELSE -!/TS IF (IAPROC .EQ. NAPOUT) & -!/TS WRITE(SCREEN, "(A, 2E10.3, A, 2E10.3, A)") & -!/TS '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& -!/TS XGRD(JY, JX), YGRD(JY, JX), ')' -!/TS END IF +#ifdef W3_TS + IF (FLAGLL) THEN + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, "(A, 2F10.3, A, 2F10.3, A)") & + '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& + XGRD(JY, JX), YGRD(JY, JX), ')' + ELSE + IF (IAPROC .EQ. NAPOUT) & + WRITE(SCREEN, "(A, 2E10.3, A, 2E10.3, A)") & + '✗ (PLON, PLAT): (', PLON, PLAT, ') | (XGRD, YGRD): (',& + XGRD(JY, JX), YGRD(JY, JX), ')' + END IF +#endif ! Store ISEA NSEL = NSEL + 1 PSEA(NSEL) = ISEA diff --git a/model/ftn/w3snlsmd.ftn b/model/src/w3snlsmd.F90 similarity index 92% rename from model/ftn/w3snlsmd.ftn rename to model/src/w3snlsmd.F90 index 0c352cea2..11310c14d 100644 --- a/model/ftn/w3snlsmd.ftn +++ b/model/src/w3snlsmd.F90 @@ -170,8 +170,12 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) USE W3ODATMD, ONLY: NDST, NDSE ! USE W3DISPMD, ONLY: WAVNU1 -!/S USE W3SERVMD, ONLY: STRACE -!/T2 USE W3ARRYMD, ONLY: PRT2DS +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T2 + USE W3ARRYMD, ONLY: PRT2DS +#endif !/ IMPLICIT NONE !/ @@ -187,7 +191,9 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) !/ INTEGER :: IFR, IFRMIN, ITH, IFRMN2, & IKD, JKD(0:NFR+2), ISPX0, ISPX -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SIGP, CP, CM, XL, XH, EL, EH, DENOM, & SIT, XSITLN, MC, F3A, F3B, F3C, & F4A, F4B, F4C, F00, F31, F32, F41, & @@ -203,9 +209,13 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SNLS') +#ifdef W3_S + CALL STRACE (IENT, 'W3SNLS') +#endif ! -!/T WRITE (NDST,9000) DEPTH, UABS, DT +#ifdef W3_T + WRITE (NDST,9000) DEPTH, UABS, DT +#endif ! ! 1. Initializations ------------------------------------------------ * ! 1.a Expanded frequency range @@ -225,7 +235,9 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) ! ! 1.c Get relevant spectral peak frequency ! -!/T1 E1 = -1. +#ifdef W3_T1 + E1 = -1. +#endif SIGP = - TPI XL = 1./XFR - 1. XH = XFR - 1. @@ -294,7 +306,9 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) XSITLN = LOG(XSIT) IFRMIN = 1 JKD = 1 -!/T1 FILTFP = -1. +#ifdef W3_T1 + FILTFP = -1. +#endif ! DO IFR=NFR+2, 1, -1 ! @@ -317,12 +331,16 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) IKD = 1 + NINT ( ( LOG(SIT) - LOG(SITMIN) ) / XSITLN ) JKD(IFRMN2) = MAX ( 1 , MIN(IKD,NKD) ) ! -!/T WRITE (NDST,9010) IFRMIN, SIGP * TPIINV -!/T1 WRITE (NDST,9011) -!/T1 DO IFR=1, NFR -!/T1 WRITE (NDST,9012) IFR, XSI(IFR)/TPI, XSI(IFR)/XWN(IFR), & -!/T1 E1(IFR), FILTFP(IFR) -!/T1 END DO +#ifdef W3_T + WRITE (NDST,9010) IFRMIN, SIGP * TPIINV +#endif +#ifdef W3_T1 + WRITE (NDST,9011) + DO IFR=1, NFR + WRITE (NDST,9012) IFR, XSI(IFR)/TPI, XSI(IFR)/XWN(IFR), & + E1(IFR), FILTFP(IFR) + END DO +#endif ! ! 1.e Initialize arrays ! @@ -389,7 +407,9 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) ! 3.a Check for request ! IF ( PRESENT(SNL) ) THEN -!/T WRITE (NDST,9030) 'YES/--' +#ifdef W3_T + WRITE (NDST,9030) 'YES/--' +#endif ! ! 3.b Initializations ! @@ -436,15 +456,19 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) ! ! ... End loop 3.c ! -!/T ELSE -!/T WRITE (NDST,9030) '---/NO' +#ifdef W3_T + ELSE + WRITE (NDST,9030) '---/NO' +#endif END IF ! ! 4. Compute filtered spectrum if requested ------------------------- * ! 4.a Check for request ! IF ( PRESENT(AA) ) THEN -!/T WRITE (NDST,9040) 'YES/--' +#ifdef W3_T + WRITE (NDST,9040) 'YES/--' +#endif ! ! 4.b Initializations ! @@ -491,23 +515,35 @@ SUBROUTINE W3SNLS ( A, CG, WN, DEPTH, UABS, DT, SNL, AA ) ! ! ... End loop 4.c ! -!/T ELSE -!/T WRITE (NDST,9040) '---/NO' +#ifdef W3_T + ELSE + WRITE (NDST,9040) '---/NO' +#endif END IF ! -!/T stop +#ifdef W3_T + stop +#endif RETURN ! ! Formats ! -!/T 9000 FORMAT (/' TEST W3SNLS: DEPTH, UABS, DT :',F9.2,F7.2,F7.2) +#ifdef W3_T + 9000 FORMAT (/' TEST W3SNLS: DEPTH, UABS, DT :',F9.2,F7.2,F7.2) +#endif ! -!/T 9010 FORMAT ( ' IFRMIN, FP :',I4,F8.4) -!/T1 9011 FORMAT ( ' TEST W3SNLS: IFR, FR, C, E1, FILT :') -!/T1 9012 FORMAT (13X,I4,F10.4,2F10.2,F10.4) +#ifdef W3_T + 9010 FORMAT ( ' IFRMIN, FP :',I4,F8.4) +#endif +#ifdef W3_T1 + 9011 FORMAT ( ' TEST W3SNLS: IFR, FR, C, E1, FILT :') + 9012 FORMAT (13X,I4,F10.4,2F10.2,F10.4) +#endif ! -!/T 9030 FORMAT ( ' TEST W3SNLS: SOURCE TERM REQUESTED : ',A) -!/T 9040 FORMAT ( ' TEST W3SNLS: AVERAGING REQUESTED : ',A) +#ifdef W3_T + 9030 FORMAT ( ' TEST W3SNLS: SOURCE TERM REQUESTED : ',A) + 9040 FORMAT ( ' TEST W3SNLS: AVERAGING REQUESTED : ',A) +#endif !/ !/ Embedded subroutines !/ @@ -644,7 +680,9 @@ SUBROUTINE INSNLS ! USE W3DISPMD, ONLY: WAVNU2 USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -655,14 +693,18 @@ SUBROUTINE INSNLS !/ Local parameters !/ INTEGER :: IKD, IERR -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DEPTH, SITMAX, OFF, S0, WN0, CG0, & S3, WN3, CG3, S4, WN4, CG4, WN12, & DT3, DT4, B3, B4 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSNLS') +#ifdef W3_S + CALL STRACE (IENT, 'INSNLS') +#endif ! ! 1. Initializations ------------------------------------------------ * ! 1.a Set up relative depths @@ -672,7 +714,9 @@ SUBROUTINE INSNLS SITMAX = SQRT ( KDMAX * TANH(KDMAX) ) XSIT = (SITMAX/SITMIN)**(1./REAL(NKD-1)) ! -!/T WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT +#ifdef W3_T + WRITE (NDST,9010) NKD, KDMIN, KDMAX, XSIT +#endif ! ! 1.b Set up quadruplet ! @@ -707,7 +751,9 @@ SUBROUTINE INSNLS CALL WAVNU2 ( S3, DEPTH, WN3, CG3, 1.E-6, 25, IERR) CALL WAVNU2 ( S4, DEPTH, WN4, CG4, 1.E-6, 25, IERR) ! -!/T WRITE (NDST,9020) IKD, WN0*DEPTH, S0*TPIINV, DEPTH +#ifdef W3_T + WRITE (NDST,9020) IKD, WN0*DEPTH, S0*TPIINV, DEPTH +#endif ! ! 2.c Offset angles ! @@ -718,7 +764,9 @@ SUBROUTINE INSNLS B3 = DT3 / DTH B4 = DT4 / DTH ! -!/T WRITE (NDST,9021) A34, B3, B4, DT3*RADE, DT4*RADE +#ifdef W3_T + WRITE (NDST,9021) A34, B3, B4, DT3*RADE, DT4*RADE +#endif ! IF ( A34.GT.ABMAX .OR. B3.GT.ABMAX .OR. B4.GT.ABMAX .OR. & A34.LT.0. .OR. B3.LT.0. .OR. B4.LT.0. ) GOTO 801 @@ -750,9 +798,11 @@ SUBROUTINE INSNLS ' PARAMETER FORCED OUT OF RANGE '/ & ' A34, B3, B4 :', 3F10.4/) ! -!/T 9010 FORMAT (/' TEST INSNLS: NKD, KDMIN/MAX/X :',I5,3F10.4) -!/T 9020 FORMAT ( ' IKD, KD, F, D :',I5,3F10.4) -!/T 9021 FORMAT ( ' A34, B3,B4, TH3/4:',3F7.3,2F6.2) +#ifdef W3_T + 9010 FORMAT (/' TEST INSNLS: NKD, KDMIN/MAX/X :',I5,3F10.4) + 9020 FORMAT ( ' IKD, KD, F, D :',I5,3F10.4) + 9021 FORMAT ( ' A34, B3,B4, TH3/4:',3F7.3,2F6.2) +#endif !/ ! /End of INSNLS ------------------------------------------------------/ !/ diff --git a/model/ftn/w3src0md.ftn b/model/src/w3src0md.F90 similarity index 94% rename from model/ftn/w3src0md.ftn rename to model/src/w3src0md.F90 index 3a737a814..0113016c1 100644 --- a/model/ftn/w3src0md.ftn +++ b/model/src/w3src0md.F90 @@ -122,8 +122,12 @@ SUBROUTINE W3SPR0 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) !/ ------------------------------------------------------------------- / USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -137,12 +141,16 @@ SUBROUTINE W3SPR0 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) !/ Local parameters !/ INTEGER :: IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: EB(NK), EBAND !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR0') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR0') +#endif ! EMEAN = 0. FMEAN = 0. @@ -181,13 +189,17 @@ SUBROUTINE W3SPR0 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 ! -!/T WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#ifdef W3_T + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3E10.3) +#endif !/ !/ End of W3SPR0 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3src1md.ftn b/model/src/w3src1md.F90 similarity index 85% rename from model/ftn/w3src1md.ftn rename to model/src/w3src1md.F90 index 1f83a8285..98aacdded 100644 --- a/model/ftn/w3src1md.ftn +++ b/model/src/w3src1md.F90 @@ -131,8 +131,12 @@ SUBROUTINE W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) !/ ------------------------------------------------------------------- / USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, SIG, DDEN, FTE, FTF, FTWN -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -146,12 +150,16 @@ SUBROUTINE W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) !/ Local parameters !/ INTEGER :: IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: EB(NK), EBAND !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR1') +#endif ! EMEAN = 0. FMEAN = 0. @@ -190,13 +198,17 @@ SUBROUTINE W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) FMEAN = TPIINV * EMEAN / MAX ( 1.E-7 , FMEAN ) WNMEAN = ( EMEAN / MAX ( 1.E-7 , WNMEAN ) )**2 ! -!/T WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#ifdef W3_T + WRITE (NDST,9000) EMEAN, FMEAN, WNMEAN +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SPR1 : E,F,WN MEAN ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SPR1 : E,F,WN MEAN ',3E10.3) +#endif !/ !/ End of W3SPR1 ----------------------------------------------------- / !/ @@ -273,12 +285,22 @@ SUBROUTINE W3SIN1 (A, K, USTAR, USDIR, S, D) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/T USE CONSTANTS +#ifdef W3_T + USE CONSTANTS +#endif USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SIG2, ESIN, ECOS, SINC1 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -292,16 +314,26 @@ SUBROUTINE W3SIN1 (A, K, USTAR, USDIR, S, D) !/ Local parameters !/ INTEGER :: IS -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: IK, ITH +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: IK, ITH +#endif REAL :: COSU, SINU -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIN1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIN1') +#endif ! -!/T WRITE (NDST,9000) SINC1, USTAR, USDIR*RADE +#ifdef W3_T + WRITE (NDST,9000) SINC1, USTAR, USDIR*RADE +#endif ! ! 1. Preparations ! @@ -320,22 +352,30 @@ SUBROUTINE W3SIN1 (A, K, USTAR, USDIR, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SIN1 : COMMON FACT.: ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIN1 : COMMON FACT.: ',3E10.3) +#endif !/ !/ End of W3SIN1 ----------------------------------------------------- / !/ @@ -413,10 +453,18 @@ SUBROUTINE W3SDS1 (A, K, EMEAN, FMEAN, WNMEAN, S, D) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, SDSC1 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -431,20 +479,30 @@ SUBROUTINE W3SDS1 (A, K, EMEAN, FMEAN, WNMEAN, S, D) !/ Local parameters !/ INTEGER :: IS -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: IK, ITH +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: IK, ITH +#endif REAL :: FACTOR -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDS1') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDS1') +#endif ! ! 1. Common factor ! FACTOR = SDSC1 * FMEAN * WNMEAN**3 * EMEAN**2 ! -!/T WRITE (NDST,9000) SDSC1, FMEAN, WNMEAN, EMEAN, FACTOR +#ifdef W3_T + WRITE (NDST,9000) SDSC1, FMEAN, WNMEAN, EMEAN, FACTOR +#endif ! ! 3. Source term ! @@ -453,22 +511,30 @@ SUBROUTINE W3SDS1 (A, K, EMEAN, FMEAN, WNMEAN, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SDS1 : COMMON FACT.: ',5E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SDS1 : COMMON FACT.: ',5E10.3) +#endif !/ !/ End of W3SDS1 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3src2md.ftn b/model/src/w3src2md.F90 similarity index 79% rename from model/ftn/w3src2md.ftn rename to model/src/w3src2md.F90 index 45ad3bc8f..3f5450cd0 100644 --- a/model/ftn/w3src2md.ftn +++ b/model/src/w3src2md.F90 @@ -168,9 +168,13 @@ SUBROUTINE W3SPR2 (A, CG, WN, DEPTH, FPI, U, USTAR, & USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, DTH, SIG, DDEN, FTE, FTF, FTWN, & NITTIN, ZWIND, CINXSI -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE !/ IMPLICIT NONE @@ -187,12 +191,16 @@ SUBROUTINE W3SPR2 (A, CG, WN, DEPTH, FPI, U, USTAR, & !/ Local parameters !/ INTEGER :: IK, ITH, I1, ITT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: EBAND, FPISTR, EB(NK), UST !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR2') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR2') +#endif ! UST = MAX ( 0.0001 , USTAR ) ! @@ -327,10 +335,18 @@ SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, & ESIN, ECOS, FTE, FTTR, FPIMIN, ZWIND, & FACTI1, FACTI2, FSWELL -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif !/ IMPLICIT NONE !/ @@ -345,21 +361,31 @@ SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) !/ Local parameters !/ INTEGER :: IS, IK, IOMA, ICL, NKFILT, NKFIL2 -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER ITH +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER ITH +#endif REAL :: COSU, SINU, COSFAC, LAMBDA, ULAM, & CLAM, OMA, M0, M1, RD1, RD2, BETA, & FACLN1, FACLN2, USTAR, TRANS, FPISTR,& FP1STR, FP1, SIN1A(NK) REAL, PARAMETER :: TRANSF = 0.75 REAL, PARAMETER :: PEAKFC = 0.8 -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIN2') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIN2') +#endif ! -!/T WRITE (NDST,9000) DSIGA, DDRAG, U, UDIR*RADE, CD, Z0 +#ifdef W3_T + WRITE (NDST,9000) DSIGA, DDRAG, U, UDIR*RADE, CD, Z0 +#endif ! ! 1. Preparations ! @@ -368,7 +394,9 @@ SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) ! ! 2. Loop over spectrum ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif ! FACLN1 = U / LOG(ZWIND/Z0) FACLN2 = LOG(Z0) @@ -393,8 +421,10 @@ SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) + RD1 * RD2 * BETATB(IOMA+1,ICL+1) D(IS) = BETA * SIG2(IS) S(IS) = A(IS) * D(IS) -!/T2 WRITE (NDST,9021) IS, COSFAC, LAMBDA, ULAM, CLAM*1.E3, & -!/T2 OMA, BETA*1.E4 +#ifdef W3_T2 + WRITE (NDST,9021) IS, COSFAC, LAMBDA, ULAM, CLAM*1.E3, & + OMA, BETA*1.E4 +#endif END DO ! ! 3. Calculate FPI @@ -449,27 +479,37 @@ SUBROUTINE W3SIN2 ( A, CG, K, U, UDIR, CD, Z0, FPI, S, D ) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SIN2 : DSIGA,DDRAG,U,UDIR,CD,Z0(IN) : '/ & -!/T ' ',F8.4,F9.6,F7.2,F6.1,F8.5,F8.5) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIN2 : DSIGA,DDRAG,U,UDIR,CD,Z0(IN) : '/ & + ' ',F8.4,F9.6,F7.2,F6.1,F8.5,F8.5) +#endif ! -!/T2 9020 FORMAT (' TEST W3SIN2 : IS, COS, LAMBDA, ULAM, CLAM*1E3, ', & -!/T2 'OMA, BETA*1E4') -!/T2 9021 FORMAT (6X,I6,F7.2,1X,F6.1,2(1X,F5.2),2(1X,F6.2)) +#ifdef W3_T2 + 9020 FORMAT (' TEST W3SIN2 : IS, COS, LAMBDA, ULAM, CLAM*1E3, ', & + 'OMA, BETA*1E4') + 9021 FORMAT (6X,I6,F7.2,1X,F6.1,2(1X,F5.2),2(1X,F6.2)) +#endif !/ !/ End of W3SIN2 ----------------------------------------------------- / !/ @@ -552,10 +592,18 @@ SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) FACTI1, FACTI2, XF1, XF2, XFH, SDSALN, & CDSA0, CDSA1, CDSA2, CDSB0, CDSB1, CDSB2, & CDSB3 -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -570,18 +618,28 @@ SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) !/ Local parameters !/ INTEGER :: IK, ITH, IKHW -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FHW, XHW, FPIT, PHI, AF1, AF2, & AFILT, BFILT, CDIST, FILT, POW, & CDISH, CDISP, HW, EHIGH, EBD(NK) -!/T REAL POWMAX -!/T0 REAL DOUT(NK,NTH) +#ifdef W3_T + REAL POWMAX +#endif +#ifdef W3_T0 + REAL DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDS2') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDS2') +#endif ! -!/T WRITE (NDST,9000) FPI, USTAR +#ifdef W3_T + WRITE (NDST,9000) FPI, USTAR +#endif ! ! 1. Preparations ! 1.a HW @@ -629,8 +687,12 @@ SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) ! ! 2. Combined diagonal factor ! -!/T2 WRITE (NDST,9020) -!/T POWMAX = 0. +#ifdef W3_T2 + WRITE (NDST,9020) +#endif +#ifdef W3_T + POWMAX = 0. +#endif DO IK=1, NK FILT = MIN ( 1., MAX ( 0. , AFILT + BFILT*SIG(IK) )) POW = MIN ( 25. , CDSA1 / ( CDISP*SIG(IK) )**CDSA2 ) @@ -641,13 +703,19 @@ SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) ELSE D(1,IK) = (1.-FILT) * CDIST * K(IK)**2 END IF -!/T POWMAX = MAX(POW*FILT,POWMAX) -!/T2 WRITE (NDST,9021) IK, FILT, ALFA(IK)/SDSALN, & -!/T2 CDIST*PHI*K(IK)**2, CDSA0*CDISH*SIG(IK)**3 & -!/T2 * (ALFA(IK)/SDSALN)**POW, D(1,IK) +#ifdef W3_T + POWMAX = MAX(POW*FILT,POWMAX) +#endif +#ifdef W3_T2 + WRITE (NDST,9021) IK, FILT, ALFA(IK)/SDSALN, & + CDIST*PHI*K(IK)**2, CDSA0*CDISH*SIG(IK)**3 & + * (ALFA(IK)/SDSALN)**POW, D(1,IK) +#endif END DO ! -!/T WRITE (NDST,9010) AF1, AF2, AFILT, BFILT, POWMAX +#ifdef W3_T + WRITE (NDST,9010) AF1, AF2, AFILT, BFILT, POWMAX +#endif ! ! 3. 2-D diagonal array ! @@ -661,25 +729,35 @@ SUBROUTINE W3SDS2 (A, CG, K, FPI, USTAR, ALFA, S, D) ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH,IK) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH,IK) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1:), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SDS2 : FPI, USTAR : ',2F8.3) -!/T 9010 FORMAT (' TEST W3SDS2 : AF1-2, A-BFILT, PMAX : ',4F7.3,E10.3) -!/T2 9020 FORMAT (' TEST W3SDS2 : IK, FILT, ALFA, DDST, DDSH, DDS') -!/T2 9021 FORMAT (' ',I6,2F7.3,3E11.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SDS2 : FPI, USTAR : ',2F8.3) + 9010 FORMAT (' TEST W3SDS2 : AF1-2, A-BFILT, PMAX : ',4F7.3,E10.3) +#endif +#ifdef W3_T2 + 9020 FORMAT (' TEST W3SDS2 : IK, FILT, ALFA, DDST, DDSH, DDS') + 9021 FORMAT (' ',I6,2F7.3,3E11.3) +#endif !/ !/ End of W3SDS2 ----------------------------------------------------- / !/ @@ -757,7 +835,9 @@ SUBROUTINE INPTAB !/ ------------------------------------------------------------------- / USE CONSTANTS USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -768,16 +848,28 @@ SUBROUTINE INPTAB !/ Local parameters !/ INTEGER :: ISIGA, IDRAG -!/S INTEGER, SAVE :: IENT = 0 -!/T0 INTEGER :: I1 -!/T1 INTEGER :: IE1 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + INTEGER :: I1 +#endif +#ifdef W3_T1 + INTEGER :: IE1 +#endif REAL :: SIGA, DRAG -!/T0 REAL :: BMIN, BMAX -!/T1 REAL :: ENORM, ERR(NRDRAG) +#ifdef W3_T0 + REAL :: BMIN, BMAX +#endif +#ifdef W3_T1 + REAL :: ENORM, ERR(NRDRAG) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INPTAB') +#ifdef W3_S + CALL STRACE (IENT, 'INPTAB') +#endif ! ! 1. Determine range and increments of table ------------------------ * @@ -785,7 +877,9 @@ SUBROUTINE INPTAB DSIGA = SIGAMX / REAL(NRSIGA) DDRAG = DRAGMX / REAL(NRDRAG) ! -!/T WRITE (NDST,9000) SIGAMX, DSIGA, DRAGMX, DDRAG +#ifdef W3_T + WRITE (NDST,9000) SIGAMX, DSIGA, DRAGMX, DDRAG +#endif ! ! 2. Fill table ----------------------------------------------------- * ! @@ -799,83 +893,97 @@ SUBROUTINE INPTAB ! ! 3. Test output ---------------------------------------------------- * ! -!/T0 WRITE (NDST,9010) -!/T0 I1 = MIN (35,NRDRAG) -!/T0 DO ISIGA=-NRSIGA,NRSIGA -!/T0 SIGA = REAL(ISIGA) * DSIGA -!/T0 BMIN = 0. -!/T0 BMAX = 0. -!/T0 DO IDRAG=1, NRDRAG -!/T0 BMIN = MIN ( BMIN , BETATB(ISIGA,IDRAG) ) -!/T0 BMAX = MAX ( BMAX , BETATB(ISIGA,IDRAG) ) -!/T0 END DO -!/T0 BMAX = MAX ( BMAX , -BMIN ) -!/T0 WRITE (NDST,9011) ISIGA, SIGA, BMAX, & -!/T0 (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=1,I1) -!/T0 IF (I1.LT.NRDRAG) WRITE (NDST,9012) & -!/T0 (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=I1+1,NRDRAG) -!/T0 END DO -! -!/T1 WRITE (NDST,9020) -!/T1 IE1 = MIN (30,NRDRAG-1) -!/T1 ENORM = 1000. / ABS(BETATB(0,NRDRAG)) -!/T1 DO ISIGA=-NRSIGA,NRSIGA -!/T1 SIGA = REAL(ISIGA) * DSIGA -!/T1 IF ( ABS(SIGA) .LT. 5.01 ) THEN -!/T1 DO IDRAG=1, NRDRAG-1 -!/T1 DRAG = ( REAL(IDRAG) + 0.5 ) * DDRAG -!/T1 ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & -!/T1 ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA,IDRAG+1) ) -!/T1 END DO -!/T1 WRITE (NDST,9021) ISIGA, SIGA, & -!/T1 (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) -!/T1 IF (IE1.LT.NRDRAG-1) WRITE (NDST,9022) & -!/T1 (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG-1) -!/T1 ENDIF -!/T1 END DO -! -!/T1 WRITE (NDST,9030) -!/T1 IE1 = MIN (30,NRDRAG) -!/T1 ENORM = 1000. / ABS(BETATB(0,NRDRAG)) -!/T1 DO ISIGA=-NRSIGA,NRSIGA-1 -!/T1 SIGA = ( REAL(ISIGA) + 0.5 ) * DSIGA -!/T1 IF ( ABS(SIGA) .LT. 5.01 ) THEN -!/T1 DO IDRAG=1, NRDRAG -!/T1 DRAG = REAL(IDRAG) * DDRAG -!/T1 ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & -!/T1 ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA+1,IDRAG) ) -!/T1 END DO -!/T1 WRITE (NDST,9031) ISIGA, SIGA, & -!/T1 (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) -!/T1 IF (IE1.LT.NRDRAG) WRITE (NDST,9032) & -!/T1 (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG) -!/T1 ENDIF -!/T1 END DO +#ifdef W3_T0 + WRITE (NDST,9010) + I1 = MIN (35,NRDRAG) + DO ISIGA=-NRSIGA,NRSIGA + SIGA = REAL(ISIGA) * DSIGA + BMIN = 0. + BMAX = 0. + DO IDRAG=1, NRDRAG + BMIN = MIN ( BMIN , BETATB(ISIGA,IDRAG) ) + BMAX = MAX ( BMAX , BETATB(ISIGA,IDRAG) ) + END DO + BMAX = MAX ( BMAX , -BMIN ) + WRITE (NDST,9011) ISIGA, SIGA, BMAX, & + (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=1,I1) + IF (I1.LT.NRDRAG) WRITE (NDST,9012) & + (NINT(BETATB(ISIGA,IDRAG)/BMAX*100.),IDRAG=I1+1,NRDRAG) + END DO +#endif +! +#ifdef W3_T1 + WRITE (NDST,9020) + IE1 = MIN (30,NRDRAG-1) + ENORM = 1000. / ABS(BETATB(0,NRDRAG)) + DO ISIGA=-NRSIGA,NRSIGA + SIGA = REAL(ISIGA) * DSIGA + IF ( ABS(SIGA) .LT. 5.01 ) THEN + DO IDRAG=1, NRDRAG-1 + DRAG = ( REAL(IDRAG) + 0.5 ) * DDRAG + ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & + ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA,IDRAG+1) ) + END DO + WRITE (NDST,9021) ISIGA, SIGA, & + (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) + IF (IE1.LT.NRDRAG-1) WRITE (NDST,9022) & + (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG-1) + ENDIF + END DO +#endif +! +#ifdef W3_T1 + WRITE (NDST,9030) + IE1 = MIN (30,NRDRAG) + ENORM = 1000. / ABS(BETATB(0,NRDRAG)) + DO ISIGA=-NRSIGA,NRSIGA-1 + SIGA = ( REAL(ISIGA) + 0.5 ) * DSIGA + IF ( ABS(SIGA) .LT. 5.01 ) THEN + DO IDRAG=1, NRDRAG + DRAG = REAL(IDRAG) * DDRAG + ERR(IDRAG) = - W3BETA (SIGA,DRAG,NDST) + 0.5 * & + ( BETATB(ISIGA,IDRAG) + BETATB(ISIGA+1,IDRAG) ) + END DO + WRITE (NDST,9031) ISIGA, SIGA, & + (NINT(ENORM*ERR(IDRAG)),IDRAG=1,IE1) + IF (IE1.LT.NRDRAG) WRITE (NDST,9032) & + (NINT(ENORM*ERR(IDRAG)),IDRAG=IE1+1,NRDRAG) + ENDIF + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST INPTAB : SIGAMX, DSIGA : ',F6.2,F8.2/ & -!/T ' DRAGMX, DDRAG : ',F8.4,F9.5) -! -!/T0 9010 FORMAT (/' TEST INPTAB : TABLE, NORMALIZED WITH ', & -!/T0 'BETATB(ISIGA,NRDRAG)'/ & -!/T0 ' ISIGA, SIGA, BETA_MAX, TABLE (x100)') -!/T0 9011 FORMAT (1X,I4,F7.2,F6.4,1X,35I3) -!/T0 9012 FORMAT (19X,35I3) -! -!/T1 9020 FORMAT (/' TEST INPTAB : ERROR DUE TO DRAG, NORMALIZED ', & -!/T1 'WITH BETATB(ISIGA,NRDRAG)'/ & -!/T1 ' ISIGA, SIGA, TABLE (x1000)') -!/T1 9021 FORMAT (1X,I4,F7.2,35I3) -!/T1 9022 FORMAT (12X,35I3) -! -!/T1 9030 FORMAT (/' TEST INPTAB : ERROR DUE TO SIGA, NORMALIZED WITH ', & -!/T1 'BETATB(ISIGA,NRDRAG)'/ & -!/T1 ' ISIGA, SIGA, TABLE (x1000)') -!/T1 9031 FORMAT (1X,I4,F7.2,35I3) -!/T1 9032 FORMAT (12X,35I3) +#ifdef W3_T + 9000 FORMAT ( ' TEST INPTAB : SIGAMX, DSIGA : ',F6.2,F8.2/ & + ' DRAGMX, DDRAG : ',F8.4,F9.5) +#endif +! +#ifdef W3_T0 + 9010 FORMAT (/' TEST INPTAB : TABLE, NORMALIZED WITH ', & + 'BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, BETA_MAX, TABLE (x100)') + 9011 FORMAT (1X,I4,F7.2,F6.4,1X,35I3) + 9012 FORMAT (19X,35I3) +#endif +! +#ifdef W3_T1 + 9020 FORMAT (/' TEST INPTAB : ERROR DUE TO DRAG, NORMALIZED ', & + 'WITH BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, TABLE (x1000)') + 9021 FORMAT (1X,I4,F7.2,35I3) + 9022 FORMAT (12X,35I3) +#endif +! +#ifdef W3_T1 + 9030 FORMAT (/' TEST INPTAB : ERROR DUE TO SIGA, NORMALIZED WITH ', & + 'BETATB(ISIGA,NRDRAG)'/ & + ' ISIGA, SIGA, TABLE (x1000)') + 9031 FORMAT (1X,I4,F7.2,35I3) + 9032 FORMAT (12X,35I3) +#endif !/ !/ Internal function W3BETA !/ @@ -948,15 +1056,21 @@ REAL FUNCTION W3BETA ( OMA , CL , NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: OM1, OM2, A0, A1, A2, A3, A4, A5, & A6, A7, A8, A9, A10 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3BETA') +#ifdef W3_S + CALL STRACE (IENT, 'W3BETA') +#endif ! -!/T0 WRITE (NDST,9000) OMA, CL +#ifdef W3_T0 + WRITE (NDST,9000) OMA, CL +#endif ! ! calculate Omegas ! @@ -978,8 +1092,10 @@ REAL FUNCTION W3BETA ( OMA , CL , NDST ) A7 = (A9*(OM2-1)**2+A10) / (OM2-OM1) A8 = A7 * OM1 ! -!/T0 WRITE (NDST,9001) OM1, OM2 -!/T0 WRITE (NDST,9002) A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 +#ifdef W3_T0 + WRITE (NDST,9001) OM1, OM2 + WRITE (NDST,9002) A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10 +#endif ! ! calculate beta * 1.e4 ! @@ -998,17 +1114,21 @@ REAL FUNCTION W3BETA ( OMA , CL , NDST ) ! beta * dwat / dair ! W3BETA = W3BETA * 1.E-4 -!/T0 WRITE (NDST,9003) W3BETA +#ifdef W3_T0 + WRITE (NDST,9003) W3BETA +#endif ! RETURN ! ! Formats ! -!/T0 9000 FORMAT ( ' TEST W3BETA : INPUT : ',2E10.3) -!/T0 9001 FORMAT ( ' TEST W3BETA : OM1-2 : ',2E10.3) -!/T0 9002 FORMAT ( ' TEST W3BETA : A0-10 : ',5E10.3/ & -!/T0 ' ',6E10.3) -!/T0 9003 FORMAT ( ' TEST W3BETA : BETA : ',E10.3) +#ifdef W3_T0 + 9000 FORMAT ( ' TEST W3BETA : INPUT : ',2E10.3) + 9001 FORMAT ( ' TEST W3BETA : OM1-2 : ',2E10.3) + 9002 FORMAT ( ' TEST W3BETA : A0-10 : ',5E10.3/ & + ' ',6E10.3) + 9003 FORMAT ( ' TEST W3BETA : BETA : ',E10.3) +#endif !/ !/ End of W3BETA ----------------------------------------------------- / !/ diff --git a/model/ftn/w3src3md.ftn b/model/src/w3src3md.F90 similarity index 90% rename from model/ftn/w3src3md.ftn rename to model/src/w3src3md.F90 index 0041421a5..886b7efd8 100644 --- a/model/ftn/w3src3md.ftn +++ b/model/src/w3src3md.F90 @@ -151,8 +151,12 @@ SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DTH, DDEN, WWNMEANP, & WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& SSTXFTFTAIL, SSWELLF -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -170,14 +174,18 @@ SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & !/ Local parameters !/ INTEGER :: IS, IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: TAUW, EBAND, EMEANWS, UNZ, & EB(NK),EB2(NK),ALFA(NK) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR3') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR3') +#endif ! UNZ = MAX ( 0.01 , U ) USTAR = MAX ( 0.0001 , USTAR ) @@ -265,14 +273,18 @@ SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & ! ! 6. Final test output ---------------------------------------------- * ! -!/T WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 +#ifdef W3_T + WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 +#endif ! RETURN ! ! Formats ! -!/T 9060 FORMAT (' TEST W3SPR3 : E,WN MN :',F8.3,F8.4/ & -!/T ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +#ifdef W3_T + 9060 FORMAT (' TEST W3SPR3 : E,WN MN :',F8.3,F8.4/ & + ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +#endif !/ !/ End of W3SPR3 ----------------------------------------------------- / !/ @@ -359,17 +371,31 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: GRAV, TPI -!/T USE CONSTANTS, ONLY: RADE +#ifdef W3_T + USE CONSTANTS, ONLY: RADE +#endif USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG, SIG2, TH, & ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& SSWELLF, & DDEN2, DTH, SSINTHP,ZZ0RAT -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ODATMD, ONLY: NDST -!/T0 USE W3ODATMD, ONLY: NDST -!/T1 USE W3ODATMD, ONLY: NDST -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T0 + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T1 + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -387,12 +413,16 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & !/ Local parameters !/ INTEGER :: IS,IK,ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: COSU, SINU, TAUX, TAUY REAL :: UST2, TAUW, TAUWB REAL , PARAMETER :: EPS1 = 0.00001, EPS2 = 0.000001 -!/STAB3 REAL :: Usigma !standard deviation of U due to gustiness -!/STAB3 REAL :: USTARsigma !standard deviation of USTAR due to gustiness +#ifdef W3_STAB3 + REAL :: Usigma !standard deviation of U due to gustiness + REAL :: USTARsigma !standard deviation of USTAR due to gustiness +#endif REAL :: CM,UCO,UCN,ZCN, & Z0VISC REAL XI,DELI1,DELI2 @@ -404,13 +434,19 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & INTEGER IND,J,ISTAB REAL DSTAB(3,NSPEC) REAL STRESSSTAB(3,2),STRESSSTABN(3,2) -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIN3') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIN3') +#endif ! -!/T WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE +#ifdef W3_T + WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE +#endif ! ! 1. Preparations ! @@ -427,13 +463,17 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where ! I got it from, maybe just made up from drag law ... ! -!/STAB3 Usigma=MAX(0.,-0.025*AS) -!/STAB3 USTARsigma=(1.0+U/(10.+U))*Usigma +#ifdef W3_STAB3 + Usigma=MAX(0.,-0.025*AS) + USTARsigma=(1.0+U/(10.+U))*Usigma +#endif UST=USTAR ISTAB=3 -!/STAB3 DO ISTAB=1,2 -!/STAB3 IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) -!/STAB3 IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) +#ifdef W3_STAB3 + DO ISTAB=1,2 + IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) + IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) +#endif TAUX = UST**2* COS(USDIR) TAUY = UST**2* SIN(USDIR) ! @@ -508,26 +548,34 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & TAUWNX =STRESSSTABN(3,1) TAUWNY =STRESSSTABN(3,2) ! WRITE(995,'(A,11G14.5)') 'NEGSTRESS: ',TAUWNX,TAUWNY,FW*UORB**3 -!/STAB3 END DO -!/STAB3 D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) -!/STAB3 XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) -!/STAB3 YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) -!/STAB3 TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) -!/STAB3 TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) +#ifdef W3_STAB3 + END DO + D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) + XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) + YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) + TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) + TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) +#endif S = D * A ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#endif ! ! Computes the high-frequency contribution ! the difference in spectal density (kx,ky) to (f,theta) @@ -572,7 +620,9 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SIN3 : COMMON FACT.: ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIN3 : COMMON FACT.: ',3E10.3) +#endif !/ !/ End of W3SIN3 ----------------------------------------------------- / !/ @@ -636,7 +686,9 @@ SUBROUTINE INSIN3 !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: TPIINV USE W3GDATMD, ONLY: SIG, NK -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -646,11 +698,15 @@ SUBROUTINE INSIN3 !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSIN3') +#ifdef W3_S + CALL STRACE (IENT, 'INSIN3') +#endif ! ! 1. .... ----------------------------------------------------------- * ! @@ -841,8 +897,12 @@ SUBROUTINE TABU_TAUHF(FRMAX) !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: GRAV, TPI USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, XFR, FACHFE, ZZ0MAX -!/T USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -873,9 +933,13 @@ SUBROUTINE TABU_TAUHF(FRMAX) REAL :: Y,YC,DELY INTEGER :: I,J,K,L REAL :: X0 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/S CALL STRACE (IENT, 'TABU_HF') +#ifdef W3_S + CALL STRACE (IENT, 'TABU_HF') +#endif ! USTARM = 5. ALPHAM = 20.*AALPHA @@ -920,7 +984,9 @@ SUBROUTINE TABU_TAUHF(FRMAX) END DO !IF (MOD(K,5).EQ.0.AND.MOD(L,5).EQ.0) & !WRITE(102,'(2I4,3G16.8)') L,K,UST,AALPHA+FLOAT(L)*DELALP,TAUHFT(K,L) -!/T WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) +#ifdef W3_T + WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) +#endif END DO END DO DEALLOCATE(W) @@ -932,7 +998,9 @@ SUBROUTINE TABU_TAUHF(FRMAX) !WRITE(101,*) 'TAUHFT:',FRMAX,BBETA,AALPHA,CONST1,OMEGAC,TPI !WRITE(101,'(20G16.8)') TAUHFT RETURN -!/T 9000 FORMAT (' TABU_HF, L, K :',(2I4,3F8.3)/) +#ifdef W3_T + 9000 FORMAT (' TABU_HF, L, K :',(2I4,3F8.3)/) +#endif END SUBROUTINE TABU_TAUHF !/ ------------------------------------------------------------------- / @@ -1105,13 +1173,25 @@ SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: GRAV, TPI USE W3GDATMD, ONLY: NSPEC, NTH, NK, DDELTA1, DDELTA2, & -!/T0 SIG, & +#ifdef W3_T0 + SIG, & +#endif SSDSC1 -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ODATMD, ONLY: NDST -!/T1 USE W3ODATMD, ONLY: NDST -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T1 + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -1127,14 +1207,20 @@ SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & !/ Local parameters !/ INTEGER :: IS, IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FACTOR, FACTOR2 REAL :: ALFAMEAN, WNMEAN2 -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDS3') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDS3') +#endif ! ! 0. Pre-initialization of arrays, should be set before being used ! but this is helping with bit reproducibility @@ -1146,7 +1232,9 @@ SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & ALFAMEAN=WNMEAN**2*EMEAN FACTOR = SSDSC1 * TPI*FMEAN * ALFAMEAN**2 ! -!/T WRITE (NDST,9000) SSDSC1, FMEAN, WNMEAN, EMEAN, FACTOR +#ifdef W3_T + WRITE (NDST,9000) SSDSC1, FMEAN, WNMEAN, EMEAN, FACTOR +#endif ! !---------------------------------------------------------------------- ! @@ -1167,22 +1255,30 @@ SUBROUTINE W3SDS3 (A, K, CG, EMEAN, FMEAN, WNMEAN, USTAR, USDIR, & ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & + 0.0, 0.001, 'Diag Sds', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sds') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SDS3 : COMMON FACT.: ',5E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SDS3 : COMMON FACT.: ',5E10.3) +#endif !/ !/ End of W3SDS3 ----------------------------------------------------- / !/ diff --git a/model/ftn/w3src4md.ftn b/model/src/w3src4md.F90 similarity index 94% rename from model/ftn/w3src4md.ftn rename to model/src/w3src4md.F90 index 1b0c10c31..bd35e07f8 100644 --- a/model/ftn/w3src4md.ftn +++ b/model/src/w3src4md.F90 @@ -84,7 +84,9 @@ MODULE W3SRC4MD !/ ------------------------------------------------------------------- / SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & AMAX, U, UDIR, & -!/FLX5 TAUA, TAUADIR, DAIR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, DAIR, & +#endif USTAR, USDIR, & TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) !/ @@ -172,18 +174,26 @@ SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & WWNMEANPTAIL, FTE, FTF, SSTXFTF, SSTXFTWN,& SSTXFTFTAIL, SSWELLF, ESIN, ECOS, AAIRCMIN, & AAIRGB, AALPHA, ZZWND -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ODATMD, ONLY: NDST -!/T USE W3ODATMD, ONLY: NDST -! -!/FLX5 USE W3FLX5MD +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST + USE W3ODATMD, ONLY: NDST +#endif +! +#ifdef W3_FLX5 + USE W3FLX5MD +#endif IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ REAL, INTENT(IN) :: A(NTH,NK), CG(NK), WN(NK), U, UDIR -!/FLX5 REAL, INTENT(IN) :: TAUA, TAUADIR, DAIR +#ifdef W3_FLX5 + REAL, INTENT(IN) :: TAUA, TAUADIR, DAIR +#endif REAL, INTENT(IN) :: TAUWX, TAUWY LOGICAL, INTENT(IN) :: LLWS(NSPEC) REAL, INTENT(INOUT) :: USTAR ,USDIR @@ -194,14 +204,18 @@ SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & !/ Local parameters !/ INTEGER :: IS, IK, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: TAUW, EBAND, EMEANWS,UNZ, & EB(NK),EB2(NK),ELCS, ELSN !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR4') +#endif ! UNZ = MAX ( 0.01 , U ) USTAR = MAX ( 0.0001 , USTAR ) @@ -282,32 +296,40 @@ SUBROUTINE W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, WNMEAN, & ! TAUW = SQRT(TAUWX**2+TAUWY**2) ! -!/FLX5 IF (.TRUE.) THEN -!/FLX5 CALL W3FLX5 ( ZZWND, U, UDIR, TAUA, TAUADIR, DAIR, & -!/FLX5 USTAR, USDIR, Z0, CD ) -!/FLX5 IF (USTAR.GT.0.001) THEN -!/FLX5 CHARN = GRAV*Z0/USTAR**2 -!/FLX5 ELSE -!/FLX5 CHARN = AALPHA -!/FLX5 END IF -!/FLX5 ELSE +#ifdef W3_FLX5 + IF (.TRUE.) THEN + CALL W3FLX5 ( ZZWND, U, UDIR, TAUA, TAUADIR, DAIR, & + USTAR, USDIR, Z0, CD ) + IF (USTAR.GT.0.001) THEN + CHARN = GRAV*Z0/USTAR**2 + ELSE + CHARN = AALPHA + END IF + ELSE +#endif Z0=0. CALL CALC_USTAR(U,TAUW,USTAR,Z0,CHARN) UNZ = MAX ( 0.01 , U ) CD = (USTAR/UNZ)**2 USDIR = UDIR -!/FLX5 END IF +#ifdef W3_FLX5 + END IF +#endif ! ! 6. Final test output ---------------------------------------------- * ! -!/T WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 +#ifdef W3_T + WRITE (NDST,9060) EMEAN, WNMEAN, TPIINV, USTAR, CD, Z0 +#endif ! RETURN ! ! Formats ! -!/T 9060 FORMAT (' TEST W3SPR4 : E,WN MN :',F8.3,F8.4/ & -!/T ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +#ifdef W3_T + 9060 FORMAT (' TEST W3SPR4 : E,WN MN :',F8.3,F8.4/ & + ' TPIINV, USTAR, CD, Z0 :',F8.3,F7.2,1X,2F9.5) +#endif !/ !/ End of W3SPR4 ----------------------------------------------------- / !/ @@ -395,18 +417,30 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: GRAV,nu_air,KAPPA,TPI,FWTABLE,SIZEFWTABLE, & -!/T RADE, & +#ifdef W3_T + RADE, & +#endif DELAB,ABMIN USE W3GDATMD, ONLY: NK, NTH, NSPEC, DDEN, SIG, SIG2, TH, & ESIN, ECOS, EC2, ZZWND, AALPHA, BBETA, ZZALP,& TTAUWSHELTER, SSWELLF, DDEN2, DTH, SSINTHP, & ZZ0RAT, SSINBR -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ODATMD, ONLY: NDST -!/T0 USE W3ODATMD, ONLY: NDST +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T0 + USE W3ODATMD, ONLY: NDST +#endif USE W3ODATMD, ONLY: IAPROC -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_T0 + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -424,7 +458,9 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & !/ Local parameters !/ INTEGER :: IS,IK,ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FACLN1, FACLN2, LAMBDA REAL :: COSU, SINU, TAUX, TAUY, USDIRP, USTP REAL :: TAUPX, TAUPY, UST2, TAUW, TAUWB @@ -446,13 +482,19 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & INTEGER IND,J,I,ISTAB REAL DSTAB(3,NSPEC), DVISC, DTURB REAL STRESSSTAB(3,2),STRESSSTABN(3,2) -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SIN4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIN4') +#endif ! -!/T WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE +#ifdef W3_T + WRITE (NDST,9000) BBETA, USTAR, USDIR*RADE +#endif ! ! 1. Preparations ! @@ -537,13 +579,17 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! Abdalla & Cavaleri, JGR 2002 for Usigma. For USTARsigma ... I do not see where ! I got it from, maybe just made up from drag law ... ! -!/STAB3 Usigma=MAX(0.,-0.025*AS) -!/STAB3 USTARsigma=(1.0+U/(10.+U))*Usigma +#ifdef W3_STAB3 + Usigma=MAX(0.,-0.025*AS) + USTARsigma=(1.0+U/(10.+U))*Usigma +#endif UST=USTAR ISTAB=3 -!/STAB3 DO ISTAB=1,2 -!/STAB3 IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) -!/STAB3 IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) +#ifdef W3_STAB3 + DO ISTAB=1,2 + IF (ISTAB.EQ.1) UST=USTAR*(1.-USTARsigma) + IF (ISTAB.EQ.2) UST=USTAR*(1.+USTARsigma) +#endif TAUX = UST**2* COS(USDIR) TAUY = UST**2* SIN(USDIR) ! @@ -649,26 +695,34 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & YSTRESS=STRESSSTAB (3,2) TAUWNX =STRESSSTABN(3,1) TAUWNY =STRESSSTABN(3,2) -!/STAB3 END DO -!/STAB3 D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) -!/STAB3 XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) -!/STAB3 YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) -!/STAB3 TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) -!/STAB3 TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) +#ifdef W3_STAB3 + END DO + D(:)=0.5*(DSTAB(1,:)+DSTAB(2,:)) + XSTRESS=0.5*(STRESSSTAB(1,1)+STRESSSTAB(2,1)) + YSTRESS=0.5*(STRESSSTAB(1,2)+STRESSSTAB(2,2)) + TAUWNX=0.5*(STRESSSTABN(1,1)+STRESSSTABN(2,1)) + TAUWNY=0.5*(STRESSSTABN(1,2)+STRESSSTABN(2,2)) +#endif S = D * A ! ! ... Test output of arrays ! -!/T0 DO IK=1, NK -!/T0 DO ITH=1, NTH -!/T0 DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) -!/T0 END DO -!/T0 END DO +#ifdef W3_T0 + DO IK=1, NK + DO ITH=1, NTH + DOUT(IK,ITH) = D(ITH+(IK-1)*NTH) + END DO + END DO +#endif ! -!/T0 CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & -!/T0 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#ifdef W3_T0 + CALL PRT2DS (NDST, NK, NK, NTH, DOUT, SIG(1), ' ', 1., & + 0.0, 0.001, 'Diag Sin', ' ', 'NONAME') +#endif ! -!/T1 CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#ifdef W3_T1 + CALL OUTMAT (NDST, D, NTH, NTH, NK, 'diag Sin') +#endif ! ! Computes the high-frequency contribution ! the difference in spectal density (kx,ky) to (f,theta) @@ -729,7 +783,9 @@ SUBROUTINE W3SIN4 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & ! ! Formats ! -!/T 9000 FORMAT (' TEST W3SIN4 : COMMON FACT.: ',3E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3SIN4 : COMMON FACT.: ',3E10.3) +#endif !/ !/ End of W3SIN4 ----------------------------------------------------- / !/ @@ -799,7 +855,9 @@ SUBROUTINE INSIN4(FLTABS) SSDSC, SSDSBRF1, SSDSBCK, SSDSBINT, SSDSPBK, & SSDSABK, SSDSHCK, IKTAB, DCKI, SATINDICES, & SATWEIGHTS, CUMULW, NKHS, NKD, NDTAB, QBI -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -822,11 +880,15 @@ SUBROUTINE INSIN4(FLTABS) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INSIN4') +#ifdef W3_S + CALL STRACE (IENT, 'INSIN4') +#endif ! ! 1. Initializations ------------------------------------------------ * ! @@ -1172,9 +1234,13 @@ SUBROUTINE TABU_TAUHF(SIGMAX) ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: KAPPA, GRAV -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, ZZ0MAX -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif ! IMPLICIT NONE !/ @@ -1196,7 +1262,9 @@ SUBROUTINE TABU_TAUHF(SIGMAX) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: USTARM, ALPHAM REAL :: CONST1, OMEGA, OMEGAC REAL :: UST, ZZ0,OMEGACC, CM @@ -1207,7 +1275,9 @@ SUBROUTINE TABU_TAUHF(SIGMAX) INTEGER :: J,K,L REAL :: X0 ! -!/S CALL STRACE (IENT, 'TABU_HF') +#ifdef W3_S + CALL STRACE (IENT, 'TABU_HF') +#endif ! USTARM = 5. ALPHAM = 20.*AALPHA @@ -1250,12 +1320,16 @@ SUBROUTINE TABU_TAUHF(SIGMAX) ! Power of Y in denominator should be FACHFE-4 tail applied here TAUHFT(K,L) = TAUHFT(K,L)+W(J)*ZBETA/Y*DELY END DO -!/T WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) +#ifdef W3_T + WRITE (NDST,9000) L,K,AALPHA+FLOAT(L)*DELALP,UST,TAUHFT(K,L) +#endif END DO END DO DEALLOCATE(W) RETURN -!/T 9000 FORMAT ('TABU_HF, L, K, ALPHA, UST, TAUHFT(K,L) :',(2I4,3F8.3)) +#ifdef W3_T + 9000 FORMAT ('TABU_HF, L, K, ALPHA, UST, TAUHFT(K,L) :',(2I4,3F8.3)) +#endif END SUBROUTINE TABU_TAUHF !/ ------------------------------------------------------------------- / @@ -1315,11 +1389,15 @@ SUBROUTINE TABU_TAUHF2(SIGMAX) ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: KAPPA, GRAV -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3GDATMD, ONLY: AALPHA, BBETA, ZZALP, FACHFE, & TTAUWSHELTER, ZZ0MAX USE W3ODATMD, ONLY: NDSE -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif ! IMPLICIT NONE !/ @@ -1341,7 +1419,9 @@ SUBROUTINE TABU_TAUHF2(SIGMAX) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: USTARM, ALPHAM, LEVTAILM REAL :: CONST1, OMEGA, OMEGAC, LEVTAIL REAL :: UST, UST0, ZZ0,OMEGACC, CM @@ -1360,7 +1440,9 @@ SUBROUTINE TABU_TAUHF2(SIGMAX) CHARACTER(LEN=10) :: VERTST=' ' CHARACTER(LEN=35) :: IDTST=' ' ! -!/S CALL STRACE (IENT, 'TABU_HF') +#ifdef W3_S + CALL STRACE (IENT, 'TABU_HF') +#endif ! FNAMETAB='ST4TABUHF2.bin' NOFILE=.TRUE. @@ -1441,7 +1523,9 @@ SUBROUTINE TABU_TAUHF2(SIGMAX) TAUW=TAUW-W(J)*UST**2*ZBETA*LEVTAIL/Y*DELY UST=SQRT(MAX(TAUW,0.)) END DO -!/T WRITE (NDST,9000) K,L,I,UST0,AALPHA+FLOAT(L)*DELALP,LEVTAIL,TAUHFT2(K,L,I) +#ifdef W3_T + WRITE (NDST,9000) K,L,I,UST0,AALPHA+FLOAT(L)*DELALP,LEVTAIL,TAUHFT2(K,L,I) +#endif END DO END DO END DO @@ -1471,7 +1555,9 @@ SUBROUTINE TABU_TAUHF2(SIGMAX) GOTO 800 2001 CONTINUE RETURN -!/T 9000 FORMAT (' TEST TABU_HFT2, K, L, I, UST, ALPHA, LEVTAIL, TAUHFT2(K,L,I) :',(3I4,4F10.5)) +#ifdef W3_T + 9000 FORMAT (' TEST TABU_HFT2, K, L, I, UST, ALPHA, LEVTAIL, TAUHFT2(K,L,I) :',(3I4,4F10.5)) +#endif END SUBROUTINE TABU_TAUHF2 !/ ------------------------------------------------------------------- / @@ -1535,7 +1621,9 @@ SUBROUTINE CALC_USTAR(WINDSPEED,TAUW,USTAR,Z0,CHARN) !-----------------------------------------------------------------------------! USE CONSTANTS, ONLY: GRAV, KAPPA USE W3GDATMD, ONLY: ZZWND, AALPHA -!/T USE W3ODATMD, ONLY: NDST +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif IMPLICIT NONE REAL, intent(in) :: WINDSPEED,TAUW REAL, intent(out) :: USTAR, Z0, CHARN @@ -1654,13 +1742,23 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & SSDSBRFDF, SSDSBCK, IKTAB, DCKI, & SATINDICES, SATWEIGHTS, CUMULW, NKHS, NKD, & NDTAB, QBI -!/IG1 USE W3GDATMD, ONLY: IGPARS +#ifdef W3_IG1 + USE W3GDATMD, ONLY: IGPARS +#endif USE W3ODATMD, ONLY: FLOGRD -!/S USE W3SERVMD, ONLY: STRACE -!/T USE W3ODATMD, ONLY: NDST -!/T0 USE W3ODATMD, ONLY: NDST -!/T0 USE W3ARRYMD, ONLY: PRT2DS -!/T1 USE W3ARRYMD, ONLY: OUTMAT +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_T0 + USE W3ODATMD, ONLY: NDST + USE W3ARRYMD, ONLY: PRT2DS +#endif +#ifdef W3_T1 + USE W3ARRYMD, ONLY: OUTMAT +#endif ! IMPLICIT NONE !/ @@ -1677,7 +1775,9 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & !/ Local parameters !/ INTEGER :: IS, IS2, IS0, IKL, IKC, ID, NKL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, IK1, ITH, IK2, JTH, ITH2, & IKHS, IKD, SDSNTH, IT, IKM, NKM INTEGER :: NSMOOTH(NK) @@ -1704,7 +1804,9 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & REAL :: MSSLONG(NK,NTH) REAL :: MSSPCS, MSSPC2, MSSPS2, MSSP, MSSD, MSSTH REAL :: MICHE, X, KLOC -!/T0 REAL :: DOUT(NK,NTH) +#ifdef W3_T0 + REAL :: DOUT(NK,NTH) +#endif REAL :: QB(NK), S2(NK) REAL :: TSTR, TMAX, DT, T, MFT REAL :: PB(NSPEC), PB2(NSPEC), BRM12(NK), BTOVER @@ -1712,7 +1814,9 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDS4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDS4') +#endif ! ! !---------------------------------------------------------------------- @@ -1726,7 +1830,9 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & DK=0.; HS=0.; KBAR=0.; DCK=0.; EFDF=0. BTH0=0.; BTH=0.; BTH0S=0.; DDIAG=0.; SRHS=0.; PB=0. BTHS=0.; MSSSUM(:,:)=0. -!/T0 DOUT=0. +#ifdef W3_T0 + DOUT=0. +#endif QB=0.; S2=0.;PB=0.; PB2=0. BRM12(:)=0. ! @@ -1736,7 +1842,9 @@ SUBROUTINE W3SDS4 (A, K, CG, USTAR, USDIR, DEPTH, DAIR, SRHS, & BREAKFRACTION=0. RENEWALFREQ=0. IK1=1 -!/IG1 IK1=NINT(IGPARS(5))+1 +#ifdef W3_IG1 + IK1=NINT(IGPARS(5))+1 +#endif NTHSUM=MIN(FLOOR(SSDSC(10)+0.5),NTH-1) ! number of angular bins for enhanced modulation IF (NTHSUM.GT.0) THEN WTHSUM(1:NTHSUM)=1 diff --git a/model/ftn/w3src6md.ftn b/model/src/w3src6md.F90 similarity index 94% rename from model/ftn/w3src6md.ftn rename to model/src/w3src6md.F90 index d125a6155..3c316fe8c 100644 --- a/model/ftn/w3src6md.ftn +++ b/model/src/w3src6md.F90 @@ -146,7 +146,9 @@ SUBROUTINE W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) USE W3GDATMD, ONLY: NK, NTH, SIG, DTH, DDEN, FTE, FTF, FTWN, DSII USE W3ODATMD, ONLY: NDST, NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -159,7 +161,9 @@ SUBROUTINE W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IMAX REAL :: EB(NK), EBAND REAL, PARAMETER :: HSMIN = 0.05 @@ -167,7 +171,9 @@ SUBROUTINE W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SPR6') +#ifdef W3_S + CALL STRACE (IENT, 'W3SPR6') +#endif ! ! ! 1. Integrate over directions -------------------------------------- / @@ -300,7 +306,9 @@ SUBROUTINE W3SIN6 (A, CG, WN2, UABS, USTAR, USDIR, CD, DAIR, & USE W3GDATMD, ONLY: ECOS, ESIN, SIN6A0, SIN6WS USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -313,7 +321,9 @@ SUBROUTINE W3SIN6 (A, CG, WN2, UABS, USTAR, USDIR, CD, DAIR, & !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, ITH, IKN(NK) REAL :: COSU, SINU, UPROXY REAL, DIMENSION(NSPEC) :: CG2, ECOS2, ESIN2, DSII2 @@ -323,7 +333,9 @@ SUBROUTINE W3SIN6 (A, CG, WN2, UABS, USTAR, USDIR, CD, DAIR, & REAL, DIMENSION(NSPEC) :: W1, W2, SQRTBN2, CINV2 ! 4,7) REAL, DIMENSION(NK) :: LFACT, CINV ! 5) !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'W3SIN6') +#ifdef W3_S + CALL STRACE (IENT, 'W3SIN6') +#endif ! !/ 0) --- set up a basic variables ----------------------------------- / COSU = COS(USDIR) @@ -517,10 +529,14 @@ SUBROUTINE W3SDS6 (A, CG, WN, S, D) USE W3GDATMD, ONLY: SDS6A1, SDS6A2, SDS6P1, SDS6P2, SDS6ET USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/T6 USE W3TIMEMD, ONLY: STME21 -!/T6 USE W3WDATMD, ONLY: TIME -!/T6 USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T6 + USE W3TIMEMD, ONLY: STME21 + USE W3WDATMD, ONLY: TIME + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -531,7 +547,9 @@ SUBROUTINE W3SDS6 (A, CG, WN, S, D) !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, ITH, IKN(NK) REAL :: FREQ(NK) ! frequencies [Hz] REAL :: DFII(NK) ! frequency bandwiths [Hz] @@ -546,11 +564,15 @@ SUBROUTINE W3SDS6 (A, CG, WN, S, D) REAL :: T2(NK) ! forced dissipation term REAL :: T12(NK) ! = T1+T2 or combined dissipation REAL :: ADF(NK), XFAC, EDENSMAX ! temp. variables -!/T6 CHARACTER(LEN=23) :: IDTIME +#ifdef W3_T6 + CHARACTER(LEN=23) :: IDTIME +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SDS6') +#ifdef W3_S + CALL STRACE (IENT, 'W3SDS6') +#endif ! !/ 0) --- Initialize essential parameters ---------------------------- / IKN = IRANGE(1,NSPEC,NTH) ! Index vector for elements of 1, @@ -606,13 +628,17 @@ SUBROUTINE W3SDS6 (A, CG, WN, S, D) S = D * A ! !/ 5) --- Diagnostic output (switch !/T6) ---------------------------- / -!/T6 CALL STME21 ( TIME , IDTIME ) -!/T6 WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) -!/T6 WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) -!/T6 WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) -! -!/T6 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) -!/T6 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) +#ifdef W3_T6 + CALL STME21 ( TIME , IDTIME ) + WRITE (NDST,270) 'T1*E',IDTIME(1:19),(T1*EDENS) + WRITE (NDST,270) 'T2*E',IDTIME(1:19),(T2*EDENS) + WRITE (NDST,271) SUM(SUM(RESHAPE(S,(/ NTH,NK /)),1)*DDEN/CG) +#endif +! +#ifdef W3_T6 + 270 FORMAT (' TEST W3SDS6 : ',A,'(',A,')',':',70E11.3) + 271 FORMAT (' TEST W3SDS6 : Total SDS =',E13.5) +#endif !/ !/ End of W3SDS6 ----------------------------------------------------- / !/ @@ -705,7 +731,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPERR USE W3TIMEMD, ONLY: STME21 USE W3WDATMD, ONLY: TIME -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE ! !/ ------ I/O parameters --------------------------------------------- / @@ -719,7 +747,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & REAL, INTENT(OUT) :: TAUWX, TAUWY ! normal stress components ! !/ --- local parameters (in order of appearance) ------------------ / -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. INTEGER, PARAMETER:: ITERMAX = 80 ! Maximum number of iterations to ! find numerical solution for LFACT. @@ -737,7 +767,9 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & CHARACTER(LEN=23) :: IDTIME ! !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'LFACTOR') +#ifdef W3_S + CALL STRACE (IENT, 'LFACTOR') +#endif ! !/ 0) --- Find the number of frequencies required to extend arrays !/ up to f=10Hz and allocate arrays --------------------------- / @@ -828,8 +860,10 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & UPROXY = SIN6WS * USTAR UCINV10Hz = 1.0 - (UPROXY * CINV10Hz) ! -!/T6 WRITE (NDST,270) IDTIME, U10 -!/T6 WRITE (NDST,271) +#ifdef W3_T6 + WRITE (NDST,270) IDTIME, U10 + WRITE (NDST,271) +#endif DO IK=1,ITERMAX LF10Hz = MIN(1.0, EXP(UCINV10Hz * RTAU) ) ! @@ -845,8 +879,10 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & ! SIGN_OLD = SIGN_NEW SIGN_NEW = INT(SIGN(1.0, ERR)) -!/T6 WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & -!/T6 TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND +#ifdef W3_T6 + WRITE (NDST,272) IK, RTAU, DRTAU, TAU, TAU_TOT, ERR, & + TAUWX, TAUWY, TAUVX, TAUVY, TAU_NND +#endif ! ! --- Slow down DRTAU when overshot. -------------------------- / IF (SIGN_NEW .NE. SIGN_OLD) OVERSHOT = .TRUE. @@ -863,18 +899,22 @@ SUBROUTINE LFACTOR(S, CINV, U10, USTAR, USDIR, SIG, DSII, & ! LFACT(1:NK) = LF10Hz(1:NK) ! -!/T6 WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI -!/T6 WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI -!/T6 WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) -!/T6 WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) -!/T6 WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) -! -!/T6 270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & -!/T6 A,' U10=',F5.1 ) -!/T6 271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & -!/T6 ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) -!/T6 272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) -!/T6 273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) +#ifdef W3_T6 + WRITE (NDST,273) 'Sin ', IDTIME(1:19), SDENS10Hz*TPI + WRITE (NDST,273) 'SinR', IDTIME(1:19), SDENS10Hz*LF10Hz*TPI + WRITE (NDST,274) 'Sin ', SUM(SDENS10Hz(1:NK)*DSII) + WRITE (NDST,274) 'SinR ', SUM(SDENS10Hz(1:NK)*LF10Hz(1:NK)*DSII) + WRITE (NDST,274) 'SinR/C', TAUWINDS(SDENS10Hz(1:NK)*LFACT,CINV,DSII) +#endif +! +#ifdef W3_T6 + 270 FORMAT (' TEST W3SIN6 : LFACTOR SUBROUTINE CALCULATING FOR ', & + A,' U10=',F5.1 ) + 271 FORMAT (' TEST W3SIN6 : IK RTAU DRTAU TAU TAU_TOT' & + ' ERR TAUW_X TAUW_Y TAUV_X TAUV_Y TAU1D' ) + 272 FORMAT (' TEST W3SIN6 : ',I2,2F9.5,2F8.5,E10.2,4F7.4,F7.3 ) + 273 FORMAT (' TEST W3SIN6 : ',A,'(',A,'):', 70E11.3 ) +#endif 274 FORMAT (' TEST W3SIN6 : Total ',A,' =', E13.5 ) 280 FORMAT (' WARNING LFACTOR (TIME,U10,TAU,TAU_TOT,ERR,TAUW_XY,' & 'TAUV_XY,TAU_SCALAR): ',A,F6.1,2F7.4,E10.3,4F7.4,F7.3 ) @@ -939,7 +979,9 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) !/ USE CONSTANTS, ONLY: GRAV, TPI USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, XFR, ECOS, ESIN -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE ! !/ ------ I/O parameters --------------------------------------------- / @@ -950,7 +992,9 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) REAL, INTENT(OUT) :: TAUNWX, TAUNWY ! stress components (wave->atmos) ! !/ --- local parameters (in order of appearance) ------------------ / -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, PARAMETER :: FRQMAX = 10. ! Upper freq. limit to extrapolate to. INTEGER :: NK10Hz ! @@ -960,7 +1004,9 @@ SUBROUTINE TAU_WAVE_ATMOS(S, CINV, SIG, DSII, TAUNWX, TAUNWY ) REAL, ALLOCATABLE :: DSII10Hz(:), UCINV10Hz(:) ! !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'TAU_WAVE_ATMOS') +#ifdef W3_S + CALL STRACE (IENT, 'TAU_WAVE_ATMOS') +#endif ! !/ 0) --- Find the number of frequencies required to extend arrays !/ up to f=10Hz and allocate arrays --------------------------- / diff --git a/model/ftn/w3srcemd.ftn b/model/src/w3srcemd.F90 similarity index 54% rename from model/ftn/w3srcemd.ftn rename to model/src/w3srcemd.F90 index eb8174ace..48a729811 100644 --- a/model/ftn/w3srcemd.ftn +++ b/model/src/w3srcemd.F90 @@ -53,7 +53,9 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & SPECOLD, SPEC, VSIO, VDIO, SHAVEIO, & ALPHA, WN1, CG1, & D_INP, U10ABS, U10DIR, AS, USTAR, USTDIR, & -!/FLX5 TAUA, TAUADIR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, & +#endif CX, CY, ICE, ICEH, ICEF, ICEDMAX, & REFLEC, REFLED, DELX, DELY, DELA, TRNX, & TRNY, BERG, FPI, DTDYN, FCUT, DTG, TAUWX, & @@ -361,65 +363,149 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ICESCALES, IICESMOOTH USE W3GDATMD, ONLY: FSSOURCE, optionCall USE W3GDATMD, ONLY: B_JGS_NLEVEL, B_JGS_SOURCE_NONLINEAR -!/REF1 USE W3GDATMD, ONLY: IOBP, IOBPD, IOBDP, GTYPE, UNGTYPE, REFPARS +#ifdef W3_REF1 + USE W3GDATMD, ONLY: IOBP, IOBPD, IOBDP, GTYPE, UNGTYPE, REFPARS +#endif USE W3WDATMD, ONLY: TIME USE W3ODATMD, ONLY: NDSE, NDST, IAPROC USE W3IDATMD, ONLY: INFLAGS2, ICEP2 USE W3DISPMD -!/NNT USE W3ODATMD, ONLY: IAPROC, SCREEN, FNMPRE -!/FLD1 USE W3FLD1MD, ONLY: W3FLD1 -!/FLD1 USE W3GDATMD, ONLY: AALPHA -!/FLD2 USE W3FLD2MD, ONLY: W3FLD2 -!/FLD2 USE W3GDATMD, ONLY: AALPHA -!/FLX1 USE W3FLX1MD -!/FLX2 USE W3FLX2MD -!/FLX3 USE W3FLX3MD -!/FLX4 USE W3FLX4MD -!/FLX5 USE W3FLX5MD -!/LN1 USE W3SLN1MD -!/ST0 USE W3SRC0MD -!/ST1 USE W3SRC1MD -!/ST2 USE W3SRC2MD -!/ST2 USE W3GDATMD, ONLY : ZWIND -!/ST3 USE W3SRC3MD -!/ST3 USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM -!/ST4 USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 -!/ST4 USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM, FFXFA -!/ST6 USE W3SRC6MD -!/ST6 USE W3SWLDMD, ONLY : W3SWL6 -!/ST6 USE W3GDATMD, ONLY : SWL6S6 -!/NL1 USE W3SNL1MD -!/NL2 USE W3SNL2MD -!/NL3 USE W3SNL3MD -!/NL4 USE W3SNL4MD -!/NL5 USE W3SNL5MD -!/NL5 USE W3TIMEMD, ONLY: TICK21 -!/NLS USE W3SNLSMD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/IC1 USE W3SIC1MD -!/IC2 USE W3SIC2MD -!/IC3 USE W3SIC3MD -!/IC4 USE W3SIC4MD -!/IC5 USE W3SIC5MD -!/IS1 USE W3SIS1MD -!/IS2 USE W3SIS2MD -!/IS2 USE W3GDATMD, ONLY : IS2PARS -!/DB1 USE W3SDB1MD -!/TR1 USE W3STR1MD -!/BS1 USE W3SBS1MD -!/REF1 USE W3REF1MD -!/IG1 USE W3GDATMD, ONLY : IGPARS -!/S USE W3SERVMD, ONLY: STRACE -!/NNT USE W3SERVMD, ONLY: EXTCDE -!/UOST USE W3UOSTMD, ONLY : UOST_SRCTRMCOMPUTE -!/PDLIB USE PDLIB_W3PROFSMD, ONLY : B_JAC, ASPAR_JAC, ASPAR_DIAG_SOURCES -!/PDLIB USE yowNodepool, ONLY: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P -!/PDLIB USE W3GDATMD, ONLY: CLATS -!/PDLIB USE W3WDATMD, ONLY: VA -!/PDLIB USE W3PARALL, ONLY: ONESIXTH, ZERO, THR, IMEM +#ifdef W3_NNT + USE W3ODATMD, ONLY: IAPROC, SCREEN, FNMPRE +#endif +#ifdef W3_FLD1 + USE W3FLD1MD, ONLY: W3FLD1 + USE W3GDATMD, ONLY: AALPHA +#endif +#ifdef W3_FLD2 + USE W3FLD2MD, ONLY: W3FLD2 + USE W3GDATMD, ONLY: AALPHA +#endif +#ifdef W3_FLX1 + USE W3FLX1MD +#endif +#ifdef W3_FLX2 + USE W3FLX2MD +#endif +#ifdef W3_FLX3 + USE W3FLX3MD +#endif +#ifdef W3_FLX4 + USE W3FLX4MD +#endif +#ifdef W3_FLX5 + USE W3FLX5MD +#endif +#ifdef W3_LN1 + USE W3SLN1MD +#endif +#ifdef W3_ST0 + USE W3SRC0MD +#endif +#ifdef W3_ST1 + USE W3SRC1MD +#endif +#ifdef W3_ST2 + USE W3SRC2MD + USE W3GDATMD, ONLY : ZWIND +#endif +#ifdef W3_ST3 + USE W3SRC3MD + USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM +#endif +#ifdef W3_ST4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 + USE W3GDATMD, ONLY : ZZWND, FFXFM, FFXPM, FFXFA +#endif +#ifdef W3_ST6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 +#endif +#ifdef W3_NL1 + USE W3SNL1MD +#endif +#ifdef W3_NL2 + USE W3SNL2MD +#endif +#ifdef W3_NL3 + USE W3SNL3MD +#endif +#ifdef W3_NL4 + USE W3SNL4MD +#endif +#ifdef W3_NL5 + USE W3SNL5MD + USE W3TIMEMD, ONLY: TICK21 +#endif +#ifdef W3_NLS + USE W3SNLSMD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_IC1 + USE W3SIC1MD +#endif +#ifdef W3_IC2 + USE W3SIC2MD +#endif +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_IC4 + USE W3SIC4MD +#endif +#ifdef W3_IC5 + USE W3SIC5MD +#endif +#ifdef W3_IS1 + USE W3SIS1MD +#endif +#ifdef W3_IS2 + USE W3SIS2MD + USE W3GDATMD, ONLY : IS2PARS +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_TR1 + USE W3STR1MD +#endif +#ifdef W3_BS1 + USE W3SBS1MD +#endif +#ifdef W3_REF1 + USE W3REF1MD +#endif +#ifdef W3_IG1 + USE W3GDATMD, ONLY : IGPARS +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_NNT + USE W3SERVMD, ONLY: EXTCDE +#endif +#ifdef W3_UOST + USE W3UOSTMD, ONLY : UOST_SRCTRMCOMPUTE +#endif +#ifdef W3_PDLIB + USE PDLIB_W3PROFSMD, ONLY : B_JAC, ASPAR_JAC, ASPAR_DIAG_SOURCES + USE yowNodepool, ONLY: PDLIB_CCON, NPA, PDLIB_I_DIAG, PDLIB_JA, PDLIB_IA_P + USE W3GDATMD, ONLY: CLATS + USE W3WDATMD, ONLY: VA + USE W3PARALL, ONLY: ONESIXTH, ZERO, THR, IMEM +#endif !/ IMPLICIT NONE !/ @@ -433,7 +519,9 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & REAL, INTENT(IN) :: D_INP, U10ABS, & U10DIR, AS, CX, CY, DTG, D50,PSIC, & ICE, ICEH -!/FLX5 REAL, INTENT(IN) :: TAUA, TAUADIR +#ifdef W3_FLX5 + REAL, INTENT(IN) :: TAUA, TAUADIR +#endif INTEGER, INTENT(IN) :: REFLED(6) REAL, INTENT(IN) :: REFLEC(4), DELX, DELY, DELA, & TRNX, TRNY, BERG, ICEDMAX, DAIR @@ -453,12 +541,18 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & !/ INTEGER :: IK, ITH, IS, IS0, NSTEPS, NKH, NKH1,& IKS1, IS1, NSPECH, IDT, IERR, NKI, NKD -!/S INTEGER, SAVE :: IENT = 0 -!/NNT INTEGER, SAVE :: NDSD = 89, NDSD2 = 88, J -!/NL5 INTEGER :: QI5TSTART(2) -!/NL5 REAL :: QR5KURT -!/NL5 INTEGER, PARAMETER :: NL5_SELECT = 1 -!/NL5 REAL, PARAMETER :: NL5_OFFSET = 0. ! explicit dyn. +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_NNT + INTEGER, SAVE :: NDSD = 89, NDSD2 = 88, J +#endif +#ifdef W3_NL5 + INTEGER :: QI5TSTART(2) + REAL :: QR5KURT + INTEGER, PARAMETER :: NL5_SELECT = 1 + REAL, PARAMETER :: NL5_OFFSET = 0. ! explicit dyn. +#endif REAL :: DTTOT, FHIGH, DT, AFILT, DAMAX, AFAC,& HDT, ZWND, FP, DEPTH, TAUSCX, TAUSCY, FHIGI ! Scaling factor for SIN, SDS, SNL @@ -468,15 +562,31 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & REAL :: WN_R(NK), CG_ICE(NK),ALPHA_LIU(NK), ICECOEF2,& R(NK) DOUBLE PRECISION :: ATT, ISO -!/ST1 REAL :: FH1, FH2 -!/ST2 REAL :: FHTRAN, DFH, FACDIA, FACPAR -!/ST3 REAL :: FMEANS, FH1, FH2 -!/ST4 REAL :: FMEANS, FH1, FH2, FAGE, DLWMEAN +#ifdef W3_ST1 + REAL :: FH1, FH2 +#endif +#ifdef W3_ST2 + REAL :: FHTRAN, DFH, FACDIA, FACPAR +#endif +#ifdef W3_ST3 + REAL :: FMEANS, FH1, FH2 +#endif +#ifdef W3_ST4 + REAL :: FMEANS, FH1, FH2, FAGE, DLWMEAN +#endif REAL :: QCERR = 0. !/XNL2 and !/NNT -!/SEED REAL :: UC, SLEV -!/MLIM REAL :: HM, EM -!/NNT REAL :: FACNN -!/T REAL :: DTRAW +#ifdef W3_SEED + REAL :: UC, SLEV +#endif +#ifdef W3_MLIM + REAL :: HM, EM +#endif +#ifdef W3_NNT + REAL :: FACNN +#endif +#ifdef W3_T + REAL :: DTRAW +#endif REAL :: EBAND, DIFF, EFINISH, HSTOT, PHINL, & FMEAN1, FMEANWS, MWXINIT, MWYINIT, & FACTOR, FACTOR2, DRAT, TAUWAX, TAUWAY, & @@ -488,47 +598,93 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & VSIN(NSPEC), VDIN(NSPEC), & VSNL(NSPEC), VDNL(NSPEC), & VSDS(NSPEC), VDDS(NSPEC), & -!/ST6 VSWL(NSPEC), VDWL(NSPEC), & +#ifdef W3_ST6 + VSWL(NSPEC), VDWL(NSPEC), & +#endif VSBT(NSPEC), VDBT(NSPEC), & -!/IC1 VSIC(NSPEC), VDIC(NSPEC), & -!/IC2 VSIC(NSPEC), VDIC(NSPEC), & -!/IC3 VSIC(NSPEC), VDIC(NSPEC), & -!/IC4 VSIC(NSPEC), VDIC(NSPEC), & -!/IC5 VSIC(NSPEC), VDIC(NSPEC), & -!/DB1 VSDB(NSPEC), VDDB(NSPEC), & -!/TR1 VSTR(NSPEC), VDTR(NSPEC), & -!/BS1 VSBS(NSPEC), VDBS(NSPEC), & -!/REF1 VREF(NSPEC), & -!/IS1 VSIR(NSPEC), VDIR(NSPEC), & -!/IS2 VSIR(NSPEC), VDIR(NSPEC),VDIR2(NSPEC), & -!/UOST VSUO(NSPEC), VDUO(NSPEC), & +#ifdef W3_IC1 + VSIC(NSPEC), VDIC(NSPEC), & +#endif +#ifdef W3_IC2 + VSIC(NSPEC), VDIC(NSPEC), & +#endif +#ifdef W3_IC3 + VSIC(NSPEC), VDIC(NSPEC), & +#endif +#ifdef W3_IC4 + VSIC(NSPEC), VDIC(NSPEC), & +#endif +#ifdef W3_IC5 + VSIC(NSPEC), VDIC(NSPEC), & +#endif +#ifdef W3_DB1 + VSDB(NSPEC), VDDB(NSPEC), & +#endif +#ifdef W3_TR1 + VSTR(NSPEC), VDTR(NSPEC), & +#endif +#ifdef W3_BS1 + VSBS(NSPEC), VDBS(NSPEC), & +#endif +#ifdef W3_REF1 + VREF(NSPEC), & +#endif +#ifdef W3_IS1 + VSIR(NSPEC), VDIR(NSPEC), & +#endif +#ifdef W3_IS2 + VSIR(NSPEC), VDIR(NSPEC),VDIR2(NSPEC), & +#endif +#ifdef W3_UOST + VSUO(NSPEC), VDUO(NSPEC), & +#endif VS (NSPEC), VD (NSPEC), EB(NK) -!/ST3 LOGICAL :: LLWS(NSPEC) -!/ST4 LOGICAL :: LLWS(NSPEC) -!/ST4 REAL :: BRLAMBDA(NSPEC) -!/IS2 DOUBLE PRECISION :: SCATSPEC(NTH) +#ifdef W3_ST3 + LOGICAL :: LLWS(NSPEC) +#endif +#ifdef W3_ST4 + LOGICAL :: LLWS(NSPEC) + REAL :: BRLAMBDA(NSPEC) +#endif +#ifdef W3_IS2 + DOUBLE PRECISION :: SCATSPEC(NTH) +#endif REAL :: FOUT(NK,NTH), SOUT(NK,NTH), DOUT(NK,NTH) REAL, SAVE :: TAUNUX, TAUNUY -!/OMPG/!$omp threadprivate( TAUNUX, TAUNUY) +#ifdef W3_OMPG +!$omp threadprivate( TAUNUX, TAUNUY) +#endif LOGICAL, SAVE :: FLTEST = .FALSE., FLAGNN = .TRUE. -!/OMPG/!$omp threadprivate( FLTEST, FLAGNN ) +#ifdef W3_OMPG +!$omp threadprivate( FLTEST, FLAGNN ) +#endif LOGICAL :: SHAVE LOGICAL :: LBREAK LOGICAL, SAVE :: FIRST = .TRUE. -!/OMPG/!$omp threadprivate( FIRST ) +#ifdef W3_OMPG +!$omp threadprivate( FIRST ) +#endif LOGICAL :: PrintDeltaSmDA REAL :: eInc1, eInc2 REAL :: DeltaSRC(NSPEC), MAXDAC(NSPEC) -!/PDLIB REAL :: PreVS, eVS, eVD, FAK, DVS, SIDT -!/PDLIB INTEGER :: ISP, IP, ISEA +#ifdef W3_PDLIB + REAL :: PreVS, eVS, eVD, FAK, DVS, SIDT + INTEGER :: ISP, IP, ISEA +#endif -!/NNT CHARACTER(LEN=17), SAVE :: FNAME = 'test_data_nnn.ww3' +#ifdef W3_NNT + CHARACTER(LEN=17), SAVE :: FNAME = 'test_data_nnn.ww3' +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SRCE') +#ifdef W3_S + CALL STRACE (IENT, 'W3SRCE') +#endif ! -!/T FLTEST = .TRUE. +#ifdef W3_T + FLTEST = .TRUE. +#endif ! DEPTH = MAX ( DMIN , D_INP ) IKS1 = 1 @@ -536,60 +692,108 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ICESCALEIN = MAX(0.,MIN(1.,1.-ICE*ICESCALES(2))) ICESCALENL = MAX(0.,MIN(1.,1.-ICE*ICESCALES(3))) ICESCALEDS = MAX(0.,MIN(1.,1.-ICE*ICESCALES(4))) -!/IG1! -!/IG1! Does not integrate source terms for IG band if IGPARS(12) = 0. -!/IG1! -!/IG1 IF (NINT(IGPARS(12)).EQ.0) IKS1 = NINT(IGPARS(5)) +#ifdef W3_IG1 +! +! Does not integrate source terms for IG band if IGPARS(12) = 0. +! + IF (NINT(IGPARS(12)).EQ.0) IKS1 = NINT(IGPARS(5)) +#endif IS1=(IKS1-1)*NTH+1 ! -!/LN0 VSLN = 0. -!/SEED VSLN = 0. -!/ST0 VSIN = 0. -!/ST0 VDIN = 0. -!/ST3 VSIN = 0. -!/ST3 VDIN = 0. -!/ST4 VSIN = 0. -!/ST4 VDIN = 0. +#ifdef W3_LN0 + VSLN = 0. +#endif +#ifdef W3_SEED + VSLN = 0. +#endif +#ifdef W3_ST0 + VSIN = 0. + VDIN = 0. +#endif +#ifdef W3_ST3 + VSIN = 0. + VDIN = 0. +#endif +#ifdef W3_ST4 + VSIN = 0. + VDIN = 0. +#endif -!/NL0 VSNL = 0. -!/NL0 VDNL = 0. -!/ST0 VSDS = 0. -!/ST0 VDDS = 0. +#ifdef W3_NL0 + VSNL = 0. + VDNL = 0. +#endif +#ifdef W3_ST0 + VSDS = 0. + VDDS = 0. +#endif VSBT = 0. VDBT = 0. -!/DB1 VSDB = 0. -!/DB1 VDDB = 0. -!/IC1 VSIC = 0. -!/IC1 VDIC = 0. -!/IC2 VSIC = 0. -!/IC2 VDIC = 0. -!/IC3 VSIC = 0. -!/IC3 VDIC = 0. -!/IC4 VSIC = 0. -!/IC4 VDIC = 0. -!/UOST VSUO = 0. -!/UOST VDUO = 0. -!/IC5 VSIC = 0. -!/IC5 VDIC = 0. -! -!/IS1 VSIR = 0. -!/IS1 VDIR = 0. -!/IS2 VSIR = 0. -!/IS2 VDIR = 0. -!/IS2 VDIR2= 0. -! -!/ST6 VSWL = 0. -!/ST6 VDWL = 0. -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST4 ZWND = ZZWND -!/ST6 ZWND = 10. +#ifdef W3_DB1 + VSDB = 0. + VDDB = 0. +#endif +#ifdef W3_IC1 + VSIC = 0. + VDIC = 0. +#endif +#ifdef W3_IC2 + VSIC = 0. + VDIC = 0. +#endif +#ifdef W3_IC3 + VSIC = 0. + VDIC = 0. +#endif +#ifdef W3_IC4 + VSIC = 0. + VDIC = 0. +#endif +#ifdef W3_UOST + VSUO = 0. + VDUO = 0. +#endif +#ifdef W3_IC5 + VSIC = 0. + VDIC = 0. +#endif +! +#ifdef W3_IS1 + VSIR = 0. + VDIR = 0. +#endif +#ifdef W3_IS2 + VSIR = 0. + VDIR = 0. + VDIR2= 0. +#endif +! +#ifdef W3_ST6 + VSWL = 0. + VDWL = 0. +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST4 + ZWND = ZZWND +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif ! DRAT = DAIR / DWAT -!/T WRITE (NDST,9000) -!/T WRITE (NDST,9001) DEPTH, U10ABS, U10DIR*RADE +#ifdef W3_T + WRITE (NDST,9000) + WRITE (NDST,9001) DEPTH, U10ABS, U10DIR*RADE +#endif ! ! 1. Preparations --------------------------------------------------- * ! @@ -639,94 +843,128 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! ! TIME is updated in W3WAVEMD prior to the call of W3SCRE, we should ! move 'TIME' one time step backward (QL) -!/NL5 QI5TSTART = TIME -!/NL5 CALL TICK21 (QI5TSTART, -1.0 * DTG) -! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start sum(SPEC)=', sum(SPEC) -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECOLD)=', sum(SPECOLD) -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECINIT)=', sum(SPECINIT) -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start sum(VSIO)=', sum(VSIO) -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start sum(VDIO)=', sum(VDIO) -!/DEBUGSRC WRITE(740+IAPROC,*) 'W3SRCE start USTAR=', USTAR -!/DEBUGSRC END IF +#ifdef W3_NL5 + QI5TSTART = TIME + CALL TICK21 (QI5TSTART, -1.0 * DTG) +#endif +! +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECOLD)=', sum(SPECOLD) + WRITE(740+IAPROC,*) 'W3SRCE start sum(SPECINIT)=', sum(SPECINIT) + WRITE(740+IAPROC,*) 'W3SRCE start sum(VSIO)=', sum(VSIO) + WRITE(740+IAPROC,*) 'W3SRCE start sum(VDIO)=', sum(VDIO) + WRITE(740+IAPROC,*) 'W3SRCE start USTAR=', USTAR + END IF +#endif -!/ST4 DLWMEAN= 0. -!/ST4 BRLAMBDA(:)=0. -!/ST4 WHITECAP(:)=0. +#ifdef W3_ST4 + DLWMEAN= 0. + BRLAMBDA(:)=0. + WHITECAP(:)=0. +#endif ! ! 1.c Set mean parameters ! -!/ST0 CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST0 FP = 0.85 * FMEAN -!/ST1 CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST2 CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 TAUWX=0. -!/ST3 TAUWY=0. -!/ST3 IF ( IT .eq. 0 ) THEN -!/ST3 LLWS(:) = .TRUE. -!/ST3 USTAR=0. -!/ST3 USTDIR=0. -!/ST3 CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & -!/ST3 AMAX, U10ABS, U10DIR, USTAR, USTDIR, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST3 ELSE -!/ST3 CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & -!/ST3 AMAX, U10ABS, U10DIR, USTAR, USTDIR, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST3 CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST3 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST3 ICE, VSIN, VDIN, LLWS, IX, IY ) -!/ST3 END IF -!/ST3 CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & -!/ST3 AMAX, U10ABS, U10DIR, USTAR, USTDIR, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST3 TWS = 1./FMEANWS -!/ST4 TAUWX=0. -!/ST4 TAUWY=0. -!/ST4 IF ( IT .eq. 0 ) THEN -!/ST4 LLWS(:) = .TRUE. -!/ST4 USTAR=0. -!/ST4 USTDIR=0. -!/ST4 ELSE -!/ST4 CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & -!/ST4 AMAX, U10ABS, U10DIR, & -!/ST4!/FLX5 TAUA, TAUADIR, DAIR, & -!/ST4 USTAR, USTDIR, & -!/ST4 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) +#ifdef W3_ST0 + CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN +#endif +#ifdef W3_ST1 + CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN +#endif +#ifdef W3_ST2 + CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + TAUWX=0. + TAUWY=0. + IF ( IT .eq. 0 ) THEN + LLWS(:) = .TRUE. + USTAR=0. + USTDIR=0. + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + ELSE + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) + END IF + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, WNMEAN, & + AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) + TWS = 1./FMEANWS +#endif +#ifdef W3_ST4 + TAUWX=0. + TAUWY=0. + IF ( IT .eq. 0 ) THEN + LLWS(:) = .TRUE. + USTAR=0. + USTDIR=0. + ELSE + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & + AMAX, U10ABS, U10DIR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, DAIR, & +#endif + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) +#endif -!/DEBUGSRC!/ST4 IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: out value USTAR=', USTAR, ' USTDIR=', USTDIR -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: out value EMEAN=', EMEAN, ' FMEAN=', FMEAN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: out value FMEAN1=', FMEAN1, ' WNMEAN=', WNMEAN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: out value CD=', CD, ' Z0=', Z0 -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: out value ALPHA=', CHARN, ' FMEANWS=', FMEANWS -!/DEBUGSRC!/ST4 END IF +#ifdef W3_DEBUGSRC +#ifdef W3_ST4 + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: out value USTAR=', USTAR, ' USTDIR=', USTDIR + WRITE(740+IAPROC,*) '1: out value EMEAN=', EMEAN, ' FMEAN=', FMEAN + WRITE(740+IAPROC,*) '1: out value FMEAN1=', FMEAN1, ' WNMEAN=', WNMEAN + WRITE(740+IAPROC,*) '1: out value CD=', CD, ' Z0=', Z0 + WRITE(740+IAPROC,*) '1: out value ALPHA=', CHARN, ' FMEANWS=', FMEANWS + END IF +#endif +#endif -!/ST4 CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST4 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST4 VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) -!/ST4 END IF -!/DEBUGSRC!/ST4 IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: U10DIR=', U10DIR, ' Z0=', Z0, ' CHARN=', CHARN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: USTAR=', USTAR, ' U10ABS=', U10ABS, ' AS=', AS -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: DRAT=', DRAT -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: TAUWX=', TAUWX, ' TAUWY=', TAUWY -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: TAUWAX=', TAUWAX, ' TAUWAY=', TAUWAY -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: min(CG1)=', minval(CG1), ' max(CG1)=', maxval(CG1) -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) -!/DEBUGSRC!/ST4 END IF +#ifdef W3_ST4 + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) + END IF +#endif +#ifdef W3_DEBUGSRC +#ifdef W3_ST4 + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: U10DIR=', U10DIR, ' Z0=', Z0, ' CHARN=', CHARN + WRITE(740+IAPROC,*) '1: USTAR=', USTAR, ' U10ABS=', U10ABS, ' AS=', AS + WRITE(740+IAPROC,*) '1: DRAT=', DRAT + WRITE(740+IAPROC,*) '1: TAUWX=', TAUWX, ' TAUWY=', TAUWY + WRITE(740+IAPROC,*) '1: TAUWAX=', TAUWAX, ' TAUWAY=', TAUWAY + WRITE(740+IAPROC,*) '1: min(CG1)=', minval(CG1), ' max(CG1)=', maxval(CG1) + WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) '1: W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) + END IF +#endif +#endif -!/ST4 CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & -!/ST4 AMAX, U10ABS, U10DIR, & -!/ST4!/FLX5 TAUA, TAUADIR, DAIR, & -!/ST4 USTAR, USTDIR, & -!/ST4 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) -!/ST4 TWS = 1./FMEANWS -!/ST6 CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#ifdef W3_ST4 + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN, & + AMAX, U10ABS, U10DIR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, DAIR, & +#endif + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) + TWS = 1./FMEANWS +#endif +#ifdef W3_ST6 + CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif ! ! 1.c2 Stores the initial data ! @@ -734,47 +972,73 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! ! 1.d Stresses ! -!/FLX1 CALL W3FLX1 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & -!/FLX2 USTAR, USTDIR, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & -!/FLX3 USTAR, USTDIR, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, U10ABS, U10DIR, TAUA, TAUADIR, DAIR, & -!/FLX5 USTAR, USTDIR, Z0, CD ) +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, U10ABS, U10DIR, USTAR, USTDIR, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, U10ABS, U10DIR, TAUA, TAUADIR, DAIR, & + USTAR, USTDIR, Z0, CD ) +#endif ! ! 1.e Prepare cut-off beyond which the tail is imposed with a power law ! -!/ST0 FHIGH = SIG(NK) -!/ST1 FH1 = FXFM * FMEAN -!/ST1 FH2 = FXPM / USTAR -!/ST1 FHIGH = MAX ( FH1 , FH2 ) -!/ST1 IF (FLTEST) WRITE (NDST,9004) FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV -!/ST2 FHIGH = XFC * FPI -!/ST3 FHIGH = MAX(FFXFM * MAX(FMEAN,FMEANWS),FFXPM / USTAR) -!/ST4! Introduces a Long & Resio (JGR2007) type dependance on wave age +#ifdef W3_ST0 + FHIGH = SIG(NK) +#endif +#ifdef W3_ST1 + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) + IF (FLTEST) WRITE (NDST,9004) FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV +#endif +#ifdef W3_ST2 + FHIGH = XFC * FPI +#endif +#ifdef W3_ST3 + FHIGH = MAX(FFXFM * MAX(FMEAN,FMEANWS),FFXPM / USTAR) +#endif +#ifdef W3_ST4 +! Introduces a Long & Resio (JGR2007) type dependance on wave age +#endif ! !/ST4 FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) -!/ST4 FAGE = 0. -!/ST4 FHIGH = MAX( (FFXFM + FAGE ) * MAX(FMEAN1,FMEANWS), FFXPM / USTAR) -!/ST4 FHIGI = FFXFA * FMEAN1 -!/ST6 IF (FXFM .LE. 0) THEN -!/ST6 FHIGH = SIG(NK) -!/ST6 ELSE -!/ST6 FHIGH = MAX (FXFM * FMEAN, FXPM / USTAR) -!/ST6 ENDIF +#ifdef W3_ST4 + FAGE = 0. + FHIGH = MAX( (FFXFM + FAGE ) * MAX(FMEAN1,FMEANWS), FFXPM / USTAR) + FHIGI = FFXFA * FMEAN1 +#endif +#ifdef W3_ST6 + IF (FXFM .LE. 0) THEN + FHIGH = SIG(NK) + ELSE + FHIGH = MAX (FXFM * FMEAN, FXPM / USTAR) + ENDIF +#endif ! ! 1.f Prepare output file for !/NNT option ! -!/NNT IF ( IT .EQ. 0 ) THEN -!/NNT J = LEN_TRIM(FNMPRE) -!/NNT WRITE (FNAME(11:13),'(I3.3)') IAPROC -!/NNT OPEN (NDSD,FILE=FNMPRE(:J)//FNAME,FORM='UNFORMATTED', & -!/NNT ERR=800,IOSTAT=IERR) -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) NK, NTH -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) SIG(1:NK) * TPIINV -!/NNT OPEN (NDSD2,FILE=FNMPRE(:J)//'time.ww3', & -!/NNT FORM='FORMATTED',ERR=800,IOSTAT=IERR) -!/NNT END IF +#ifdef W3_NNT + IF ( IT .EQ. 0 ) THEN + J = LEN_TRIM(FNMPRE) + WRITE (FNAME(11:13),'(I3.3)') IAPROC + OPEN (NDSD,FILE=FNMPRE(:J)//FNAME,FORM='UNFORMATTED', & + ERR=800,IOSTAT=IERR) + WRITE (NDSD,ERR=801,IOSTAT=IERR) NK, NTH + WRITE (NDSD,ERR=801,IOSTAT=IERR) SIG(1:NK) * TPIINV + OPEN (NDSD2,FILE=FNMPRE(:J)//'time.ww3', & + FORM='FORMATTED',ERR=800,IOSTAT=IERR) + END IF +#endif ! ! ... Branch point dynamic integration - - - - - - - - - - - - - - - - ! @@ -782,125 +1046,205 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! NSTEPS = NSTEPS + 1 ! -!/T WRITE (NDST,9020) NSTEPS, DTTOT +#ifdef W3_T + WRITE (NDST,9020) NSTEPS, DTTOT +#endif ! ! 2. Calculate source terms ----------------------------------------- * ! ! 2.a Input. ! -!/LN1 CALL W3SLN1 ( WN1, FHIGH, USTAR, U10DIR , VSLN ) -! -!/ST1 CALL W3SIN1 ( SPEC, WN2, USTAR, U10DIR , VSIN, VDIN ) -!/ST2 CALL W3SIN2 ( SPEC, CG1, WN2, U10ABS, U10DIR, CD, Z0, & -!/ST2 FPI, VSIN, VDIN ) -!/ST3 CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST3 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST3 ICE, VSIN, VDIN, LLWS, IX, IY ) -!/ST4 CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST4 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST4 VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) +#ifdef W3_LN1 + CALL W3SLN1 ( WN1, FHIGH, USTAR, U10DIR , VSLN ) +#endif +! +#ifdef W3_ST1 + CALL W3SIN1 ( SPEC, WN2, USTAR, U10DIR , VSIN, VDIN ) +#endif +#ifdef W3_ST2 + CALL W3SIN2 ( SPEC, CG1, WN2, U10ABS, U10DIR, CD, Z0, & + FPI, VSIN, VDIN ) +#endif +#ifdef W3_ST3 + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) +#endif -!/DEBUGSRC!/ST4 IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) -!/DEBUGSRC!/ST4 END IF +#ifdef W3_DEBUGSRC +#ifdef W3_ST4 + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VSIN=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) '2 : W3SIN4(min/max/sum)VDIN=', minval(VDIN), maxval(VDIN), sum(VDIN) + END IF +#endif +#endif -!/ST6 CALL W3SIN6 ( SPEC, CG1, WN2, U10ABS, USTAR, USTDIR, CD, DAIR, & -!/ST6 TAUWX, TAUWY, TAUWAX, TAUWAY, VSIN, VDIN ) +#ifdef W3_ST6 + CALL W3SIN6 ( SPEC, CG1, WN2, U10ABS, USTAR, USTDIR, CD, DAIR, & + TAUWX, TAUWY, TAUWAX, TAUWAY, VSIN, VDIN ) +#endif ! ! 2.b Nonlinear interactions. ! -!/NL1 CALL W3SNL1 ( SPEC, CG1, WNMEAN*DEPTH, VSNL, VDNL ) -!/NL2 CALL W3SNL2 ( SPEC, CG1, DEPTH, VSNL, VDNL ) -!/NL3 CALL W3SNL3 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) -!/NL4 CALL W3SNL4 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) -!/NL5 CALL W3SNL5 ( SPEC, CG1, WN1, FMEAN, QI5TSTART, & -!/NL5 U10ABS, U10DIR, JSEA, VSNL, VDNL, QR5KURT) -! -!/PDLIB IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN -!/TR1 CALL W3STR1 ( SPEC, CG1, WN1, DEPTH, IX, VSTR, VDTR ) -!/PDLIB ENDIF +#ifdef W3_NL1 + CALL W3SNL1 ( SPEC, CG1, WNMEAN*DEPTH, VSNL, VDNL ) +#endif +#ifdef W3_NL2 + CALL W3SNL2 ( SPEC, CG1, DEPTH, VSNL, VDNL ) +#endif +#ifdef W3_NL3 + CALL W3SNL3 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) +#endif +#ifdef W3_NL4 + CALL W3SNL4 ( SPEC, CG1, WN1, DEPTH, VSNL, VDNL ) +#endif +#ifdef W3_NL5 + CALL W3SNL5 ( SPEC, CG1, WN1, FMEAN, QI5TSTART, & + U10ABS, U10DIR, JSEA, VSNL, VDNL, QR5KURT) +#endif +! +#ifdef W3_PDLIB + IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN +#endif +#ifdef W3_TR1 + CALL W3STR1 ( SPEC, CG1, WN1, DEPTH, IX, VSTR, VDTR ) +#endif +#ifdef W3_PDLIB + ENDIF +#endif ! ! 2.c Dissipation... except for ST4 ! 2.c1 as in source term package ! -!/ST1 CALL W3SDS1 ( SPEC, WN2, EMEAN, FMEAN, WNMEAN, VSDS, VDDS ) -!/ST2 CALL W3SDS2 ( SPEC, CG1, WN1, FPI, USTAR, ALPHA,VSDS, VDDS ) -!/ST3 CALL W3SDS3 ( SPEC, WN1, CG1, EMEAN, FMEANS, WNMEAN, & -!/ST3 USTAR, USTDIR, DEPTH, VSDS, VDDS, IX, IY ) -!/ST4 CALL W3SDS4 ( SPEC, WN1, CG1, USTAR, USTDIR, DEPTH, DAIR, VSDS, & -!/ST4 VDDS, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) +#ifdef W3_ST1 + CALL W3SDS1 ( SPEC, WN2, EMEAN, FMEAN, WNMEAN, VSDS, VDDS ) +#endif +#ifdef W3_ST2 + CALL W3SDS2 ( SPEC, CG1, WN1, FPI, USTAR, ALPHA,VSDS, VDDS ) +#endif +#ifdef W3_ST3 + CALL W3SDS3 ( SPEC, WN1, CG1, EMEAN, FMEANS, WNMEAN, & + USTAR, USTDIR, DEPTH, VSDS, VDDS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SDS4 ( SPEC, WN1, CG1, USTAR, USTDIR, DEPTH, DAIR, VSDS, & + VDDS, IX, IY, BRLAMBDA, WHITECAP, DLWMEAN ) +#endif -!/DEBUGSRC!/ST4 IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VSDS=', minval(VSDS), maxval(VSDS), sum(VSDS) -!/DEBUGSRC!/ST4 WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VDDS=', minval(VDDS), maxval(VDDS), sum(VDDS) -!/DEBUGSRC!/ST4 END IF +#ifdef W3_DEBUGSRC +#ifdef W3_ST4 + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VSDS=', minval(VSDS), maxval(VSDS), sum(VSDS) + WRITE(740+IAPROC,*) '2 : W3SDS4(min/max/sum)VDDS=', minval(VDDS), maxval(VDDS), sum(VDDS) + END IF +#endif +#endif -!/ST6 CALL W3SDS6 ( SPEC, CG1, WN1, VSDS, VDDS ) -! -!/PDLIB IF (.NOT. FSSOURCE) THEN -!/PDLIB IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN -!/DB1 CALL W3SDB1 ( IX, SPEC, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, & -!/DB1 LBREAK, VSDB, VDDB ) -!/PDLIB ENDIF -!/PDLIB ENDIF +#ifdef W3_ST6 + CALL W3SDS6 ( SPEC, CG1, WN1, VSDS, VDDS ) +#endif +! +#ifdef W3_PDLIB + IF (.NOT. FSSOURCE) THEN + IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN +#endif +#ifdef W3_DB1 + CALL W3SDB1 ( IX, SPEC, DEPTH, EMEAN, FMEAN, WNMEAN, CG1, & + LBREAK, VSDB, VDDB ) +#endif +#ifdef W3_PDLIB + ENDIF + ENDIF +#endif ! ! 2.c2 optional dissipation parameterisations ! -!/ST6 IF (SWL6S6) THEN -!/ST6 CALL W3SWL6 ( SPEC, CG1, WN1, VSWL, VDWL ) -!/ST6 END IF +#ifdef W3_ST6 + IF (SWL6S6) THEN + CALL W3SWL6 ( SPEC, CG1, WN1, VSWL, VDWL ) + END IF +#endif ! ! 2.d Bottom interactions. ! -!/PDLIB IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN -!/BT1 CALL W3SBT1 ( SPEC, CG1, WN1, DEPTH, VSBT, VDBT ) -!/BT4 CALL W3SBT4 ( SPEC, CG1, WN1, DEPTH, D50, PSIC, TAUBBL, & -!/BT4 BEDFORM, VSBT, VDBT, IX, IY ) -!/BT8 CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) -!/BT9 CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) -! -!/BS1 CALL W3SBS1 ( SPEC, CG1, WN1, DEPTH, CX, CY, & -!/BS1 TAUSCX, TAUSCY, VSBS, VDBS ) -!/PDLIB ENDIF +#ifdef W3_PDLIB + IF (.NOT. B_JGS_SOURCE_NONLINEAR) THEN +#endif +#ifdef W3_BT1 + CALL W3SBT1 ( SPEC, CG1, WN1, DEPTH, VSBT, VDBT ) +#endif +#ifdef W3_BT4 + CALL W3SBT4 ( SPEC, CG1, WN1, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, VSBT, VDBT, IX, IY ) +#endif +#ifdef W3_BT8 + CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) +#endif +#ifdef W3_BT9 + CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) +#endif +! +#ifdef W3_BS1 + CALL W3SBS1 ( SPEC, CG1, WN1, DEPTH, CX, CY, & + TAUSCX, TAUSCY, VSBS, VDBS ) +#endif +#ifdef W3_PDLIB + ENDIF +#endif ! ! 2.e Unresolved Obstacles Source Term ! -!/UOST ! UNRESOLVED OBSTACLES -!/UOST CALL UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG1, DT, & -!/UOST U10ABS, U10DIR, VSUO, VDUO) +#ifdef W3_UOST + ! UNRESOLVED OBSTACLES + CALL UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG1, DT, & + U10ABS, U10DIR, VSUO, VDUO) +#endif ! ! 2.g Dump training data if necessary ! -!/NNT WRITE (SCREEN,8888) TIME, DTTOT, FLAGNN, QCERR -!/NNT WRITE (NDSD2,8888) TIME, DTTOT, FLAGNN, QCERR -!/NNT 8888 FORMAT (1X,I8.8,1X,I6.6,F8.1,L2,F8.2) -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) IX, IY, TIME, NSTEPS, & -!/NNT DTTOT, FLAGNN, DEPTH, U10ABS, U10DIR -! -!/NNT IF ( FLAGNN ) THEN -!/NNT DO IK=1, NK -!/NNT FACNN = TPI * SIG(IK) / CG1(IK) -!/NNT DO ITH=1, NTH -!/NNT IS = ITH + (IK-1)*NTH -!/NNT FOUT(IK,ITH) = SPEC(IS) * FACNN -!/NNT SOUT(IK,ITH) = VSNL(IS) * FACNN -!/NNT DOUT(IK,ITH) = VDNL(IS) -!/NNT END DO -!/NNT END DO -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) FOUT -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) SOUT -!/NNT WRITE (NDSD,ERR=801,IOSTAT=IERR) DOUT -!/NNT END IF +#ifdef W3_NNT + WRITE (SCREEN,8888) TIME, DTTOT, FLAGNN, QCERR + WRITE (NDSD2,8888) TIME, DTTOT, FLAGNN, QCERR + 8888 FORMAT (1X,I8.8,1X,I6.6,F8.1,L2,F8.2) + WRITE (NDSD,ERR=801,IOSTAT=IERR) IX, IY, TIME, NSTEPS, & + DTTOT, FLAGNN, DEPTH, U10ABS, U10DIR +#endif +! +#ifdef W3_NNT + IF ( FLAGNN ) THEN + DO IK=1, NK + FACNN = TPI * SIG(IK) / CG1(IK) + DO ITH=1, NTH + IS = ITH + (IK-1)*NTH + FOUT(IK,ITH) = SPEC(IS) * FACNN + SOUT(IK,ITH) = VSNL(IS) * FACNN + DOUT(IK,ITH) = VDNL(IS) + END DO + END DO + WRITE (NDSD,ERR=801,IOSTAT=IERR) FOUT + WRITE (NDSD,ERR=801,IOSTAT=IERR) SOUT + WRITE (NDSD,ERR=801,IOSTAT=IERR) DOUT + END IF +#endif ! ! 3. Set frequency cut-off ------------------------------------------ * ! -!/ST2 FHIGH = XFC * FPI -!/ST2 IF ( FLTEST ) WRITE (NDST,9005) FHIGH*TPIINV +#ifdef W3_ST2 + FHIGH = XFC * FPI + IF ( FLTEST ) WRITE (NDST,9005) FHIGH*TPIINV +#endif NKH = MIN ( NK , INT(FACTI2+FACTI1*LOG(MAX(1.E-7,FHIGH))) ) NKH1 = MIN ( NK , NKH+1 ) NSPECH = NKH1*NTH -!/T WRITE (NDST,9021) NKH, NKH1, NSPECH +#ifdef W3_T + WRITE (NDST,9021) NKH, NKH1, NSPECH +#endif ! ! 4. Summation of source terms and diagonal term and time step ------ * ! @@ -929,25 +1273,45 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & DO IS=IS1, NSPECH VS(IS) = VSLN(IS) + VSIN(IS) + VSNL(IS) & + VSDS(IS) + VSBT(IS) -!/ST6 VS(IS) = VS(IS) + VSWL(IS) -!/TR1 VS(IS) = VS(IS) + VSTR(IS) -!/BS1 VS(IS) = VS(IS) + VSBS(IS) -!/UOST VS(IS) = VS(IS) + VSUO(IS) +#ifdef W3_ST6 + VS(IS) = VS(IS) + VSWL(IS) +#endif +#ifdef W3_TR1 + VS(IS) = VS(IS) + VSTR(IS) +#endif +#ifdef W3_BS1 + VS(IS) = VS(IS) + VSBS(IS) +#endif +#ifdef W3_UOST + VS(IS) = VS(IS) + VSUO(IS) +#endif VD(IS) = VDIN(IS) + VDNL(IS) & + VDDS(IS) + VDBT(IS) -!/ST6 VD(IS) = VD(IS) + VDWL(IS) -!/TR1 VD(IS) = VD(IS) + VDTR(IS) -!/BS1 VD(IS) = VD(IS) + VDBS(IS) -!/UOST VD(IS) = VD(IS) + VDUO(IS) +#ifdef W3_ST6 + VD(IS) = VD(IS) + VDWL(IS) +#endif +#ifdef W3_TR1 + VD(IS) = VD(IS) + VDTR(IS) +#endif +#ifdef W3_BS1 + VD(IS) = VD(IS) + VDBS(IS) +#endif +#ifdef W3_UOST + VD(IS) = VD(IS) + VDUO(IS) +#endif DAMAX = MIN ( DAM(IS) , MAX ( XREL*SPECINIT(IS) , AFILT ) ) AFAC = 1. / MAX( 1.E-10 , ABS(VS(IS)/DAMAX) ) -!/NL5 IF (NL5_SELECT .EQ. 1) THEN -!/NL5 DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & -!/NL5 1. + NL5_OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) -!/NL5 ELSE +#ifdef W3_NL5 + IF (NL5_SELECT .EQ. 1) THEN + DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & + 1. + NL5_OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) + ELSE +#endif DT = MIN ( DT , AFAC / ( MAX ( 1.E-10, & 1. + OFFSET*AFAC*MIN(0.,VD(IS)) ) ) ) -!/NL5 ENDIF +#ifdef W3_NL5 + ENDIF +#endif ! IF (IX == DEBUG_NODE) THEN ! WRITE(*,'(A20,I10,10F30.10)') 'TIME STEP COMP', IS, DAMAX, DAM(IS), XREL*SPECINIT(IS), AFILT, AFAC, DT ! ENDIF @@ -958,44 +1322,62 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & DT = MAX ( 0.5, DT ) ! Here we have a hardlimit, which is not too usefull, at least not as a fixed constant ! DTDYN = DTDYN + DT -!/T DTRAW = DT +#ifdef W3_T + DTRAW = DT +#endif IDT = 1 + INT ( 0.99*(DTG-DTTOT)/DT ) ! number of iterations DT = (DTG-DTTOT)/REAL(IDT) ! actualy time step SHAVE = DT.LT.DTMIN .AND. DT.LT.DTG-DTTOT ! limiter check ... SHAVEIO = SHAVE DT = MAX ( DT , MIN (DTMIN,DTG-DTTOT) ) ! override dt with input time step or last time step if it is bigger ... anyway the limiter is on! ! -!/NL5 DT = INT(DT) * 1.0 +#ifdef W3_NL5 + DT = INT(DT) * 1.0 +#endif IF (srce_call .eq. srce_imp_post) DT = DTG ! for implicit part -!/NL5 IF (NL5_SELECT .EQ. 1) THEN -!/NL5 HDT = NL5_OFFSET * DT -!/NL5 ELSE +#ifdef W3_NL5 + IF (NL5_SELECT .EQ. 1) THEN + HDT = NL5_OFFSET * DT + ELSE +#endif HDT = OFFSET * DT -!/NL5 ENDIF +#ifdef W3_NL5 + ENDIF +#endif DTTOT = DTTOT + DT -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(*,'(A20,2I10,5F20.10,L20)') 'TIMINGS 2', IDT, NSTEPS, DT, DTMIN, DTDYN, HDT, DTTOT, SHAVE -!/DEBUGSRC IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '1: min/max/sum(VS)=', minval(VS), maxval(VS), sum(VS) -!/DEBUGSRC WRITE(740+IAPROC,*) '1: min/max/sum(VD)=', minval(VD), maxval(VD), sum(VD) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VDIN)=', minval(VDIN), maxval(VDIN), sum(VDIN) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VSLN)=', minval(VSLN), maxval(VSLN), sum(VSLN) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VDNL)=', minval(VDNL), maxval(VDNL), sum(VDNL) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VDDS)=', minval(VDDS), maxval(VDDS), sum(VDDS) -!/DEBUGSRC!/ST6 WRITE(740+IAPROC,*) 'min/max/sum(VSWL)=', minval(VSWL), maxval(VSWL), sum(VSWL) -!/DEBUGSRC!/ST6 WRITE(740+IAPROC,*) 'min/max/sum(VDWL)=', minval(VDWL), maxval(VDWL), sum(VDWL) -!/DEBUGSRC!/DB1 WRITE(740+IAPROC,*) 'min/max/sum(VSDB)=', minval(VSDB), maxval(VSDB), sum(VSDB) -!/DEBUGSRC!/DB1 WRITE(740+IAPROC,*) 'min/max/sum(VDDB)=', minval(VDDB), maxval(VDDB), sum(VDDB) -!/DEBUGSRC!/TR1 WRITE(740+IAPROC,*) 'min/max/sum(VSTR)=', minval(VSTR), maxval(VSTR), sum(VSTR) -!/DEBUGSRC!/TR1 WRITE(740+IAPROC,*) 'min/max/sum(VDTR)=', minval(VDTR), maxval(VDTR), sum(VDTR) -!/DEBUGSRC!/BS1 WRITE(740+IAPROC,*) 'min/max/sum(VSBS)=', minval(VSBS), maxval(VSBS), sum(VSBS) -!/DEBUGSRC!/BS1 WRITE(740+IAPROC,*) 'min/max/sum(VDBS)=', minval(VDBS), maxval(VDBS), sum(VDBS) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VSBT)=', minval(VSBT), maxval(VSBT), sum(VSBT) -!/DEBUGSRC WRITE(740+IAPROC,*) 'min/max/sum(VDBT)=', minval(VDBT), maxval(VDBT), sum(VDBT) -!/DEBUGSRC END IF +#ifdef W3_DEBUGSRC + IF (IX == DEBUG_NODE) WRITE(*,'(A20,2I10,5F20.10,L20)') 'TIMINGS 2', IDT, NSTEPS, DT, DTMIN, DTDYN, HDT, DTTOT, SHAVE + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '1: min/max/sum(VS)=', minval(VS), maxval(VS), sum(VS) + WRITE(740+IAPROC,*) '1: min/max/sum(VD)=', minval(VD), maxval(VD), sum(VD) + WRITE(740+IAPROC,*) 'min/max/sum(VSIN)=', minval(VSIN), maxval(VSIN), sum(VSIN) + WRITE(740+IAPROC,*) 'min/max/sum(VDIN)=', minval(VDIN), maxval(VDIN), sum(VDIN) + WRITE(740+IAPROC,*) 'min/max/sum(VSLN)=', minval(VSLN), maxval(VSLN), sum(VSLN) + WRITE(740+IAPROC,*) 'min/max/sum(VSNL)=', minval(VSNL), maxval(VSNL), sum(VSNL) + WRITE(740+IAPROC,*) 'min/max/sum(VDNL)=', minval(VDNL), maxval(VDNL), sum(VDNL) + WRITE(740+IAPROC,*) 'min/max/sum(VSDS)=', minval(VSDS), maxval(VSDS), sum(VSDS) + WRITE(740+IAPROC,*) 'min/max/sum(VDDS)=', minval(VDDS), maxval(VDDS), sum(VDDS) +#ifdef W3_ST6 + WRITE(740+IAPROC,*) 'min/max/sum(VSWL)=', minval(VSWL), maxval(VSWL), sum(VSWL) + WRITE(740+IAPROC,*) 'min/max/sum(VDWL)=', minval(VDWL), maxval(VDWL), sum(VDWL) +#endif +#ifdef W3_DB1 + WRITE(740+IAPROC,*) 'min/max/sum(VSDB)=', minval(VSDB), maxval(VSDB), sum(VSDB) + WRITE(740+IAPROC,*) 'min/max/sum(VDDB)=', minval(VDDB), maxval(VDDB), sum(VDDB) +#endif +#ifdef W3_TR1 + WRITE(740+IAPROC,*) 'min/max/sum(VSTR)=', minval(VSTR), maxval(VSTR), sum(VSTR) + WRITE(740+IAPROC,*) 'min/max/sum(VDTR)=', minval(VDTR), maxval(VDTR), sum(VDTR) +#endif +#ifdef W3_BS1 + WRITE(740+IAPROC,*) 'min/max/sum(VSBS)=', minval(VSBS), maxval(VSBS), sum(VSBS) + WRITE(740+IAPROC,*) 'min/max/sum(VDBS)=', minval(VDBS), maxval(VDBS), sum(VDBS) +#endif + WRITE(740+IAPROC,*) 'min/max/sum(VSBT)=', minval(VSBT), maxval(VSBT), sum(VSBT) + WRITE(740+IAPROC,*) 'min/max/sum(VDBT)=', minval(VDBT), maxval(VDBT), sum(VDBT) + END IF +#endif IF (srce_call .eq. srce_imp_pre) THEN @@ -1035,27 +1417,31 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & VSIO=VS VDIO=VD !!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(10EN15.4)') SUM(VS), SUM(VD), SUM(VSIN), SUM(VDIN), SUM(VSDS), SUM(VDDS), SUM(VSNL), SUM(VDNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_imp_pre : SHAVE = ', SHAVE -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_imp_pre : DT=', DT, ' HDT=', HDT, 'DTG=', DTG -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_imp_pre : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VSTOT)=', sum(VS) -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VDTOT)=', sum(MIN(0. , VD)) -!/DEBUGSRC END IF -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) +#ifdef W3_DEBUGSRC + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) ' srce_imp_pre : SHAVE = ', SHAVE + WRITE(740+IAPROC,*) ' srce_imp_pre : DT=', DT, ' HDT=', HDT, 'DTG=', DTG + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VSTOT)=', sum(VS) + WRITE(740+IAPROC,*) ' srce_imp_pre : sum(VDTOT)=', sum(MIN(0. , VD)) + END IF + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) +#endif RETURN ! return everything is done for the implicit ... END IF ! srce_imp_pre ! -!/T WRITE (NDST,9040) DTRAW, DT, SHAVE +#ifdef W3_T + WRITE (NDST,9040) DTRAW, DT, SHAVE +#endif ! ! 5. Increment spectrum --------------------------------------------- * ! @@ -1077,31 +1463,35 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) END DO END IF -!/DB1 DO IS=IS1, NSPECH -!/DB1 eInc1 = VSDB(IS) * DT / MAX ( 1. , (1.-HDT*VDDB(IS))) -!/DB1 SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) -!/DB1 END DO +#ifdef W3_DB1 + DO IS=IS1, NSPECH + eInc1 = VSDB(IS) * DT / MAX ( 1. , (1.-HDT*VDDB(IS))) + SPEC(IS) = MAX ( 0. , SPEC(IS)+eInc1 ) + END DO +#endif ! IF (IX == DEBUG_NODE) THEN ! WRITE(*,'(A20,I20,F20.10,L20,4F20.10)') 'AFTER', IX, DEPTH, SHAVE, SUM(VS), SUM(VD), SUM(SPEC) ! ENDIF !!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(10EN15.4)') SUM(VS), SUM(VD), SUM(VSIN), SUM(VDIN), SUM(VSDS), SUM(VDDS), SUM(VSNL), SUM(VDNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) -!/DEBUGSRC IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) -!/DEBUGSRC IF (IX == DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_direct : SHAVE = ', SHAVE -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_direct : DT=', DT, ' HDT=', HDT, 'DTG=', DTG -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_direct : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_direct : sum(VSTOT)=', sum(VS) -!/DEBUGSRC WRITE(740+IAPROC,*) ' srce_direct : sum(VDTOT)=', sum(MIN(0. , VD)) -!/DEBUGSRC END IF +#ifdef W3_DEBUGSRC + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDIN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDDS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VDNL) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSLN) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VSBT) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VS) + IF (IX == DEBUG_NODE) WRITE(44,'(1EN15.4)') SUM(VD) + IF (IX == DEBUG_NODE) THEN + WRITE(740+IAPROC,*) ' srce_direct : SHAVE = ', SHAVE + WRITE(740+IAPROC,*) ' srce_direct : DT=', DT, ' HDT=', HDT, 'DTG=', DTG + WRITE(740+IAPROC,*) ' srce_direct : sum(SPEC)=', sum(SPEC) + WRITE(740+IAPROC,*) ' srce_direct : sum(VSTOT)=', sum(VS) + WRITE(740+IAPROC,*) ' srce_direct : sum(VDTOT)=', sum(MIN(0. , VD)) + END IF +#endif END IF @@ -1142,128 +1532,182 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & TAUWNY= TAUWNY+ TAUWAY * DRAT *DT ! MISSING: TAIL TO BE ADDED ? ! -!/NLS CALL W3SNLS ( SPEC, CG1, WN1, DEPTH, U10ABS, DT, AA=SPEC ) +#ifdef W3_NLS + CALL W3SNLS ( SPEC, CG1, WN1, DEPTH, U10ABS, DT, AA=SPEC ) +#endif ! ! 6. Add tail ------------------------------------------------------- * ! a Mean parameters ! ! -!/ST0 CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST2 CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, U10ABS, U10DIR, USTAR, USTDIR, & -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) -!/ST4 CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN,& -!/ST4 AMAX, U10ABS, U10DIR, & -!/ST4!/FLX5 TAUA, TAUADIR, DAIR, & -!/ST4 USTAR, USTDIR, & -!/ST4 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) -!/ST6 CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) -! -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & -!/FLX2 USTAR, USTDIR, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & -!/FLX3 USTAR, USTDIR, Z0, CD ) -! -!/ST1 FH1 = FXFM * FMEAN -!/ST1 FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) -!/ST1 NKH = MAX ( 2 , MIN ( NKH1 , & -!/ST1 INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) -! -!/ST1 IF ( FLTEST ) WRITE (NDST,9060) & -!/ST1 FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH -! -!/ST2 FHTRAN = XFT*FPI -!/ST2 FHIGH = XFC*FPI -!/ST2 DFH = FHIGH - FHTRAN -!/ST2 NKH = MAX ( 1 , & -!/ST2 INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHTRAN)) ) ) -! -!/ST2 IF ( FLTEST ) WRITE (NDST,9061) FHTRAN, FHIGH, NKH -! -!/ST3 FH1 = FFXFM * FMEAN -!/ST3 FH2 = FFXPM / USTAR -!/ST3 FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) -!/ST3 NKH = MAX ( 2 , MIN ( NKH1 , & -!/ST3 INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) -! -!/ST3 IF ( FLTEST ) WRITE (NDST,9062) & -!/ST3 FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH -! -!/ST4! Introduces a Long & Resio (JGR2007) type dependance on wave age -!/ST4 FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) -!/ST4 FH1 = (FFXFM+FAGE) * FMEAN1 +#ifdef W3_ST0 + CALL W3SPR0 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) +#endif +#ifdef W3_ST1 + CALL W3SPR1 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX) +#endif +#ifdef W3_ST2 + CALL W3SPR2 (SPEC, CG1, WN1, DEPTH, FPI, U10ABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, U10ABS, U10DIR, USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (SPEC, CG1, WN1, EMEAN, FMEAN, FMEAN1, WNMEAN,& + AMAX, U10ABS, U10DIR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, DAIR, & +#endif + USTAR, USTDIR, & + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS, DLWMEAN) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (SPEC, CG1, WN1, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif +! +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, U10ABS, U10DIR, & + USTAR, USTDIR, Z0, CD ) +#endif +! +#ifdef W3_ST1 + FH1 = FXFM * FMEAN + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) +#endif +! +#ifdef W3_ST1 + IF ( FLTEST ) WRITE (NDST,9060) & + FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH +#endif +! +#ifdef W3_ST2 + FHTRAN = XFT*FPI + FHIGH = XFC*FPI + DFH = FHIGH - FHTRAN + NKH = MAX ( 1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHTRAN)) ) ) +#endif +! +#ifdef W3_ST2 + IF ( FLTEST ) WRITE (NDST,9061) FHTRAN, FHIGH, NKH +#endif +! +#ifdef W3_ST3 + FH1 = FFXFM * FMEAN + FH2 = FFXPM / USTAR + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) +#endif +! +#ifdef W3_ST3 + IF ( FLTEST ) WRITE (NDST,9062) & + FH1*TPIINV, FH2*TPIINV, FHIGH*TPIINV, NKH +#endif +! +#ifdef W3_ST4 +! Introduces a Long & Resio (JGR2007) type dependance on wave age + FAGE = FFXFA*TANH(0.3*U10ABS*FMEANWS*TPI/GRAV) + FH1 = (FFXFM+FAGE) * FMEAN1 +#endif -!/ST4 FH2 = FFXPM / USTAR -!/ST4 FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) -!/ST4 NKH = MAX ( 2 , MIN ( NKH1 , & -!/ST4 INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) -! -!/ST6 IF (FXFM .LE. 0) THEN -!/ST6 FHIGH = SIG(NK) -!/ST6 ELSE -!/ST6 FHIGH = MIN ( SIG(NK), MAX(FXFM * FMEAN, FXPM / USTAR) ) -!/ST6 ENDIF -!/ST6 NKH = MAX ( 2 , MIN ( NKH1 , & -!/ST6 INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) -! -!/ST6 IF ( FLTEST ) WRITE (NDST,9063) FHIGH*TPIINV, NKH +#ifdef W3_ST4 + FH2 = FFXPM / USTAR + FHIGH = MIN ( SIG(NK) , MAX ( FH1 , FH2 ) ) + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) +#endif +! +#ifdef W3_ST6 + IF (FXFM .LE. 0) THEN + FHIGH = SIG(NK) + ELSE + FHIGH = MIN ( SIG(NK), MAX(FXFM * FMEAN, FXPM / USTAR) ) + ENDIF + NKH = MAX ( 2 , MIN ( NKH1 , & + INT ( FACTI2 + FACTI1*LOG(MAX(1.E-7,FHIGH)) ) ) ) +#endif +! +#ifdef W3_ST6 + IF ( FLTEST ) WRITE (NDST,9063) FHIGH*TPIINV, NKH +#endif ! ! 6.b Limiter for shallow water or Miche style criterion ! Last time step ONLY ! ! uses true depth (D_INP) instead of limited depth ! -!/MLIM IF ( DTTOT .GE. 0.9999*DTG ) THEN -!/MLIM HM = FHMAX *TANH(WNMEAN*MAX(0.,D_INP)) / MAX(1.E-4,WNMEAN ) -!/MLIM EM = HM * HM / 16. -!/MLIM IF ( EMEAN.GT.EM .AND. EMEAN.GT.1.E-30 ) THEN -!/MLIM SPEC = SPEC / EMEAN * EM -!/MLIM EMEAN = EM -!/MLIM END IF -!/MLIM END IF +#ifdef W3_MLIM + IF ( DTTOT .GE. 0.9999*DTG ) THEN + HM = FHMAX *TANH(WNMEAN*MAX(0.,D_INP)) / MAX(1.E-4,WNMEAN ) + EM = HM * HM / 16. + IF ( EMEAN.GT.EM .AND. EMEAN.GT.1.E-30 ) THEN + SPEC = SPEC / EMEAN * EM + EMEAN = EM + END IF + END IF +#endif ! ! 6.c Seeding of spectrum ! alpha = 0.005 , 0.5 in eq., 0.25 for directional distribution ! -!/SEED DO IK=MIN(NK,NKH), NK -!/SEED UC = FACSD * GRAV / SIG(IK) -!/SEED SLEV = MIN ( 1. , MAX ( 0. , U10ABS/UC-1. ) ) * & -!/SEED 6.25E-4 / WN1(IK)**3 / SIG(IK) -!/SEED IF (INFLAGS2(4)) SLEV=SLEV*(1-ICE) -!/SEED DO ITH=1, NTH -!/SEED SPEC(ITH+(IK-1)*NTH) = MAX ( SPEC(ITH+(IK-1)*NTH) , & -!/SEED SLEV * MAX ( 0. , COS(U10DIR-TH(ITH)) )**2 ) -!/SEED END DO -!/SEED END DO +#ifdef W3_SEED + DO IK=MIN(NK,NKH), NK + UC = FACSD * GRAV / SIG(IK) + SLEV = MIN ( 1. , MAX ( 0. , U10ABS/UC-1. ) ) * & + 6.25E-4 / WN1(IK)**3 / SIG(IK) + IF (INFLAGS2(4)) SLEV=SLEV*(1-ICE) + DO ITH=1, NTH + SPEC(ITH+(IK-1)*NTH) = MAX ( SPEC(ITH+(IK-1)*NTH) , & + SLEV * MAX ( 0. , COS(U10DIR-TH(ITH)) )**2 ) + END DO + END DO +#endif ! ! 6.d Add tail ! DO IK=NKH+1, NK -!/ST2 FACDIA = MAX ( 0. , MIN ( 1., (SIG(IK)-FHTRAN)/DFH) ) -!/ST2 FACPAR = MAX ( 0. , 1.-FACDIA ) +#ifdef W3_ST2 + FACDIA = MAX ( 0. , MIN ( 1., (SIG(IK)-FHTRAN)/DFH) ) + FACPAR = MAX ( 0. , 1.-FACDIA ) +#endif DO ITH=1, NTH SPEC(ITH+(IK-1)*NTH) = SPEC(ITH+(IK-2)*NTH) * FACHFA & -!/ST2 * FACDIA + FACPAR * SPEC(ITH+(IK-1)*NTH) & +#ifdef W3_ST2 + * FACDIA + FACPAR * SPEC(ITH+(IK-1)*NTH) & +#endif + 0. END DO END DO ! ! 6.e Update wave-supported stress----------------------------------- * ! -!/ST3 CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST3 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST3 ICE, VSIN, VDIN, LLWS, IX, IY ) -!/ST4 CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & -!/ST4 U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & -!/ST4 VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) +#ifdef W3_ST3 + CALL W3SIN3 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + ICE, VSIN, VDIN, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SIN4 ( SPEC, CG1, WN2, U10ABS, USTAR, DRAT, AS, & + U10DIR, Z0, CD, TAUWX, TAUWY, TAUWAX, TAUWAY, & + VSIN, VDIN, LLWS, IX, IY, BRLAMBDA ) +#endif ! ! 7. Check if integration complete ---------------------------------- * ! ! Update QI5TSTART (Q. Liu) -!/NL5 CALL TICK21(QI5TSTART, DT) +#ifdef W3_NL5 + CALL TICK21(QI5TSTART, DT) +#endif IF (srce_call .eq. srce_imp_post) THEN EXIT ENDIF @@ -1272,11 +1716,13 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & EXIT ENDIF END DO ! INTEGRATIN LOOP -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) 'NSTEPS=', NSTEPS -!/DEBUGSRC WRITE(740+IAPROC,*) '1 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF -!/DEBUGSRC WRITE(740+IAPROC,*) 'DT=', DT, 'DTG=', DTG +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'NSTEPS=', NSTEPS + WRITE(740+IAPROC,*) '1 : sum(SPEC)=', sum(SPEC) + END IF + WRITE(740+IAPROC,*) 'DT=', DT, 'DTG=', DTG +#endif ! ! ... End point dynamic integration - - - - - - - - - - - - - - - - - - ! @@ -1289,13 +1735,17 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! ! Error escape locations ! -!/NNT 800 CONTINUE -!/NNT WRITE (NDSE,8000) FNAME, IERR -!/NNT CALL EXTCDE (1) +#ifdef W3_NNT + 800 CONTINUE + WRITE (NDSE,8000) FNAME, IERR + CALL EXTCDE (1) +#endif ! -!/NNT 801 CONTINUE -!/NNT WRITE (NDSE,8001) IERR -!/NNT CALL EXTCDE (2) +#ifdef W3_NNT + 801 CONTINUE + WRITE (NDSE,8001) IERR + CALL EXTCDE (2) +#endif ! 888 CONTINUE ! @@ -1304,9 +1754,11 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! and final energy, plus wind input plus the SNL flux to high freq., ! minus the energy lost to the bottom boundary layer (BBL) ! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '2 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '2 : sum(SPEC)=', sum(SPEC) + END IF +#endif EFINISH = 0. MWXFINISH = 0. MWYFINISH = 0. @@ -1350,9 +1802,11 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! INFLAGS2(4) is true if ice concentration was ever read during ! this simulation ! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '3 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '3 : sum(SPEC)=', sum(SPEC) + END IF +#endif IF ( INFLAGS2(4).AND.ICE.GT.0 ) THEN @@ -1362,13 +1816,15 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & SIG,WN_R,CG_ICE,ALPHA_LIU) ! IF (IICESMOOTH) THEN -!/IS2 DO IK=1,NK -!/IS2 SMOOTH_ICEDISP=0. -!/IS2 IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.ICEF) THEN ! IF ICE IS NOT TOO MUCH BROKEN -!/IS2 SMOOTH_ICEDISP=TANH((ICEF-IS2PARS(14)*(TPI/WN_R(IK)))/(ICEF*IS2PARS(13))) -!/IS2 END IF -!/IS2 WN_R(IK)=WN1(IK)*(1-SMOOTH_ICEDISP)+WN_R(IK)*(SMOOTH_ICEDISP) -!/IS2 END DO +#ifdef W3_IS2 + DO IK=1,NK + SMOOTH_ICEDISP=0. + IF (IS2PARS(14)*(TPI/WN_R(IK)).LT.ICEF) THEN ! IF ICE IS NOT TOO MUCH BROKEN + SMOOTH_ICEDISP=TANH((ICEF-IS2PARS(14)*(TPI/WN_R(IK)))/(ICEF*IS2PARS(13))) + END IF + WN_R(IK)=WN1(IK)*(1-SMOOTH_ICEDISP)+WN_R(IK)*(SMOOTH_ICEDISP) + END DO +#endif END IF ELSE WN_R=WN1 @@ -1377,17 +1833,31 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! R(:)=1 ! In case IC2 is defined but not IS2 ! -!/IC1 CALL W3SIC1 ( SPEC,DEPTH, CG1, IX, IY, VSIC, VDIC ) -!/IS2 CALL W3SIS2 ( SPEC, DEPTH, ICE, ICEH, ICEF, ICEDMAX, IX, IY, & -!/IS2 VSIR, VDIR, VDIR2, WN1, CG1, WN_R, CG_ICE, R ) +#ifdef W3_IC1 + CALL W3SIC1 ( SPEC,DEPTH, CG1, IX, IY, VSIC, VDIC ) +#endif +#ifdef W3_IS2 + CALL W3SIS2 ( SPEC, DEPTH, ICE, ICEH, ICEF, ICEDMAX, IX, IY, & + VSIR, VDIR, VDIR2, WN1, CG1, WN_R, CG_ICE, R ) +#endif -!/IC2 CALL W3SIC2 ( SPEC, DEPTH, ICEH, ICEF, CG1, WN1,& -!/IC2 IX, IY, VSIC, VDIC, WN_R, CG_ICE, ALPHA_LIU, R) -!/IC3 CALL W3SIC3 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) -!/IC4 CALL W3SIC4 ( SPEC,DEPTH, CG1, IX, IY, VSIC, VDIC ) -!/IC5 CALL W3SIC5 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) -! -!/IS1 CALL W3SIS1 ( SPEC, ICE, VSIR ) +#ifdef W3_IC2 + CALL W3SIC2 ( SPEC, DEPTH, ICEH, ICEF, CG1, WN1,& + IX, IY, VSIC, VDIC, WN_R, CG_ICE, ALPHA_LIU, R) +#endif +#ifdef W3_IC3 + CALL W3SIC3 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) +#endif +#ifdef W3_IC4 + CALL W3SIC4 ( SPEC,DEPTH, CG1, IX, IY, VSIC, VDIC ) +#endif +#ifdef W3_IC5 + CALL W3SIC5 ( SPEC,DEPTH, CG1, WN1, IX, IY, VSIC, VDIC ) +#endif +! +#ifdef W3_IS1 + CALL W3SIS1 ( SPEC, ICE, VSIR ) +#endif SPEC2 = SPEC ! TAUICE(:) = 0. @@ -1398,44 +1868,60 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! First part of ice term integration: dissipation part ! ATT=1. -!/IC1 ATT=EXP(ICE*VDIC(IS)*DTG) -!/IC2 ATT=EXP(ICE*VDIC(IS)*DTG) -!/IC3 ATT=EXP(ICE*VDIC(IS)*DTG) -!/IC4 ATT=EXP(ICE*VDIC(IS)*DTG) -!/IC5 ATT=EXP(ICE*VDIC(IS)*DTG) -!/IS1 ATT=ATT*EXP(ICE*VDIR(IS)*DTG) -!/IS2 ATT=ATT*EXP(ICE*VDIR2(IS)*DTG) -!/IS2 IF (IS2PARS(2).EQ.0) THEN ! Reminder : IS2PARS(2) = IS2BACKSCAT -!/IS2! -!/IS2! If there is not re-distribution in directions the scattering is just an attenuation -!/IS2! -!/IS2 ATT=ATT*EXP((ICE*VDIR(IS))*DTG) -!/IS2 END IF +#ifdef W3_IC1 + ATT=EXP(ICE*VDIC(IS)*DTG) +#endif +#ifdef W3_IC2 + ATT=EXP(ICE*VDIC(IS)*DTG) +#endif +#ifdef W3_IC3 + ATT=EXP(ICE*VDIC(IS)*DTG) +#endif +#ifdef W3_IC4 + ATT=EXP(ICE*VDIC(IS)*DTG) +#endif +#ifdef W3_IC5 + ATT=EXP(ICE*VDIC(IS)*DTG) +#endif +#ifdef W3_IS1 + ATT=ATT*EXP(ICE*VDIR(IS)*DTG) +#endif +#ifdef W3_IS2 + ATT=ATT*EXP(ICE*VDIR2(IS)*DTG) + IF (IS2PARS(2).EQ.0) THEN ! Reminder : IS2PARS(2) = IS2BACKSCAT +! +! If there is not re-distribution in directions the scattering is just an attenuation +! + ATT=ATT*EXP((ICE*VDIR(IS))*DTG) + END IF +#endif SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ATT*SPEC2(1+(IK-1)*NTH:NTH+(IK-1)*NTH) ! ! Second part of ice term integration: scattering including re-distribution in directions ! -!/IS2 IF (IS2PARS(2).GE.0) THEN -!/IS2 IF (IS2PARS(20).GT.0.5) THEN -!/IS2! -!/IS2! Case of isotropic back-scatter: the directional spectrum is decomposed into -!/IS2! - an isotropic part (ISO): eigenvalue of scattering is 0 -!/IS2! - the rest (SPEC-ISO): eigenvalue of scattering is VDIR(IS) -!/IS2! -!/IS2 SCAT = EXP(VDIR(IS)*IS2PARS(2)*DTG) -!/IS2 ISO = SUM(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH))/NTH -!/IS2 SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ISO & -!/IS2 +(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)-ISO)*SCAT -!/IS2 ELSE -!/IS2! -!/IS2! General solution with matrix exponentials: same as bottom scattering, see Ardhuin & Herbers (JFM 2002) -!/IS2! -!/IS2 SCATSPEC(1:NTH)=DBLE(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)) -!/IS2 SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = & -!/IS2 REAL(MATMUL(IS2EIGVEC(:,:), EXP(IS2EIGVAL(:)*VDIR(IS)*DTG*IS2PARS(2)) & -!/IS2 *MATMUL(TRANSPOSE(IS2EIGVEC(:,:)),SCATSPEC))) -!/IS2 END IF -!/IS2 END IF +#ifdef W3_IS2 + IF (IS2PARS(2).GE.0) THEN + IF (IS2PARS(20).GT.0.5) THEN +! +! Case of isotropic back-scatter: the directional spectrum is decomposed into +! - an isotropic part (ISO): eigenvalue of scattering is 0 +! - the rest (SPEC-ISO): eigenvalue of scattering is VDIR(IS) +! + SCAT = EXP(VDIR(IS)*IS2PARS(2)*DTG) + ISO = SUM(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH))/NTH + SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = ISO & + +(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)-ISO)*SCAT + ELSE +! +! General solution with matrix exponentials: same as bottom scattering, see Ardhuin & Herbers (JFM 2002) +! + SCATSPEC(1:NTH)=DBLE(SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH)) + SPEC(1+(IK-1)*NTH:NTH+(IK-1)*NTH) = & + REAL(MATMUL(IS2EIGVEC(:,:), EXP(IS2EIGVAL(:)*VDIR(IS)*DTG*IS2PARS(2)) & + *MATMUL(TRANSPOSE(IS2EIGVEC(:,:)),SCATSPEC))) + END IF + END IF +#endif ! ! 10.2 Fluxes of energy and momentum due to ice effects ! @@ -1452,9 +1938,11 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & PHICE =-1.*DWAT*GRAV*PHICE /DTG TAUICE(:)=TAUICE(:)/DTG ELSE -!/IS2 IF (IS2PARS(10).LT.0.5) THEN -!/IS2 ICEF = 0. -!/IS2 ENDIF +#ifdef W3_IS2 + IF (IS2PARS(10).LT.0.5) THEN + ICEF = 0. + ENDIF +#endif END IF ! ! @@ -1465,59 +1953,77 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & !conditions (>10 m/s). It is not recommended to use these at lower wind !in their current state. ! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '4 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '4 : sum(SPEC)=', sum(SPEC) + END IF +#endif ! FLD1/2 requires the calculation of FPI: -!/FLD1 CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) -!/FLD2 CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) -! -!/FLD1 IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then -!/FLD1 CALL W3FLD1 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & -!/FLD1 COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & -!/FLD1 DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) -!/FLD1 ELSE -!/FLD1 CHARN = AALPHA -!/FLD1 ENDIF -!/FLD2 IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then -!/FLD2 CALL W3FLD2 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & -!/FLD2 COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & -!/FLD2 DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) -!/FLD2 ELSE -!/FLD2 CHARN = AALPHA -!/FLD2 ENDIF +#ifdef W3_FLD1 + CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) +#endif +#ifdef W3_FLD2 + CALL CALC_FPI(SPEC, CG1, FPI, VSIN ) +#endif +! +#ifdef W3_FLD1 + IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then + CALL W3FLD1 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & + COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & + DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) + ELSE + CHARN = AALPHA + ENDIF +#endif +#ifdef W3_FLD2 + IF (U10ABS.GT.10. .and. HSTOT.gt.0.5) then + CALL W3FLD2 ( SPEC,min(FPI/TPI,2.0),COEF*U10ABS*COS(U10DIR), & + COEF*U10ABS*Sin(U10DIR), ZWND, DEPTH, 0.0, & + DAIR, USTAR, USTDIR, Z0,TAUNUX,TAUNUY,CHARN) + ELSE + CHARN = AALPHA + ENDIF +#endif ! ! 12. includes shoreline reflection --------------------------------------------- * ! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '5 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF -!/REF1 IF (REFLEC(1).GT.0.OR.REFLEC(2).GT.0.OR.(REFLEC(4).GT.0.AND.BERG.GT.0)) THEN -!/REF1 CALL W3SREF ( SPEC, CG1, WN1, EMEAN, FMEAN, DEPTH, CX, CY, & -!/REF1 REFLEC, REFLED, TRNX, TRNY, & -!/REF1 BERG, DTG, IX, IY, VREF ) -!/REF1 IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '5 : sum(SPEC)=', sum(SPEC) + END IF +#endif +#ifdef W3_REF1 + IF (REFLEC(1).GT.0.OR.REFLEC(2).GT.0.OR.(REFLEC(4).GT.0.AND.BERG.GT.0)) THEN + CALL W3SREF ( SPEC, CG1, WN1, EMEAN, FMEAN, DEPTH, CX, CY, & + REFLEC, REFLED, TRNX, TRNY, & + BERG, DTG, IX, IY, VREF ) + IF (GTYPE.EQ.UNGTYPE.AND.REFPARS(3).LT.0.5) THEN +#endif !AR: this can be further simplified let's do some simple tests 1st ... -!/REF1 IF (IOBP(IX).EQ.0) THEN -!/REF1 DO IK=1, NK -!/REF1 DO ITH=1, NTH -!/REF1 IF (IOBPD(ITH,IX).EQ.0) SPEC(ITH+(IK-1)*NTH) = DTG*VREF(ITH+(IK-1)*NTH) -!/REF1 END DO -!/REF1 END DO -!/REF1 ELSE -!/REF1 IF (IOBDP(IX) .EQ. -1) THEN -!/REF1 SPEC(:) = SPEC(:) + DTG * VREF(:) -!/REF1 ENDIF -!/REF1 ENDIF -!/REF1 ELSE -!/REF1 SPEC(:) = SPEC(:) + DTG * VREF(:) -!/REF1 END IF -!/REF1 END IF -! -!/DEBUGSRC IF (IX .eq. DEBUG_NODE) THEN -!/DEBUGSRC WRITE(740+IAPROC,*) '6 : sum(SPEC)=', sum(SPEC) -!/DEBUGSRC END IF +#ifdef W3_REF1 + IF (IOBP(IX).EQ.0) THEN + DO IK=1, NK + DO ITH=1, NTH + IF (IOBPD(ITH,IX).EQ.0) SPEC(ITH+(IK-1)*NTH) = DTG*VREF(ITH+(IK-1)*NTH) + END DO + END DO + ELSE + IF (IOBDP(IX) .EQ. -1) THEN + SPEC(:) = SPEC(:) + DTG * VREF(:) + ENDIF + ENDIF + ELSE + SPEC(:) = SPEC(:) + DTG * VREF(:) + END IF + END IF +#endif +! +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) '6 : sum(SPEC)=', sum(SPEC) + END IF +#endif FIRST = .FALSE. @@ -1529,43 +2035,69 @@ SUBROUTINE W3SRCE ( srce_call, IT, JSEA, IX, IY, IMOD, & ! ! Formats ! -!/NNT 8000 FORMAT (/' *** ERROR W3SRCE : ERROR IN OPENING FILE ',A,' ***'/ & -!/NNT ' IOSTAT = ',I10/) -!/NNT 8001 FORMAT (/' *** ERROR W3SRCE : ERROR IN WRITING TO FILE ***'/ & -!/NNT ' IOSTAT = ',I10/) -! -!/T 9000 FORMAT (' TEST W3SRCE : COUNTERS : NO LONGER AVAILABLE') -!/T 9001 FORMAT (' TEST W3SRCE : DEPTH :',F8.1/ & -!/T ' WIND SPEED :',F8.1/ & -!/T ' WIND DIR :',F8.1) -!/ST1 9004 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST1 ' ------------- NEW DYNAMIC INTEGRATION LOOP', & -!/ST1 ' ------------- ') -!/ST2 9005 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & -!/ST2 ' ------------- NEW DYNAMIC INTEGRATION LOOP', & -!/ST2 ' ------------- ') -!/ST3 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST3 ' ------------- NEW DYNAMIC INTEGRATION LOOP', & -!/ST3 ' ------------- ') -!/ST4 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST4 ' ------------- NEW DYNAMIC INTEGRATION LOOP', & -!/ST4 ' ------------- ') -! -!/T 9020 FORMAT (' TEST W3SRCE : NSTEP : ',I4,' DTTOT :',F6.1) -!/T 9021 FORMAT (' TEST W3SRCE : NKH (3X) : ',2I3,I6) -! -!/T 9040 FORMAT (' TEST W3SRCE : DTRAW, DT, SHAVE :',2F6.1,2X,L1) -! -!/ST1 9060 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST1 ' NKH : ',I3) -!/ST2 9061 FORMAT (' TEST W3SRCE : FHIGH (2X) : ',2F8.4/ & -!/ST2 ' NKH : ',I3) -!/ST3 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST3 ' NKH : ',I3) -!/ST4 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & -!/ST4 ' NKH : ',I3) -!/ST6 9063 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & -!/ST6 ' NKH : ',I3) +#ifdef W3_NNT + 8000 FORMAT (/' *** ERROR W3SRCE : ERROR IN OPENING FILE ',A,' ***'/ & + ' IOSTAT = ',I10/) + 8001 FORMAT (/' *** ERROR W3SRCE : ERROR IN WRITING TO FILE ***'/ & + ' IOSTAT = ',I10/) +#endif +! +#ifdef W3_T + 9000 FORMAT (' TEST W3SRCE : COUNTERS : NO LONGER AVAILABLE') + 9001 FORMAT (' TEST W3SRCE : DEPTH :',F8.1/ & + ' WIND SPEED :',F8.1/ & + ' WIND DIR :',F8.1) +#endif +#ifdef W3_ST1 + 9004 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') +#endif +#ifdef W3_ST2 + 9005 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') +#endif +#ifdef W3_ST3 + 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') +#endif +#ifdef W3_ST4 + 9006 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' ------------- NEW DYNAMIC INTEGRATION LOOP', & + ' ------------- ') +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3SRCE : NSTEP : ',I4,' DTTOT :',F6.1) + 9021 FORMAT (' TEST W3SRCE : NKH (3X) : ',2I3,I6) +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3SRCE : DTRAW, DT, SHAVE :',2F6.1,2X,L1) +#endif +! +#ifdef W3_ST1 + 9060 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) +#endif +#ifdef W3_ST2 + 9061 FORMAT (' TEST W3SRCE : FHIGH (2X) : ',2F8.4/ & + ' NKH : ',I3) +#endif +#ifdef W3_ST3 + 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) +#endif +#ifdef W3_ST4 + 9062 FORMAT (' TEST W3SRCE : FHIGH (3X) : ',3F8.4/ & + ' NKH : ',I3) +#endif +#ifdef W3_ST6 + 9063 FORMAT (' TEST W3SRCE : FHIGH : ',F8.4/ & + ' NKH : ',I3) +#endif !/ !/ End of W3SRCE ----------------------------------------------------- / !/ @@ -1634,7 +2166,9 @@ SUBROUTINE CALC_FPI( A, CG, FPI, S ) !/ ------------------------------------------------------------------- / USE CONSTANTS USE W3GDATMD, ONLY: NK, NTH, NSPEC, XFR, DDEN, SIG,FTE, FTTR -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -1648,12 +2182,16 @@ SUBROUTINE CALC_FPI( A, CG, FPI, S ) !/ Local parameters !/ INTEGER :: IS, IK -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: M0, M1, SIN1A(NK) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'CALC_FPI') +#ifdef W3_S + CALL STRACE (IENT, 'CALC_FPI') +#endif ! ! Calculate FPI: equivalent peak frequncy from wind source term ! input @@ -1729,7 +2267,9 @@ SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, only : NTH, NK, NSPEC IMPLICIT NONE @@ -1740,7 +2280,9 @@ SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1748,7 +2290,9 @@ SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) INTEGER :: ISP, ITH, IK, IS REAL, INTENT(IN) :: SPEC(NSPEC) REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) -!/S CALL STRACE (IENT, 'SIGN_VSD_SEMI_IMPLICIT_WW3') +#ifdef W3_S + CALL STRACE (IENT, 'SIGN_VSD_SEMI_IMPLICIT_WW3') +#endif DO IS=1,NSPEC VD(IS) = MIN(0., VD(IS)) END DO @@ -1799,7 +2343,9 @@ SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, only : NTH, NK, NSPEC @@ -1811,14 +2357,18 @@ SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER :: ISP, ITH, IK, IS REAL, INTENT(IN) :: SPEC(NSPEC) REAL, INTENT(INOUT) :: VS(NSPEC), VD(NSPEC) -!/S CALL STRACE (IENT, 'SIGN_VSD_PATANKAR_WW3') +#ifdef W3_S + CALL STRACE (IENT, 'SIGN_VSD_PATANKAR_WW3') +#endif DO IS=1,NSPEC VD(IS) = MIN(0., VD(IS)) VS(IS) = MAX(0., VS(IS)) diff --git a/model/ftn/w3str1md.ftn b/model/src/w3str1md.F90 similarity index 99% rename from model/ftn/w3str1md.ftn rename to model/src/w3str1md.F90 index 19d933bc8..74b901faf 100644 --- a/model/ftn/w3str1md.ftn +++ b/model/src/w3str1md.F90 @@ -231,7 +231,9 @@ SUBROUTINE W3STR1 (A, CG, WN, DEPTH, IX, S, D) USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -288,7 +290,9 @@ SUBROUTINE W3STR1 (A, CG, WN, DEPTH, IX, S, D) ! XIS : rate between two succeeding frequency counters ! XISLN : log of XIS ! -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER I1, I2, ID, IDDUM, II, IS, ISM, ISM1, ISMAX, & ISP, ISP1, ITH, IK REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & @@ -304,7 +308,9 @@ SUBROUTINE W3STR1 (A, CG, WN, DEPTH, IX, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3STR1') +#ifdef W3_S + CALL STRACE (IENT, 'W3STR1') +#endif ! ! 0. Initializations ------------------------------------------------ * ! diff --git a/model/ftn/w3str2md.ftn b/model/src/w3str2md.F90 similarity index 98% rename from model/ftn/w3str2md.ftn rename to model/src/w3str2md.F90 index 79ae56134..b66688b8b 100644 --- a/model/ftn/w3str2md.ftn +++ b/model/src/w3str2md.F90 @@ -147,7 +147,9 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) USE W3GDATMD, ONLY: NK, NTH, NSPEC, DTH, SIG, DDEN, FTE, FTF, PPTRIAD USE W3ODATMD, ONLY: NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -204,7 +206,9 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) ! XIS : rate between two succeeding frequency counters ! XISLN : log of XIS ! -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER I1, I2, ID, IDDUM, IENT, II, IS, ISM, ISM1, ISMAX, & ISP, ISP1, ITH, IK REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & @@ -219,7 +223,9 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3STR2') +#ifdef W3_S + CALL STRACE (IENT, 'W3STR2') +#endif ! ! 0. Initializations ------------------------------------------------ * ! diff --git a/model/ftn/w3strkmd.ftn b/model/src/w3strkmd.F90 similarity index 90% rename from model/ftn/w3strkmd.ftn rename to model/src/w3strkmd.F90 index faaac4e30..0fb0b45dc 100644 --- a/model/ftn/w3strkmd.ftn +++ b/model/src/w3strkmd.F90 @@ -314,8 +314,10 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & !/ No unauthorized use without permission. !/ IMPLICIT NONE -!/MPI -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + + INCLUDE "mpif.h" +#endif ! ! 1. Purpose : ! @@ -428,13 +430,15 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & INTEGER :: latind1, latind2, lonind1, lonind2 REAL :: lonext, latext -!/MPI INTEGER :: rank, irank, nproc, EXTENT, DOMSIZE, tag1, tag2 -!/MPI/! INTEGER :: MPI_INT_DOMARR, MPI_REAL_DOMARR -!/MPI INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) -!/MPI INTEGER :: REQ(16) -!/MPI/! INTEGER :: ISTAT(MPI_STATUS_SIZE,16) -!/MPI REAL :: COMMARR1(44) -!/MPI INTEGER :: COMMARR2(11) +#ifdef W3_MPI + INTEGER :: rank, irank, nproc, EXTENT, DOMSIZE, tag1, tag2 +! INTEGER :: MPI_INT_DOMARR, MPI_REAL_DOMARR + INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) + INTEGER :: REQ(16) +! INTEGER :: ISTAT(MPI_STATUS_SIZE,16) + REAL :: COMMARR1(44) + INTEGER :: COMMARR2(11) +#endif ! ! 4. Subroutines used : ! @@ -464,8 +468,10 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & ! !/ ------------------------------------------------------------------- / -!/MPI CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) -!/MPI CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) +#ifdef W3_MPI + CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) +#endif NULLIFY( sysA ) NULLIFY( maxSys ) @@ -475,7 +481,9 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & ! Read file here, and set up 2d array wsdat with the data. t0 = 1 IF (intype.EQ.1) THEN -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif ! Read partRes format file WRITE(20,*) 'Reading partRes partitioning file...' filesize = 7500000 @@ -515,9 +523,13 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & line = line-1 WRITE(6,*) '... finished' ! DEALLOCATE(date0) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ELSE IF (intype.EQ.2) THEN -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif ! Read WW3 Spectral Partition format file ! Query input file to determine required array sizes INQUIRE(FILE=filename, EXIST=file_exists) @@ -583,7 +595,9 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & IF (FLFORM) THEN READ (11,1000,ERR=802,END=112) date1,date2,x,y, & numpart,wnd,wnddir,invar6,invar7 -!/del write(*,*) '0:',x,y,numpart +#ifdef W3_del + write(*,*) '0:',x,y,numpart +#endif skipln = skipln+1 ELSE READ (11,ERR=802,IOSTAT=IOERR) DATETIME,x,y, & @@ -642,7 +656,9 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & DO line = 1,numpart+1 READ (11,1010,END=111,ERR=802,IOSTAT=IOERR) & invar1,invar2,invar3,invar4 -!/del write(*,'(A,2I6,4F7.2)') '1+:',line,numpart+1,invar1,invar2,invar3,invar4 +#ifdef W3_del + write(*,'(A,2I6,4F7.2)') '1+:',line,numpart+1,invar1,invar2,invar3,invar4 +#endif readln = readln+1 END DO ELSE @@ -834,10 +850,14 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & IF (ALLOCATED(PSPR)) DEALLOCATE(PSPR) IF (ALLOCATED(PWF)) DEALLOCATE(PWF) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif END IF -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif ! Find unique time steps (and sort in ascending order) CALL UNIQUE(REAL(ts(1:line)),line,uniqueTim,maxTs) @@ -916,24 +936,38 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & mlat(I,J) = uniqueLat(J) END DO END DO -!/MPI END IF +#ifdef W3_MPI + END IF +#endif -!/MPI CALL MPI_BCAST(maxI,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(maxJ,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(maxTs,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) +#ifdef W3_MPI + CALL MPI_BCAST(maxI,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxJ,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxTs,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) +#endif ! Allocate the wsdat structure -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(20,*) 'Allocating wsdat...' -!/MPI END IF +#ifdef W3_MPI + END IF +#endif NULLIFY(wsdat) ALLOCATE(wsdat(maxTs)) -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(20,*) 'SIZE(wsdat) = ',SIZE(wsdat) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! Allocate and initialize the wsdat array -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif DO tsA = 1,maxTs ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) @@ -1090,110 +1124,116 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & ! IF (ALLOCATED(wf0)) DEALLOCATE(wf0) IF (ALLOCATED(wndSpd0)) DEALLOCATE(wndSpd0) IF (ALLOCATED(wndDir0)) DEALLOCATE(wndDir0) -!/MPI END IF - -!/MPI/! Communicate the wsdat entries from rank=0 to other ranks -!/MPI DO tsA = t0,maxTs -!/MPI irank = MOD((tsA-t0),MIN(nproc,maxTS)) -!/MPI/! WRITE(20,*) 'Rank,irank=',rank,irank -!/MPI IF (irank.NE.0) THEN -!/MPI/! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) -!/MPI ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) -!/MPI ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) -!/MPI ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) -!/MPI -!/MPI DO j = 1,maxJ -!/MPI DO i = 1,maxI -!/MPI wsdat(tsA)%maxi=maxI -!/MPI wsdat(tsA)%maxj=maxJ -!/MPI wsdat(tsA)%par(i,j)%hs(1:10)=9999. -!/MPI wsdat(tsA)%par(i,j)%tp(1:10)=9999. -!/MPI wsdat(tsA)%par(i,j)%dir(1:10)=9999. -!/MPI wsdat(tsA)%par(i,j)%dspr(1:10)=9999. -!/MPI wsdat(tsA)%par(i,j)%ipart(1:10)=0 -!/MPI wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable -!/MPI wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 -!/MPI wsdat(tsA)%wnd(i,j)%wdir=9999. -!/MPI wsdat(tsA)%wnd(i,j)%wspd=9999. -!/MPI wsdat(tsA)%par(i,j)%checked=-1 -!/MPI END DO -!/MPI END DO -!/MPI END IF -!/MPI -!/MPI DO j = 1,maxJ -!/MPI DO i = 1,maxI -!/MPI tag1 = ((j-1)*maxI+i)*10 -!/MPI -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(6,*) '>> Sending: rank,irank,tag1=', & -!/MPI/! rank,irank,(tag1+1) -!/MPI COMMARR1 = (/wsdat(tsA)%par(i,j)%hs(:), & -!/MPI wsdat(tsA)%par(i,j)%tp(:), & -!/MPI wsdat(tsA)%par(i,j)%dir(:), & -!/MPI wsdat(tsA)%par(i,j)%dspr(:), & -!/MPI wsdat(tsA)%wnd(i,j)%wdir, & -!/MPI wsdat(tsA)%wnd(i,j)%wspd, & -!/MPI wsdat(tsA)%lat(i,j), & -!/MPI wsdat(tsA)%lon(i,j)/) -!/MPI CALL MPI_SEND(COMMARR1,44,MPI_REAL,irank, & -!/MPI (tag1+1),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & -!/MPI/! rank,irank,(tag1+1) -!/MPI CALL MPI_RECV(COMMARR1,44,MPI_REAL,0,(tag1+1), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI wsdat(tsA)%par(i,j)%hs = COMMARR1(1:10) -!/MPI wsdat(tsA)%par(i,j)%tp = COMMARR1(11:20) -!/MPI wsdat(tsA)%par(i,j)%dir = COMMARR1(21:30) -!/MPI wsdat(tsA)%par(i,j)%dspr = COMMARR1(31:40) -!/MPI wsdat(tsA)%wnd(i,j)%wdir = COMMARR1(41) -!/MPI wsdat(tsA)%wnd(i,j)%wspd = COMMARR1(42) -!/MPI wsdat(tsA)%lat(i,j) = COMMARR1(43) -!/MPI wsdat(tsA)%lon(i,j) = COMMARR1(44) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.0) THEN -!/MPI CALL MPI_SEND(wsdat(tsA)%date,1, & -!/MPI MPI_DOUBLE_PRECISION,irank, & -!/MPI (tag1+2),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.irank) THEN -!/MPI CALL MPI_RECV(wsdat(tsA)%date,1, & -!/MPI MPI_DOUBLE_PRECISION,0,(tag1+2), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(6,*) '>> Sending: rank,irank,tag1=', & -!/MPI/! rank,irank,(tag1+3) -!/MPI COMMARR2 = (/wsdat(tsA)%par(i,j)%ipart(:), & -!/MPI wsdat(tsA)%par(i,j)%checked/) -!/MPI CALL MPI_SEND(COMMARR2,11, & -!/MPI MPI_INTEGER,irank,(tag1+3),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & -!/MPI/! rank,irank,(tag1+3) -!/MPI CALL MPI_RECV(COMMARR2,11, & -!/MPI MPI_INTEGER,0,(tag1+3), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI wsdat(tsA)%par(i,j)%ipart(:) = COMMARR2(1:10) -!/MPI wsdat(tsA)%par(i,j)%checked = COMMARR2(11) -!/MPI END IF -!/MPI -!/MPI END DO -!/MPI END DO -!/MPI END IF -!/MPI END DO -!/MPI -!/MPI CALL MPI_Barrier(MPI_COMM_WORLD,IERR) - - -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + END IF +#endif + +#ifdef W3_MPI +! Communicate the wsdat entries from rank=0 to other ranks + DO tsA = t0,maxTs + irank = MOD((tsA-t0),MIN(nproc,maxTS)) +! WRITE(20,*) 'Rank,irank=',rank,irank + IF (irank.NE.0) THEN +! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank + + IF (rank.EQ.irank) THEN + ALLOCATE(wsdat(tsA)%lat(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%lon(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%par(maxI,maxJ)) + ALLOCATE(wsdat(tsA)%wnd(maxI,maxJ)) + + DO j = 1,maxJ + DO i = 1,maxI + wsdat(tsA)%maxi=maxI + wsdat(tsA)%maxj=maxJ + wsdat(tsA)%par(i,j)%hs(1:10)=9999. + wsdat(tsA)%par(i,j)%tp(1:10)=9999. + wsdat(tsA)%par(i,j)%dir(1:10)=9999. + wsdat(tsA)%par(i,j)%dspr(1:10)=9999. + wsdat(tsA)%par(i,j)%ipart(1:10)=0 + wsdat(tsA)%par(i,j)%sys(1:10)=9999 ! 40.PAR Increase this array, or make allocatable + wsdat(tsA)%par(i,j)%ngbrSys(1:50)=9999 + wsdat(tsA)%wnd(i,j)%wdir=9999. + wsdat(tsA)%wnd(i,j)%wspd=9999. + wsdat(tsA)%par(i,j)%checked=-1 + END DO + END DO + END IF + + DO j = 1,maxJ + DO i = 1,maxI + tag1 = ((j-1)*maxI+i)*10 + + IF (rank.EQ.0) THEN +! WRITE(6,*) '>> Sending: rank,irank,tag1=', & +! rank,irank,(tag1+1) + COMMARR1 = (/wsdat(tsA)%par(i,j)%hs(:), & + wsdat(tsA)%par(i,j)%tp(:), & + wsdat(tsA)%par(i,j)%dir(:), & + wsdat(tsA)%par(i,j)%dspr(:), & + wsdat(tsA)%wnd(i,j)%wdir, & + wsdat(tsA)%wnd(i,j)%wspd, & + wsdat(tsA)%lat(i,j), & + wsdat(tsA)%lon(i,j)/) + CALL MPI_SEND(COMMARR1,44,MPI_REAL,irank, & + (tag1+1),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN +! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & +! rank,irank,(tag1+1) + CALL MPI_RECV(COMMARR1,44,MPI_REAL,0,(tag1+1), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + wsdat(tsA)%par(i,j)%hs = COMMARR1(1:10) + wsdat(tsA)%par(i,j)%tp = COMMARR1(11:20) + wsdat(tsA)%par(i,j)%dir = COMMARR1(21:30) + wsdat(tsA)%par(i,j)%dspr = COMMARR1(31:40) + wsdat(tsA)%wnd(i,j)%wdir = COMMARR1(41) + wsdat(tsA)%wnd(i,j)%wspd = COMMARR1(42) + wsdat(tsA)%lat(i,j) = COMMARR1(43) + wsdat(tsA)%lon(i,j) = COMMARR1(44) + END IF + + IF (rank.EQ.0) THEN + CALL MPI_SEND(wsdat(tsA)%date,1, & + MPI_DOUBLE_PRECISION,irank, & + (tag1+2),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN + CALL MPI_RECV(wsdat(tsA)%date,1, & + MPI_DOUBLE_PRECISION,0,(tag1+2), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.0) THEN +! WRITE(6,*) '>> Sending: rank,irank,tag1=', & +! rank,irank,(tag1+3) + COMMARR2 = (/wsdat(tsA)%par(i,j)%ipart(:), & + wsdat(tsA)%par(i,j)%checked/) + CALL MPI_SEND(COMMARR2,11, & + MPI_INTEGER,irank,(tag1+3),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.irank) THEN +! WRITE(6,*) '<< Receiving: rank,irank,tag1=', & +! rank,irank,(tag1+3) + CALL MPI_RECV(COMMARR2,11, & + MPI_INTEGER,0,(tag1+3), & + MPI_COMM_WORLD,MPI_STATUS,IERR) + wsdat(tsA)%par(i,j)%ipart(:) = COMMARR2(1:10) + wsdat(tsA)%par(i,j)%checked = COMMARR2(11) + END IF + + END DO + END DO + END IF + END DO + + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) +#endif + + +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif ! ----*** Test Output *** -------------------------------------------------- IF (testout) THEN !-----RAW PARTITION output: Coordinates @@ -1305,20 +1345,30 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & CLOSE(35) END IF -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ------------------------------------------------------------------------ ! Allocate the sysA structure -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(20,*) 'Allocating sysA...' -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ALLOCATE( sysA(maxTs) ) -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(20,*) 'SIZE(sysA) = ',SIZE(sysA) WRITE(6,1020) ' Number of time levels being processed:',SIZE(sysA) 1020 FORMAT(A,I4) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! Allocate maxSys ALLOCATE( maxSys(maxTs) ) @@ -1335,13 +1385,19 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & END IF ! Big loop over all time levels -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(6,*) 'Performing spatial tracking...' -!/MPI END IF -!/MPI/! WRITE(20,*) 'rank,t0,maxTs,nproc =',rank,t0,maxTs,nproc -!/MPI DO tsA = (t0+rank),maxTs,MIN(nproc,maxTS) -!/MPI/! WRITE(20,*) 'Computing: Rank, tsA =',rank,tsA -!/SHRD DO tsA = t0,maxTs +#ifdef W3_MPI + END IF +! WRITE(20,*) 'rank,t0,maxTs,nproc =',rank,t0,maxTs,nproc + DO tsA = (t0+rank),maxTs,MIN(nproc,maxTS) +! WRITE(20,*) 'Computing: Rank, tsA =',rank,tsA +#endif +#ifdef W3_SHRD + DO tsA = t0,maxTs +#endif WRITE(20,*) 'Call spiralTrackV3, tsA=',tsA,'...' CALL spiralTrackV3 ( wsdat(tsA), dirKnob, perKnob, wetPts, & @@ -1353,284 +1409,288 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & WRITE(20,*) SIZE(sysA(tsA)%sys) END DO -!/MPI CALL MPI_Barrier(MPI_COMM_WORLD,IERR) -!/MPI -!/MPI/!! Define communicator for array of integers in structure "system" -!/MPI/! DOMSIZE = maxI*maxJ -!/MPI/! WRITE(20,*) 'Rank',rank,'DOMSIZE =',DOMSIZE -!/MPI/! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_INTEGER,MPI_INT_DOMARR,IERR) -!/MPI/! CALL MPI_TYPE_COMMIT(MPI_INT_DOMARR,IERR) -!/MPI/! CALL MPI_TYPE_EXTENT(MPI_INT_DOMARR,EXTENT,IERR) -!/MPI/! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_INT_DOMARR, & -!/MPI/! size =',EXTENT -!/MPI -!/MPI/!! Define communicator for array of reals in structure "system" -!/MPI/! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_REAL,MPI_REAL_DOMARR,IERR) -!/MPI/! CALL MPI_TYPE_COMMIT(MPI_REAL_DOMARR,IERR) -!/MPI/! CALL MPI_TYPE_EXTENT(MPI_REAL_DOMARR,EXTENT,IERR) -!/MPI/! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_REAL_DOMARR, & -!/MPI/! size =',EXTENT -!/MPI -!/MPI/! Communicate results back to rank 0 -!/MPI DO tsA = t0,maxTs -!/MPI irank = MOD((tsA-t0),MIN(nproc,maxTS)) -!/MPI/! WRITE(20,*) 'Rank,irank=',rank,irank -!/MPI IF (irank.NE.0) THEN -!/MPI/! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank -!/MPI -!/MPI/! Send maxSys(tsA) at each time level to rank 0 -!/MPI tag1 = tsA -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! Send results from current rank to rank 0 (blocking) -!/MPI/! WRITE(20,*) '>> Sending: rank,tsA,tag1=',rank,tsA,tag1 -!/MPI CALL MPI_SEND(maxSys(tsA),1,MPI_INTEGER,0,tag1, & -!/MPI MPI_COMM_WORLD,IERR) -!/MPI/! WRITE(20,*) 'Rank, IERR=',rank,IERR -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tsA,tag1=',rank,tsA,tag1 -!/MPI CALL MPI_RECV(maxSys(tsA),1,MPI_INTEGER, & -!/MPI irank,tag1,MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI/! Allocate structure at this time level -!/MPI ALLOCATE( sysA(tsA)%sys(maxSys(tsA)) ) -!/MPI DO ic = 1,maxSys(tsA) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%i ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%j ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%lon ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%lat ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%hs ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%tp ) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%dir) -!/MPI NULLIFY( sysA(tsA)%sys(ic)%dspr) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%i(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%j(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%lon(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%lat(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%hs(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%tp(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%dir(maxI*maxJ) ) -!/MPI ALLOCATE( sysA(tsA)%sys(ic)%dspr(maxI*maxJ) ) -!/MPI sysA(tsA)%sys(ic)%i(:) = 9999 -!/MPI sysA(tsA)%sys(ic)%j(:) = 9999 -!/MPI sysA(tsA)%sys(ic)%lon(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%lat(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%hs(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%tp(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%dir(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%dspr(:) = 9999. -!/MPI sysA(tsA)%sys(ic)%hsMean = 9999. -!/MPI sysA(tsA)%sys(ic)%tpMean = 9999. -!/MPI sysA(tsA)%sys(ic)%dirMean = 9999. -!/MPI sysA(tsA)%sys(ic)%sysInd = 9999 -!/MPI sysA(tsA)%sys(ic)%nPoints = 9999 -!/MPI sysA(tsA)%sys(ic)%grp = 9999 -!/MPI END DO -!/MPI END IF -!/MPI -!/MPI/! Send data fields at each (tsA,ic) combination -!/MPI IF ((rank.EQ.0).OR.(rank.EQ.irank)) THEN -!/MPI DO ic = 1, maxSys(tsA) -!/MPI/! Construct a unique tag for each message -!/MPI tag2 = tsA*10000 + ic*100 -!/MPI DOMSIZE = maxI*maxJ -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+1) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & -!/MPI MPI_INTEGER,0,(tag2+1),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+1) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & -!/MPI MPI_INTEGER,irank,(tag2+1), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+2) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & -!/MPI MPI_INTEGER,0,(tag2+2),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+2) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & -!/MPI MPI_INTEGER,irank,(tag2+2), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+3) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+3),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+3) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+3), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+4) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+4),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+4) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+4), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+5) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+5),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+5) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+5), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+6) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+6),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+6) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+6), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+7) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+7),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+7) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+7), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+8) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & -!/MPI MPI_REAL,0,(tag2+8),MPI_COMM_WORLD,REQ(1),IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+8) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & -!/MPI MPI_REAL,irank,(tag2+8), & -!/MPI MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) -!/MPI END IF -!/MPI/! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+9) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & -!/MPI 0,(tag2+9),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+9) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & -!/MPI irank,(tag2+9),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+10) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & -!/MPI 0,(tag2+10),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+10) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & -!/MPI irank,(tag2+10),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+11) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & -!/MPI 0,(tag2+11),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+11) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & -!/MPI irank,(tag2+11),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+12) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& -!/MPI 0,(tag2+12),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+12) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& -!/MPI irank,(tag2+12),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+13) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& -!/MPI 0,(tag2+13),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+13) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& -!/MPI irank,(tag2+13),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI -!/MPI IF (rank.EQ.irank) THEN -!/MPI/! WRITE(20,*) '>> Sending: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+14) -!/MPI CALL MPI_SEND(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& -!/MPI 0,(tag2+14),MPI_COMM_WORLD,IERR) -!/MPI END IF -!/MPI IF (rank.EQ.0) THEN -!/MPI/! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & -!/MPI/! rank,irank,(tag2+14) -!/MPI CALL MPI_RECV(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& -!/MPI irank,(tag2+14),MPI_COMM_WORLD,MPI_STATUS,IERR) -!/MPI END IF -!/MPI END DO -!/MPI END IF -!/MPI END IF -!/MPI END DO -!/MPI -!/MPI CALL MPI_Barrier(MPI_COMM_WORLD,IERR) -!/MPI -!/MPI/! CALL MPI_TYPE_FREE(MPI_INT_DOMARR,IERR) -!/MPI/! CALL MPI_TYPE_FREE(MPI_REAL_DOMARR,IERR) -!/MPI - -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + +!! Define communicator for array of integers in structure "system" +! DOMSIZE = maxI*maxJ +! WRITE(20,*) 'Rank',rank,'DOMSIZE =',DOMSIZE +! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_INTEGER,MPI_INT_DOMARR,IERR) +! CALL MPI_TYPE_COMMIT(MPI_INT_DOMARR,IERR) +! CALL MPI_TYPE_EXTENT(MPI_INT_DOMARR,EXTENT,IERR) +! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_INT_DOMARR, & +! size =',EXTENT + +!! Define communicator for array of reals in structure "system" +! CALL MPI_TYPE_CONTIGUOUS(DOMSIZE,MPI_REAL,MPI_REAL_DOMARR,IERR) +! CALL MPI_TYPE_COMMIT(MPI_REAL_DOMARR,IERR) +! CALL MPI_TYPE_EXTENT(MPI_REAL_DOMARR,EXTENT,IERR) +! WRITE(20,*) 'Rank',rank,'has set up communicator MPI_REAL_DOMARR, & +! size =',EXTENT + +! Communicate results back to rank 0 + DO tsA = t0,maxTs + irank = MOD((tsA-t0),MIN(nproc,maxTS)) +! WRITE(20,*) 'Rank,irank=',rank,irank + IF (irank.NE.0) THEN +! WRITE(20,*) 'Communicating for Rank,irank=',rank,irank + +! Send maxSys(tsA) at each time level to rank 0 + tag1 = tsA + IF (rank.EQ.irank) THEN +! Send results from current rank to rank 0 (blocking) +! WRITE(20,*) '>> Sending: rank,tsA,tag1=',rank,tsA,tag1 + CALL MPI_SEND(maxSys(tsA),1,MPI_INTEGER,0,tag1, & + MPI_COMM_WORLD,IERR) +! WRITE(20,*) 'Rank, IERR=',rank,IERR + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tsA,tag1=',rank,tsA,tag1 + CALL MPI_RECV(maxSys(tsA),1,MPI_INTEGER, & + irank,tag1,MPI_COMM_WORLD,MPI_STATUS,IERR) +! Allocate structure at this time level + ALLOCATE( sysA(tsA)%sys(maxSys(tsA)) ) + DO ic = 1,maxSys(tsA) + NULLIFY( sysA(tsA)%sys(ic)%i ) + NULLIFY( sysA(tsA)%sys(ic)%j ) + NULLIFY( sysA(tsA)%sys(ic)%lon ) + NULLIFY( sysA(tsA)%sys(ic)%lat ) + NULLIFY( sysA(tsA)%sys(ic)%hs ) + NULLIFY( sysA(tsA)%sys(ic)%tp ) + NULLIFY( sysA(tsA)%sys(ic)%dir) + NULLIFY( sysA(tsA)%sys(ic)%dspr) + ALLOCATE( sysA(tsA)%sys(ic)%i(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%j(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%lon(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%lat(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%hs(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%tp(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%dir(maxI*maxJ) ) + ALLOCATE( sysA(tsA)%sys(ic)%dspr(maxI*maxJ) ) + sysA(tsA)%sys(ic)%i(:) = 9999 + sysA(tsA)%sys(ic)%j(:) = 9999 + sysA(tsA)%sys(ic)%lon(:) = 9999. + sysA(tsA)%sys(ic)%lat(:) = 9999. + sysA(tsA)%sys(ic)%hs(:) = 9999. + sysA(tsA)%sys(ic)%tp(:) = 9999. + sysA(tsA)%sys(ic)%dir(:) = 9999. + sysA(tsA)%sys(ic)%dspr(:) = 9999. + sysA(tsA)%sys(ic)%hsMean = 9999. + sysA(tsA)%sys(ic)%tpMean = 9999. + sysA(tsA)%sys(ic)%dirMean = 9999. + sysA(tsA)%sys(ic)%sysInd = 9999 + sysA(tsA)%sys(ic)%nPoints = 9999 + sysA(tsA)%sys(ic)%grp = 9999 + END DO + END IF + +! Send data fields at each (tsA,ic) combination + IF ((rank.EQ.0).OR.(rank.EQ.irank)) THEN + DO ic = 1, maxSys(tsA) +! Construct a unique tag for each message + tag2 = tsA*10000 + ic*100 + DOMSIZE = maxI*maxJ + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+1) + CALL MPI_SEND(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & + MPI_INTEGER,0,(tag2+1),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+1) + CALL MPI_RECV(sysA(tsA)%sys(ic)%i(:),DOMSIZE, & + MPI_INTEGER,irank,(tag2+1), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+2) + CALL MPI_SEND(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & + MPI_INTEGER,0,(tag2+2),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+2) + CALL MPI_RECV(sysA(tsA)%sys(ic)%j(:),DOMSIZE, & + MPI_INTEGER,irank,(tag2+2), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+3) + CALL MPI_SEND(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & + MPI_REAL,0,(tag2+3),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+3) + CALL MPI_RECV(sysA(tsA)%sys(ic)%lon(:),DOMSIZE, & + MPI_REAL,irank,(tag2+3), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+4) + CALL MPI_SEND(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & + MPI_REAL,0,(tag2+4),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+4) + CALL MPI_RECV(sysA(tsA)%sys(ic)%lat(:),DOMSIZE, & + MPI_REAL,irank,(tag2+4), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+5) + CALL MPI_SEND(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & + MPI_REAL,0,(tag2+5),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+5) + CALL MPI_RECV(sysA(tsA)%sys(ic)%hs(:),DOMSIZE, & + MPI_REAL,irank,(tag2+5), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+6) + CALL MPI_SEND(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & + MPI_REAL,0,(tag2+6),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+6) + CALL MPI_RECV(sysA(tsA)%sys(ic)%tp(:),DOMSIZE, & + MPI_REAL,irank,(tag2+6), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+7) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & + MPI_REAL,0,(tag2+7),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+7) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dir(:),DOMSIZE, & + MPI_REAL,irank,(tag2+7), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,tag2=',rank,(tag2+8) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & + MPI_REAL,0,(tag2+8),MPI_COMM_WORLD,REQ(1),IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,tag2=',rank,(tag2+8) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dspr(:),DOMSIZE, & + MPI_REAL,irank,(tag2+8), & + MPI_COMM_WORLD,MPI_STATUS,REQ(2),IERR) + END IF +! CALL MPI_WAITALL(2,REQ,ISTAT,IERR) + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+9) + CALL MPI_SEND(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & + 0,(tag2+9),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+9) + CALL MPI_RECV(sysA(tsA)%sys(ic)%hsMean,1,MPI_REAL, & + irank,(tag2+9),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+10) + CALL MPI_SEND(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & + 0,(tag2+10),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+10) + CALL MPI_RECV(sysA(tsA)%sys(ic)%tpMean,1,MPI_REAL, & + irank,(tag2+10),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+11) + CALL MPI_SEND(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & + 0,(tag2+11),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+11) + CALL MPI_RECV(sysA(tsA)%sys(ic)%dirMean,1,MPI_REAL, & + irank,(tag2+11),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+12) + CALL MPI_SEND(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& + 0,(tag2+12),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+12) + CALL MPI_RECV(sysA(tsA)%sys(ic)%sysInd,1,MPI_INTEGER,& + irank,(tag2+12),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+13) + CALL MPI_SEND(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& + 0,(tag2+13),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+13) + CALL MPI_RECV(sysA(tsA)%sys(ic)%nPoints,1,MPI_INTEGER,& + irank,(tag2+13),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + + IF (rank.EQ.irank) THEN +! WRITE(20,*) '>> Sending: rank,irank,tag2=', & +! rank,irank,(tag2+14) + CALL MPI_SEND(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& + 0,(tag2+14),MPI_COMM_WORLD,IERR) + END IF + IF (rank.EQ.0) THEN +! WRITE(20,*) '<< Receiving: rank,irank,tag2=', & +! rank,irank,(tag2+14) + CALL MPI_RECV(sysA(tsA)%sys(ic)%grp,1,MPI_INTEGER,& + irank,(tag2+14),MPI_COMM_WORLD,MPI_STATUS,IERR) + END IF + END DO + END IF + END IF + END DO + + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) + +! CALL MPI_TYPE_FREE(MPI_INT_DOMARR,IERR) +! CALL MPI_TYPE_FREE(MPI_REAL_DOMARR,IERR) + +#endif + +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(6,*) 'Performing temporal tracking...' WRITE(20,*) 'Calling timeTrackingV2...' lonext = wsdat(1)%lon(maxI,1)-wsdat(1)%lon(1,1) @@ -1639,7 +1699,9 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & CALL timeTrackingV2 (sysA, maxSys, tpTimeKnob, dirTimeKnob, 1, & maxGroup, dt, lonext, latext, maxI, maxJ) ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! RETURN ! diff --git a/model/ftn/w3swldmd.ftn b/model/src/w3swldmd.F90 similarity index 97% rename from model/ftn/w3swldmd.ftn rename to model/src/w3swldmd.F90 index b1d828174..f4ee16b5f 100644 --- a/model/ftn/w3swldmd.ftn +++ b/model/src/w3swldmd.F90 @@ -128,7 +128,9 @@ SUBROUTINE W3SWL4 (A, CG, WN, DAIR, S, D) !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: GRAV, DWAT USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG2, DDEN, FTE, SWL6B1 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -139,7 +141,9 @@ SUBROUTINE W3SWL4 (A, CG, WN, DAIR, S, D) !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IKN(NK), ITH REAL, PARAMETER :: VA = 1.4E-5 ! Air kinematic viscosity (used in WAM). REAL :: EB(NK), WN2(NSPEC), EMEAN @@ -147,7 +151,9 @@ SUBROUTINE W3SWL4 (A, CG, WN, DAIR, S, D) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SWL4') +#ifdef W3_S + CALL STRACE (IENT, 'W3SWL4') +#endif ! IKN = IRANGE(1,NSPEC,NTH) D = 0. @@ -265,8 +271,12 @@ SUBROUTINE W3SWL6 (A, CG, WN, S, D) USE CONSTANTS, ONLY: GRAV USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, DDEN, DTH USE W3GDATMD, ONLY: SWL6CSTB1, SWL6B1, FTE, FTWN -!/T6 USE W3ODATMD, ONLY: NDST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_T6 + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ @@ -277,14 +287,18 @@ SUBROUTINE W3SWL6 (A, CG, WN, S, D) !/ !/ ------------------------------------------------------------------- / !/ Local parameters -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IK, ITH, IKN(NK) REAL, DIMENSION(NK) :: ABAND, KMAX, ANAR, BN, AORB, DDIS REAL :: K(NTH,NK), B1 !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3SWL6') +#ifdef W3_S + CALL STRACE (IENT, 'W3SWL6') +#endif ! !/ 0) --- Initialize parameters -------------------------------------- / IKN = IRANGE(1,NSPEC,NTH) ! Index vector for array access, e.g. diff --git a/model/ftn/w3tidemd.ftn b/model/src/w3tidemd.F90 similarity index 99% rename from model/ftn/w3tidemd.ftn rename to model/src/w3tidemd.F90 index 14aea8209..e24254786 100644 --- a/model/ftn/w3tidemd.ftn +++ b/model/src/w3tidemd.F90 @@ -290,7 +290,9 @@ SUBROUTINE TIDE_FIND_INDICES_PREDICTION(LIST,INDS,TIDE_PRMF) ! USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT USE W3ODATMD, ONLY: NDSE, NDSO -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ ------------------------------------------------------------------- / IMPLICIT NONE !/ @@ -301,9 +303,13 @@ SUBROUTINE TIDE_FIND_INDICES_PREDICTION(LIST,INDS,TIDE_PRMF) INTEGER, INTENT(OUT) :: INDS(70), TIDE_PRMF INTEGER J, FOUND -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/S CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') +#ifdef W3_S + CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') +#endif ! TIDE_PRMF=0 IF (TRIM(LIST(1)).EQ.'VFAST' .OR. TRIM(LIST(1)).EQ.'FAST') THEN @@ -382,7 +388,9 @@ SUBROUTINE TIDE_FIND_INDICES_ANALYSIS(LIST) ! USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT USE W3ODATMD, ONLY: NDSE, NDSO -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! !/ ------------------------------------------------------------------- / IMPLICIT NONE @@ -396,9 +404,13 @@ SUBROUTINE TIDE_FIND_INDICES_ANALYSIS(LIST) CHARACTER(LEN=5) :: TIDECON_NAME_ALL(65) ! array of names of tidal constituents REAL :: TIDE_FREQC_ALL(65) ! array of freq. of tidal constituents INTEGER :: INDS(65), J, FOUND, NTIDES -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! -!/S CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') +#ifdef W3_S + CALL STRACE (IENT, 'TIDE_FIND_INDICES_PREDICTION') +#endif ! TIDECON_NAME_ALL(:)=(/ & 'Z0 ', 'SSA ', 'MSM ', 'MM ', 'MSF ', 'MF ', 'ALP1 ', '2Q1 ', 'SIG1 ', 'Q1 ', & @@ -768,11 +780,17 @@ SUBROUTINE TIDE_READ_ANAPAR(KR1,LP,filename,KD1,KD2,XLON,XLAT,NDEF,ITREND,ITZ) ALLOCATE(TIDE_FREQC(TIDE_MF),TIDECON_NAME(TIDE_MF)) ! ndef=1 if only 1D field to be analysed (eg., elevations) ! ndef=2 if 2D field: velocity components, EW followed by NS : this is now de-activated -!/T WRITE(6,*) ' number of constituents & degrees of freedom=',TIDE_MF,ndef +#ifdef W3_T + WRITE(6,*) ' number of constituents & degrees of freedom=',TIDE_MF,ndef +#endif IF (itrend.eq.1) then -!/T WRITE(6,*) ' a linear trend is included in the analysis' +#ifdef W3_T + WRITE(6,*) ' a linear trend is included in the analysis' +#endif else -!/T WRITE(6,*) ' no linear trend is included' +#ifdef W3_T + WRITE(6,*) ' no linear trend is included' +#endif END IF ! TIDE_MF= number of consituents, excluding linear trend. The constant ! term, Z0 should be first in the list. @@ -782,10 +800,14 @@ SUBROUTINE TIDE_READ_ANAPAR(KR1,LP,filename,KD1,KD2,XLON,XLAT,NDEF,ITREND,ITZ) 10 FORMAT(2I5,F5.2) READ(KR1,11) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) -!/T WRITE(6,*) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) +#ifdef W3_T + WRITE(6,*) (TIDECON_NAME(I),TIDE_FREQC(I),I=1,TIDE_MF) +#endif 11 FORMAT(4x,A5,F16.10) READ(KR1,7) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 -!/T WRITE(6,*) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 +#ifdef W3_T + WRITE(6,*) ID1,IM1,IY1,ID2,IM2,IY2,IC1,IC2 +#endif IF (IC1.EQ.0) IC1=19 IF (IC2.EQ.0) IC2=19 7 FORMAT(16I5) @@ -2235,7 +2257,9 @@ subroutine flex_tidana_webpage(IX,IY,XLON,XLAT,KD1,KD2,ndef, itrend, RES, SSQ, R END DO ! j END DO !i -!/T WRITE(6,*) 'assembled overdetermined matrix and/or rhs' +#ifdef W3_T + WRITE(6,*) 'assembled overdetermined matrix and/or rhs' +#endif NMAX=M MEQ=N SSQ(IDEF)=1.0 @@ -2274,7 +2298,9 @@ subroutine flex_tidana_webpage(IX,IY,XLON,XLAT,KD1,KD2,ndef, itrend, RES, SSQ, R write(NDSET,*) ' underdetermined system: no svd solution',IX,IY,meq,m stop END IF -!/T WRITE(6,*) ' applying svd' +#ifdef W3_T + WRITE(6,*) ' applying svd' +#endif CALL SVD(Q,U,V,COV,W,P,B,SIG,ICODE,MEQ,NMAX,NMAXPM,NMAXP1,TOLER & ,JCODE,SSQ(IDEF),RES(IDEF)) ! IF (JCODE.GT.0) WRITE(LP,55)JCODE diff --git a/model/ftn/w3timemd.ftn b/model/src/w3timemd.F90 similarity index 97% rename from model/ftn/w3timemd.ftn rename to model/src/w3timemd.F90 index 0575df230..43bae0c02 100644 --- a/model/ftn/w3timemd.ftn +++ b/model/src/w3timemd.F90 @@ -68,7 +68,9 @@ MODULE W3TIMEMD ! !/ ------------------------------------------------------------------- / !/ -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! PUBLIC ! @@ -141,11 +143,15 @@ SUBROUTINE TICK21 ( TIME, DTIME ) !/ Local parameters !/ INTEGER :: NYMD, NHMS, NSEC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'TICK21') +#ifdef W3_S + CALL STRACE (IENT, 'TICK21') +#endif ! ! Zero increment: get "legal" date ! @@ -250,12 +256,16 @@ INTEGER FUNCTION IYMD21 ( NYMD ,M ) !/ INTEGER :: NY, NM, ND INTEGER, SAVE :: NDPM(12) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: LEAP !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'IYMD21') +#ifdef W3_S + CALL STRACE (IENT, 'IYMD21') +#endif ! ! Declare the number of days in month depending on calendar ! @@ -385,11 +395,15 @@ REAL FUNCTION DSEC21 ( TIME1, TIME2 ) !/ INTEGER :: NY1, ND1, NY2, ND2, NS1, NS2, NS, & ND, NST -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'DSEC21') +#ifdef W3_S + CALL STRACE (IENT, 'DSEC21') +#endif ! ! Convert dates and times : ! @@ -503,12 +517,16 @@ INTEGER FUNCTION MYMD21 ( NYMD ) !/ INTEGER :: NY, NM, ND INTEGER, SAVE :: NDPM(12) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: LEAP !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'MYMD21') +#ifdef W3_S + CALL STRACE (IENT, 'MYMD21') +#endif ! ! Declare the number of days in month depending on calendar ! @@ -628,11 +646,15 @@ REAL FUNCTION TDIFF ( T1, T2 ) !/ INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 REAL :: E1, E2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'TDIFF') +#ifdef W3_S + CALL STRACE (IENT, 'TDIFF') +#endif ! ! Convert dates and times : ! @@ -878,11 +900,15 @@ REAL(KIND=8) FUNCTION TIME2HOURS(TIME) !/ INTEGER :: IY,IMO,ID,IH,IMI,IS INTEGER(KIND=4) :: JDAY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'TICK21') +#ifdef W3_S + CALL STRACE (IENT, 'TICK21') +#endif ! ! Zero increment: get "legal" date ! @@ -1094,11 +1120,15 @@ SUBROUTINE T2D(TIME,DAT,IERR) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'T2D') +#ifdef W3_S + CALL STRACE (IENT, 'T2D') +#endif ! DAT(1)=TIME(1)/10000 DAT(2)=(TIME(1)-DAT(1)*10000)/100 @@ -1171,11 +1201,15 @@ SUBROUTINE D2T(DAT,TIME,IERR) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'D2T') +#ifdef W3_S + CALL STRACE (IENT, 'D2T') +#endif ! TIME(1)=DAT(1)*10000+DAT(2)*100+DAT(3) TIME(2)=DAT(5)*10000+DAT(6)*100+DAT(7) @@ -1259,11 +1293,15 @@ SUBROUTINE D2J(DAT,JULIAN,IERR) INTEGER :: YEAR, MONTH, DAY, UTC, HOUR, MINUTE REAL :: SECOND INTEGER :: A, Y, M, JDN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'D2J') +#ifdef W3_S + CALL STRACE (IENT, 'D2J') +#endif ! YEAR = DAT(1) ! Year MONTH = DAT(2) ! Month @@ -1370,11 +1408,15 @@ SUBROUTINE J2D(JULIAN,DAT,IERR) REAL :: SECOND INTEGER :: YEAR, MONTH, DAY, HOUR, MINUTE INTEGER :: JALPHA,JA,JB,JC,JD,JE,IJUL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'J2D') +#ifdef W3_S + CALL STRACE (IENT, 'J2D') +#endif ! IF(JULIAN.LT.0.d0) THEN ! Negative Julian Day not allowed IERR=1 @@ -1502,11 +1544,15 @@ DOUBLE PRECISION FUNCTION TSUB ( T1, T2 ) !/ INTEGER :: A1, B1, C1, D1, A2, B2, C2, D2 DOUBLE PRECISION :: E1, E2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'TSUB') +#ifdef W3_S + CALL STRACE (IENT, 'TSUB') +#endif ! ! Convert dates and times : ! @@ -1599,11 +1645,15 @@ DOUBLE PRECISION FUNCTION TSUBSEC ( T1, T2 ) !/ INTEGER(KIND=8) :: A1, B1, C1, D1, A2, B2, C2, D2 INTEGER(KIND=8) :: E1, E2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'TSUBSEC') +#ifdef W3_S + CALL STRACE (IENT, 'TSUBSEC') +#endif ! IF (TRIM(CALTYPE) .EQ. '360_day' ) THEN A1 = (T2(1)-T1(1))*360 + (T2(2)-T1(2))*30 + (T2(3)-T1(3)) @@ -1700,11 +1750,15 @@ SUBROUTINE U2D(UNITS,DAT,IERR) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'U2D') +#ifdef W3_S + CALL STRACE (IENT, 'U2D') +#endif ! DAT(4) = 0 ! force to UTC timezone @@ -1941,11 +1995,15 @@ SUBROUTINE T2ISO(TIME,ISODT) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'T2ISO') +#ifdef W3_S + CALL STRACE (IENT, 'T2ISO') +#endif ! !/ WRITE(ISODT,'(I4,"-",I2.2,"-",I2.2,"T",I2.2,":",I2.2,":",I2.2)') & diff --git a/model/ftn/w3triamd.ftn b/model/src/w3triamd.F90 similarity index 91% rename from model/ftn/w3triamd.ftn rename to model/src/w3triamd.F90 index 603dba11d..34065fc3c 100644 --- a/model/ftn/w3triamd.ftn +++ b/model/src/w3triamd.F90 @@ -203,8 +203,10 @@ SUBROUTINE READMSH(NDS,FNAME) INTEGER(KIND=4),ALLOCATABLE :: IFOUND(:), VERTEX(:), BOUNDTMP(:) DOUBLE PRECISION, ALLOCATABLE :: XYBTMP1(:,:),XYBTMP2(:,:) REAL :: z -!/DEBUGINIT WRITE(740+IAPROC,*) 'Beginning of READMSH routine' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Beginning of READMSH routine' + FLUSH(740+IAPROC) +#endif OPEN(NDS,FILE = FNAME,STATUS='old') READ (NDS,'(A)') COMSTR @@ -213,7 +215,9 @@ SUBROUTINE READMSH(NDS,FNAME) READ(NDS,*) i,j,k CALL NEXTLN(COMSTR, NDS, NDSE) LPDLIB = .FALSE. -!/PDLIB LPDLIB = .TRUE. +#ifdef W3_PDLIB + LPDLIB = .TRUE. +#endif ! ! read number of nodes and nodes from Gmsh files ! @@ -311,9 +315,11 @@ SUBROUTINE READMSH(NDS,FNAME) !count points connections to allocate array in W3DIMUG ! CALL COUNT(TRIGPTMP2) -!/DEBUGINIT WRITE(*,*) 'Call W3DIMUG from READMSH' -!/DEBUGINIT WRITE(740+IAPROC,*) 'Call W3DIMUG from READMSH' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(*,*) 'Call W3DIMUG from READMSH' + WRITE(740+IAPROC,*) 'Call W3DIMUG from READMSH' + FLUSH(740+IAPROC) +#endif CALL W3DIMUG ( 1, NTRI, NX, COUNTOT, NNZ, NDSE, NDST ) ! ! fills arrays @@ -324,11 +330,13 @@ SUBROUTINE READMSH(NDS,FNAME) XYB(I,3) = XYBTMP2(I,3) END DO ! -!/DEBUGSTP WRITE(740,*) 'Writing XYB(:,3)' -!/DEBUGSTP DO I=1,NX -!/DEBUGSTP WRITE(740,*) 'I,XYB(I,3)=', I, XYB(I,3) -!/DEBUGSTP END DO -!/DEBUGSTP FLUSH(740) +#ifdef W3_DEBUGSTP + WRITE(740,*) 'Writing XYB(:,3)' + DO I=1,NX + WRITE(740,*) 'I,XYB(I,3)=', I, XYB(I,3) + END DO + FLUSH(740) +#endif ! DO I=1, NTRI ITMP = TRIGPTMP2(I,:) @@ -395,11 +403,15 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! -!/PDLIB use yowElementpool, only: ne_global, INE_global -!/PDLIB use yowNodepool, only: np_global +#ifdef W3_PDLIB + use yowElementpool, only: ne_global, INE_global + use yowNodepool, only: np_global +#endif USE W3GDATMD, ONLY : TRIGP, NTRI, NX IMPLICIT NONE !/ @@ -409,7 +421,9 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -418,7 +432,9 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) INTEGER :: COLLECTED(NX), NEXTVERT(NX), PREVVERT(NX) INTEGER :: ISFINISHED, INEXT, IPREV INTEGER :: IPNEXT, IPPREV, ZNEXT, IP, I, IE -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif STATUS(:) = 0 DO IE=1,NTRI DO I=1,3 @@ -540,7 +556,9 @@ SUBROUTINE READMSHOBC(NDS, FNAME, TMPSTA, UGOBCOK) USE W3GDATMD, ONLY: NX, NY, CCON , COUNTCON USE W3ODATMD, ONLY: NDSE, NDST, NDSO USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -641,14 +659,18 @@ SUBROUTINE UG_GETOPENBOUNDARY(TMPSTA,ZBIN,ZLIM) ! 10. Source code : USE W3GDATMD, ONLY: NX, NY, CCON, COUNTCON, IOBP -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / !/ Parameter list !/ INTEGER, INTENT(INOUT) :: TMPSTA(NY,NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL , INTENT(IN) :: ZBIN(NY,NX) REAL , INTENT(IN) :: ZLIM !/ @@ -661,7 +683,9 @@ SUBROUTINE UG_GETOPENBOUNDARY(TMPSTA,ZBIN,ZLIM) MASK(:)=1 CALL SET_IOBP (MASK, STATUS) ! -!/S CALL STRACE (IENT, 'UG_GETOPENBOUNDARY') +#ifdef W3_S + CALL STRACE (IENT, 'UG_GETOPENBOUNDARY') +#endif DO IBC = 1, N_OUTSIDE_BOUNDARY IX = OUTSIDE_BOUNDARY(IBC) !write(*,*) 'TEST1', IX, TMPSTA(1,IX), CCON(IX), COUNTCON(IX), ZBIN(1,IX), ZLIM @@ -728,7 +752,9 @@ SUBROUTINE SPATIAL_GRID ! !/ ------------------------------------------------------------------- / USE W3GDATMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY: NDSE IMPLICIT NONE @@ -740,9 +766,13 @@ SUBROUTINE SPATIAL_GRID INTEGER :: K REAL*8 :: PT(3,2) -!/S INTEGER :: IENT = 0 +#ifdef W3_S + INTEGER :: IENT = 0 +#endif !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'SPATIAL_GRID') +#ifdef W3_S + CALL STRACE (IENT, 'SPATIAL_GRID') +#endif DO K = 1, NTRI @@ -822,7 +852,9 @@ SUBROUTINE NVECTRI ! !/ ------------------------------------------------------------------- / USE W3GDATMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE CONSTANTS IMPLICIT NONE @@ -837,9 +869,13 @@ SUBROUTINE NVECTRI REAL*8 :: TMP(3) REAL*8 :: TMPINV(3) REAL*8 :: PT(3,2) -!/S INTEGER :: IENT = 0 +#ifdef W3_S + INTEGER :: IENT = 0 +#endif !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'NVECTRI') +#ifdef W3_S + CALL STRACE (IENT, 'NVECTRI') +#endif DO IE = 1, NTRI @@ -945,7 +981,9 @@ SUBROUTINE COUNT(TRIGPTEMP) ! !/ ------------------------------------------------------------------- / USE W3GDATMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -957,10 +995,14 @@ SUBROUTINE COUNT(TRIGPTEMP) INTEGER :: CONN(NX) INTEGER :: COUNTER, IP, IE, I, J, N(3) -!/S INTEGER :: IENT = 0 +#ifdef W3_S + INTEGER :: IENT = 0 +#endif !/------------------------------------------------------------------------ -!/S CALL STRACE (IENT, 'COUNT') +#ifdef W3_S + CALL STRACE (IENT, 'COUNT') +#endif COUNTRI=0 COUNTOT=0 @@ -1035,12 +1077,18 @@ SUBROUTINE COORDMAX ! !/ ------------------------------------------------------------------- / USE W3GDATMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE -!/S INTEGER :: IENT = 0 +#ifdef W3_S + INTEGER :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'COORDMAX') +#ifdef W3_S + CALL STRACE (IENT, 'COORDMAX') +#endif ! ! maximum of coordinates s ! @@ -1110,7 +1158,9 @@ SUBROUTINE AREA_SI(IMOD) !/ ------------------------------------------------------------------- / USE W3GDATMD -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ input @@ -1127,10 +1177,14 @@ SUBROUTINE AREA_SI(IMOD) DOUBLE PRECISION :: TRIA03 INTEGER, ALLOCATABLE :: PTABLE(:,:) -!/S INTEGER :: IENT = 0 +#ifdef W3_S + INTEGER :: IENT = 0 +#endif !/ ------------------------------------------------------------------- / -!/S CALL STRACE (IENT, 'AREA_SI') +#ifdef W3_S + CALL STRACE (IENT, 'AREA_SI') +#endif WRITE(*,'("+TRACE......",A)') 'COMPUTE SI, TRIA und CCON' @@ -1407,7 +1461,9 @@ SUBROUTINE IS_IN_UNGRID(IMOD, XTIN, YTIN, ITOUT, IS, JS, RW) !/ ------------------------------------------------------------------- / USE W3GDATMD USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY: NDSE IMPLICIT NONE @@ -1429,8 +1485,10 @@ SUBROUTINE IS_IN_UNGRID(IMOD, XTIN, YTIN, ITOUT, IS, JS, RW) INTEGER :: ITRI INTEGER :: I1, I2, I3 INTEGER :: nbFound -!/S INTEGER :: IENT = 0 -!/S CALL STRACE (IENT, 'IS_IN_UNGRID') +#ifdef W3_S + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'IS_IN_UNGRID') +#endif ! itout = 0 @@ -1581,7 +1639,9 @@ SUBROUTINE IS_IN_UNGRID2(IMOD, XTIN, YTIN, FORCE, ITOUT, IS, JS, RW) !/ ------------------------------------------------------------------- / USE W3GDATMD USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3ODATMD, ONLY: NDSE IMPLICIT NONE @@ -1603,8 +1663,10 @@ SUBROUTINE IS_IN_UNGRID2(IMOD, XTIN, YTIN, FORCE, ITOUT, IS, JS, RW) INTEGER :: I1, I2, I3 INTEGER :: nbFound LOGICAL :: MAPSTAOK -!/S INTEGER :: IENT = 0 -!/S CALL STRACE (IENT, 'IS_IN_UNGRID2') +#ifdef W3_S + INTEGER :: IENT = 0 + CALL STRACE (IENT, 'IS_IN_UNGRID2') +#endif ! itout = 0 @@ -1743,9 +1805,11 @@ SUBROUTINE UG_GRADIENTS (PARAM, DIFFX, DIFFY) USE W3GDATMD, ONLY : TRIGP, NTRI, NX, NSEA, MAPFS, CLATIS, & MAPSTA, ANGLE, FLAGLL, IOBP, IEN, TRIA, NSEAL, NTRI USE W3ADATMD, ONLY : NSEALM -!/PDLIB USE yowElementpool -!/PDLIB use yowNodepool, only: PDLIB_IEN, PDLIB_TRIA, NPA -!/PDLIB USE yowExchangeModule, only : PDLIB_exchange1Dreal +#ifdef W3_PDLIB + USE yowElementpool + use yowNodepool, only: PDLIB_IEN, PDLIB_TRIA, NPA + USE yowExchangeModule, only : PDLIB_exchange1Dreal +#endif IMPLICIT NONE @@ -1773,7 +1837,9 @@ SUBROUTINE UG_GRADIENTS (PARAM, DIFFX, DIFFY) FACT=1. END IF -!/PDLIB IF (.NOT. LPDLIB) THEN +#ifdef W3_PDLIB + IF (.NOT. LPDLIB) THEN +#endif WEI = 0. DO IE = 1, NTRI NI = TRIGP(IE,:) @@ -1797,35 +1863,37 @@ SUBROUTINE UG_GRADIENTS (PARAM, DIFFX, DIFFY) END DO DIFFX(1,:) = DIFFX(1,:)/WEI DIFFY(1,:) = DIFFY(1,:)/WEI -!/PDLIB ELSE -!/PDLIB WEI_LOCAL = 0. -!/PDLIB DO IE = 1, NE -!/PDLIB NI = INE(:,IE) -!/PDLIB IE_GL = IELG(IE) -!/PDLIB NI_GL = INE_GLOBAL(:,IE_GL) -!/PDLIB LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI_GL))) -!/PDLIB WEI_LOCAL(NI) = WEI_LOCAL(NI) + 2.*PDLIB_TRIA(IE) -!/PDLIB IF (PDLIB_TRIA(IE) .LT. TINY(1.)) THEN -!/PDLIB WRITE(*,*) 'AREA SMALLER ZERO', IE, NTRI, PDLIB_TRIA(IE) -!/PDLIB STOP -!/PDLIB ENDIF -!/PDLIB DEDX(1) = PDLIB_IEN(1,IE) -!/PDLIB DEDX(2) = PDLIB_IEN(3,IE) -!/PDLIB DEDX(3) = PDLIB_IEN(5,IE) -!/PDLIB DEDY(1) = PDLIB_IEN(2,IE) -!/PDLIB DEDY(2) = PDLIB_IEN(4,IE) -!/PDLIB DEDY(3) = PDLIB_IEN(6,IE) -!/PDLIB VAR = PARAM(MAPFS(1,NI_GL)) * FACT -!/PDLIB DVDXIE = DOT_PRODUCT(VAR,DEDX) -!/PDLIB DVDYIE = DOT_PRODUCT(VAR,DEDY) -!/PDLIB DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN ! AR: This must be correctly computer later ... -!/PDLIB DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE -!/PDLIB END DO -!/PDLIB DIFFX(1,:) = DIFFX(1,:)/WEI_LOCAL -!/PDLIB DIFFY(1,:) = DIFFY(1,:)/WEI_LOCAL -!/PDLIB ENDIF -!/PDLIB CALL PDLIB_exchange1Dreal(DIFFX(1,1:NPA)) -!/PDLIB CALL PDLIB_exchange1Dreal(DIFFY(1,1:NPA)) +#ifdef W3_PDLIB + ELSE + WEI_LOCAL = 0. + DO IE = 1, NE + NI = INE(:,IE) + IE_GL = IELG(IE) + NI_GL = INE_GLOBAL(:,IE_GL) + LATMEAN = 1./3. * SUM(CLATIS(MAPFS(1,NI_GL))) + WEI_LOCAL(NI) = WEI_LOCAL(NI) + 2.*PDLIB_TRIA(IE) + IF (PDLIB_TRIA(IE) .LT. TINY(1.)) THEN + WRITE(*,*) 'AREA SMALLER ZERO', IE, NTRI, PDLIB_TRIA(IE) + STOP + ENDIF + DEDX(1) = PDLIB_IEN(1,IE) + DEDX(2) = PDLIB_IEN(3,IE) + DEDX(3) = PDLIB_IEN(5,IE) + DEDY(1) = PDLIB_IEN(2,IE) + DEDY(2) = PDLIB_IEN(4,IE) + DEDY(3) = PDLIB_IEN(6,IE) + VAR = PARAM(MAPFS(1,NI_GL)) * FACT + DVDXIE = DOT_PRODUCT(VAR,DEDX) + DVDYIE = DOT_PRODUCT(VAR,DEDY) + DIFFX(1,NI) = DIFFX(1,NI) + DVDXIE * LATMEAN ! AR: This must be correctly computer later ... + DIFFY(1,NI) = DIFFY(1,NI) + DVDYIE + END DO + DIFFX(1,:) = DIFFX(1,:)/WEI_LOCAL + DIFFY(1,:) = DIFFY(1,:)/WEI_LOCAL + ENDIF + CALL PDLIB_exchange1Dreal(DIFFX(1,1:NPA)) + CALL PDLIB_exchange1Dreal(DIFFY(1,1:NPA)) +#endif ! END SUBROUTINE UG_GRADIENTS @@ -1875,7 +1943,9 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ODATMD, ONLY: NBI, NDSE, ISBPI, XBPI, YBPI USE W3GDATMD, ONLY: NX, XYB, XGRD, YGRD, MAPSTA, MAPFS, MAPSF @@ -1903,7 +1973,9 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) STOP ENDIF IX1(N) = IX -!/T WRITE(NDSE ,*)'ADDING BOUNDARY POINT:',N,IX +#ifdef W3_T + WRITE(NDSE ,*)'ADDING BOUNDARY POINT:',N,IX +#endif END IF END DO ! @@ -1925,8 +1997,10 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) DIST0=SQRT(DIST0) IF (DIST0.LE.DISTMIN) THEN ISBPI(I)=IS -!/T WRITE(NDSE ,'(A,I6,A,I7,A,I6)') 'MATCHED BOUNDARY POINT:',I,'GRID POINT:', & -!/T MAPSF(IS,1),'INDEX IN nest.ww3:', JMEMO +#ifdef W3_T + WRITE(NDSE ,'(A,I6,A,I7,A,I6)') 'MATCHED BOUNDARY POINT:',I,'GRID POINT:', & + MAPSF(IS,1),'INDEX IN nest.ww3:', JMEMO +#endif ELSE FLOK=.TRUE. END IF @@ -1991,7 +2065,9 @@ SUBROUTINE SET_IOBP (MASK, STATUS) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! !/ ! @@ -2016,13 +2092,17 @@ SUBROUTINE SET_IOBP (MASK, STATUS) INTEGER :: INEXT(3), IPREV(3) INTEGER :: ZNEXT, IP, I, IE, IPNEXT, IPPREV, COUNT integer nb0, nb1, nbM1 -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 1' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 1' + FLUSH(740+IAPROC) +#endif STATUS = -1 INEXT=(/ 2, 3, 1 /) !IPREV=1+MOD(I+1,3) IPREV=(/ 3, 1, 2 /) !INEXT=1+MOD(I,3) -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 2' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 2' + FLUSH(740+IAPROC) +#endif DO IE=1,NTRI ! If one of the points of the triangle is masked out (land) then do as if triangle does not exist... ! IF ((MASK(TRIGP(IE,1)).GT.0).AND.(MASK(TRIGP(IE,2)).GT.0).AND.(MASK(TRIGP(IE,3)).GT.0)) THEN @@ -2085,24 +2165,32 @@ SUBROUTINE SET_IOBP (MASK, STATUS) EXIT END IF END DO -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 3' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 3' + FLUSH(740+IAPROC) +#endif STATUS = 1 CALL GET_BOUNDARY(NX, NTRI, TRIGP, STATUS, PREVVERT, NEXTVERT) -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 4' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 4' + FLUSH(740+IAPROC) +#endif ! DO IP= 1, NX ! WRITE(12000,*) IP, STATUS(IP) ! ENDDO -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 5' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 5' + FLUSH(740+IAPROC) +#endif !#ifdef MPI_PARALL_GRID ! CALL exchange_p2di(STATUS) !#endif -!/DEBUGSETIOBP WRITE(740+IAPROC,*) 'Calling SETIOBP, step 6' -!/DEBUGSETIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETIOBP + WRITE(740+IAPROC,*) 'Calling SETIOBP, step 6' + FLUSH(740+IAPROC) +#endif END SUBROUTINE SET_IOBP !/ ------------------------------------------------------------------- / @@ -2152,7 +2240,9 @@ SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3SERVMD, ONLY: EXTCDE IMPLICIT NONE @@ -2163,7 +2253,9 @@ SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, INTENT(IN) :: MNP, MNE, TRIGP(MNE,3) INTEGER, INTENT(INOUT) :: IOBP(MNP) @@ -2178,7 +2270,9 @@ SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & INTEGER :: IE, I, IP, IP2, IP3 INTEGER :: ISFINISHED, INEXT, IPREV, ISTAT INTEGER :: IPNEXT, IPPREV, ZNEXT, ZPREV -!/S CALL STRACE (IENT, 'GET_BOUNDARY') +#ifdef W3_S + CALL STRACE (IENT, 'GET_BOUNDARY') +#endif ALLOCATE(STATUS(MNP), STAT=ISTAT) CHECK_ALLOC_STATUS ( ISTAT ) ALLOCATE(COLLECTED(MNP), STAT=ISTAT) @@ -2374,7 +2468,9 @@ SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE ! !/ ------------------------------------------------------------------- / @@ -2383,13 +2479,17 @@ SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER, INTENT(IN) :: I INTEGER, INTENT(OUT) :: INEXT, IPREV -!/S CALL STRACE (IENT, 'TRIANG_INDEXES') +#ifdef W3_S + CALL STRACE (IENT, 'TRIANG_INDEXES') +#endif IF (I.EQ.1) THEN INEXT=3 ELSE @@ -2449,12 +2549,16 @@ SUBROUTINE GET_INTERFACE() ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE CONSTANTS, ONLY : LPDLIB USE W3GDATMD, ONLY : NX, IOBP, CCON, NSEAL, IOBDP, IE_CELL, IOBDP, TRIGP -!/PDLIB USE yowNodepool, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 -!/PDLIB USE yowElementpool, only: INE +#ifdef W3_PDLIB + USE yowNodepool, only: PDLIB_SI, PDLIB_IEN, PDLIB_CCON, NPA, PDLIB_IE_CELL2, PDLIB_POS_CELL2 + USE yowElementpool, only: INE +#endif IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / @@ -2463,25 +2567,31 @@ SUBROUTINE GET_INTERFACE() !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ INTEGER :: I, J, IP, IE -!/S CALL STRACE (IENT, 'GET_INTERFACE') -!/PDLIB IF (LPDLIB) THEN -!/PDLIB DO IP = 1, NSEAL -!/PDLIB IF (IOBP(IP) .NE. 0 .OR. IOBDP(IP) .EQ. 0) CYCLE -!/PDLIB DO I = 1, PDLIB_CCON(IP) -!/PDLIB IE = PDLIB_IE_CELL2(IP,I) -!/PDLIB IF (ANY(IOBDP(TRIGP(IE,:)) .EQ. 0)) THEN -!/PDLIB IOBDP(IP) = -1 -!/PDLIB CYCLE -!/PDLIB ENDIF -!/PDLIB ENDDO -!/PDLIB ENDDO -!/PDLIB !CALL EXCHANGE_.... -!/PDLIB ELSE +#ifdef W3_S + CALL STRACE (IENT, 'GET_INTERFACE') +#endif +#ifdef W3_PDLIB + IF (LPDLIB) THEN + DO IP = 1, NSEAL + IF (IOBP(IP) .NE. 0 .OR. IOBDP(IP) .EQ. 0) CYCLE + DO I = 1, PDLIB_CCON(IP) + IE = PDLIB_IE_CELL2(IP,I) + IF (ANY(IOBDP(TRIGP(IE,:)) .EQ. 0)) THEN + IOBDP(IP) = -1 + CYCLE + ENDIF + ENDDO + ENDDO + !CALL EXCHANGE_.... + ELSE +#endif J = 0 DO IP = 1, NSEAL IF (IOBP(IP) .NE. 1 .OR. IOBDP(IP) .EQ. 0) CYCLE @@ -2494,7 +2604,9 @@ SUBROUTINE GET_INTERFACE() ENDIF ENDDO ENDDO -!/PDLIB ENDIF +#ifdef W3_PDLIB + ENDIF +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / @@ -2566,14 +2678,18 @@ SUBROUTINE SETUGIOBP ( ) NK, NTH, DTH, XFR, MAPSTA, COUNTRI, & ECOS, ESIN, IEN, NTRI, TRIGP, & IOBP,IOBPD, IOBPA, & -!/REF1 REFPARS, REFLC, REFLD, & +#ifdef W3_REF1 + REFPARS, REFLC, REFLD, & +#endif ANGLE0, ANGLE USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX USE W3IDATMD, ONLY: FLCUR USE W3ODATMD, only : IAPROC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -2591,26 +2707,36 @@ SUBROUTINE SETUGIOBP ( ) REAL(KIND=8), PARAMETER :: THR = TINY(1.) INTEGER :: I1, I2, I3 INTEGER :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ ------------------------------------------------------------------- / ! ! 1. Preparations --------------------------------------------------- * ! 1.a Set constants ! -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 1' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 1' + FLUSH(740+IAPROC) +#endif -!/S CALL STRACE (IENT, 'SETUGIOBP') +#ifdef W3_S + CALL STRACE (IENT, 'SETUGIOBP') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Searches for boundary points ! -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 2' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 2' + FLUSH(740+IAPROC) +#endif ITMP = MAPSTA(1,:) CALL SET_IOBP(ITMP, IOBP) -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 3' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 3' + FLUSH(740+IAPROC) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Defines directions pointing into land or sea @@ -2622,8 +2748,10 @@ SUBROUTINE SETUGIOBP ( ) IF ((MAPSTA(1,IP).EQ.2).AND.(IOBP(IP).EQ.0)) IOBPA(IP)=1 !WRITE(600,*) IP,ITMP(IP),IOBP(IP),IOBPA(IP) END DO -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 4' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 4' + FLUSH(740+IAPROC) +#endif DO IE=1,NTRI I1 = TRIGP(IE,1) @@ -2673,8 +2801,10 @@ SUBROUTINE SETUGIOBP ( ) END DO END DO END DO -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 5' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 5' + FLUSH(740+IAPROC) +#endif DO IP = 1, NX IF ( IOBPA(IP) .eq. 1 .OR. IOBP(IP) .eq. 3 .OR. IOBP(IP) .eq. 4) IOBPD(:,IP) = 1 END DO @@ -2692,34 +2822,40 @@ SUBROUTINE SETUGIOBP ( ) ! IOBPD(ID,:) = iwild ! ENDDO !#endif -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 7' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 7' + FLUSH(740+IAPROC) +#endif !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Updates the reflection direction and sharp / flat shoreline angle -!/REF1 ! -!/REF1 ! Finds the shoreline direction from IOBPD -!/REF1 ! -!/REF1 REFLC(1,:)= 0. -!/REF1 REFLD(:,:)= 1 -!/REF1 DO IP=1,NX -!/REF1 IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN -!/REF1 COSSUM=0. -!/REF1 SINSUM=0. -!/REF1 NDIRSUM=0. -!/REF1 DO ITH=1,NTH -!/REF1 COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) -!/REF1 SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) -!/REF1 NDIRSUM=NDIRSUM+IOBPD(ITH,IP) -!/REF1 END DO -!/REF1 DIRCOAST=ATAN2(SINSUM, COSSUM) -!/REF1 REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) -!/REF1 REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) -!/REF1 REFLC(1,MAPFS(1,IP))= REFPARS(1) -!/REF1 END IF -!/REF1 END DO -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 8' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_REF1 + ! + ! Finds the shoreline direction from IOBPD + ! + REFLC(1,:)= 0. + REFLD(:,:)= 1 + DO IP=1,NX + IF (IOBP(IP).EQ.0.AND.MAPSTA(1,IP).EQ.1) THEN + COSSUM=0. + SINSUM=0. + NDIRSUM=0. + DO ITH=1,NTH + COSSUM=COSSUM+IOBPD(ITH,IP)*ECOS(ITH) + SINSUM=SINSUM+IOBPD(ITH,IP)*ESIN(ITH) + NDIRSUM=NDIRSUM+IOBPD(ITH,IP) + END DO + DIRCOAST=ATAN2(SINSUM, COSSUM) + REFLD(1,MAPFS(1,IP)) = 1+MOD(NTH+NINT(DIRCOAST/DTH),NTH) + REFLD(2,MAPFS(1,IP)) = 4-MAX(2,NINT(4.*REAL(NDIRSUM)/REAL(NTH))) + REFLC(1,MAPFS(1,IP))= REFPARS(1) + END IF + END DO +#endif +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 8' + FLUSH(740+IAPROC) +#endif !DO IX=1,NX @@ -2728,13 +2864,17 @@ SUBROUTINE SETUGIOBP ( ) !ENDDO !ENDDO -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 9' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 9' + FLUSH(740+IAPROC) +#endif ! ! Recomputes the angles used in the gradients estimation ! -!/DEBUGSETUGIOBP WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 10' -!/DEBUGSETUGIOBP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSETUGIOBP + WRITE(740+IAPROC,*) 'Calling SETUGIOBP, step 10' + FLUSH(740+IAPROC) +#endif ! RETURN END SUBROUTINE SETUGIOBP diff --git a/model/ftn/w3uno2md.ftn b/model/src/w3uno2md.F90 similarity index 59% rename from model/ftn/w3uno2md.ftn rename to model/src/w3uno2md.F90 index 351973a8f..ea8f779a5 100644 --- a/model/ftn/w3uno2md.ftn +++ b/model/src/w3uno2md.F90 @@ -57,7 +57,9 @@ MODULE W3UNO2MD ! 7. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -147,46 +149,66 @@ SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& !/ INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2 -!/S INTEGER, SAVE :: IENT -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & QBR, CFAC, FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN, XCFL -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN, XCFL +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UNO2') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, DT, BCLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'VELO' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & -!/T0 *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3UNO2') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, DT, BCLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'VELO' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & + *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX @@ -206,8 +228,10 @@ SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& ! 2. Fluxes for central points ------------------------------------- * ! ( 2rd order UNO2 scheme ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! DO IP=1, NB0 ! @@ -227,77 +251,91 @@ SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& *MIN(ABS(Q(IXYC+INC)-Q(IXYC))/DX2(IXYC), & ABS(Q(IXYC)-Q(IXYC-INC))/DX2(IXYC-INC) ) ! -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif ! FLA(IXY) = CFL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, DT*VELO(IXY)/DX1(IXY), & -!/T1 DT*VELO(IXY+INC)/DX1(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, DT*VELO(IXY)/DX1(IXY), & + DT*VELO(IXY+INC)/DX1(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! DO IP=NB0+1, NB1 IXY = MAPBOU(IP) VEL = VELO(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) FLA(IXY) = VEL * DT * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & -!/T1 DT*VELO(IXY)/DX2(IXY), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! DO IP=NB1+1, NB2 IXY = MAPBOU(IP) VEL = VELO(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) FLA(IXY) = VEL * DT * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & -!/T1 DT*VELO(IXY+INC)/DX2(IXY), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY+INC)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 5. Global closure ----------------------------------------------- * ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -305,50 +343,70 @@ SUBROUTINE W3UNO2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q,BCLOSE,& ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif DO IP=1, NACT IXY = MAPACT(IP) -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif ! Li Update transported quantity with fluxes Q(IXY) = MAX( 0., Q(IXY)+( FLA(IXY-INC)-FLA(IXY) )/DX1(IXY) ) ! Li This positive filter is not necessary for UNO2 scheme but kept here. -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 DT*FLA(IXY-INC)/DX1(IXY), & -!/T2 DT*FLA(IXY)/DX1(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + DT*FLA(IXY-INC)/DX1(IXY), & + DT*FLA(IXY)/DX1(IXY) +#endif END DO ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3UNO2 : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' TIME STEP :',F8.1/ & -!/T ' BCLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3UNO2 : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3UNO2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3UNO2 :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3UNO2 : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3UNO2 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' TIME STEP :',F8.1/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3UNO2 : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3UNO2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3UNO2 :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3UNO2 : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3UNO2 : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3UNO2 ----------------------------------------------------- / !/ @@ -449,45 +507,65 @@ SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & !/ INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2 -!/S INTEGER, SAVE :: IENT = 0 -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC REAL :: FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UNO2r') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'CFLL' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3UNO2r') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX @@ -504,8 +582,10 @@ SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & ! 2. Fluxes for central points ------------------------------------- * ! ( 3rd order + limiter ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! DO IP=1, NB0 ! @@ -516,74 +596,88 @@ SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & QB = Q(IXYC)+SIGN(0.5, Q(IXYD)-Q(IXYC))*(1.0-ABS(CFL)) & *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & ABS(Q(IXYC)-Q(IXYC-INC)) ) -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif ! FLA(IXY) = CFL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, CFLL(IXY), CFLL(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! DO IP=NB0+1, NB1 IXY = MAPBOU(IP) CFL = CFLL(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! DO IP=NB1+1, NB2 IXY = MAPBOU(IP) CFL = CFLL(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 5. Global closure ----------------------------------------------- * ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -591,46 +685,66 @@ SUBROUTINE W3UNO2r (MX, MY, NX, NY, CFLL, Q, BCLOSE, INC, & ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif DO IP=1, NACT IXY = MAPACT(IP) -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 FLA(IXY-INC), FLA(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) +#endif END DO ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3UNO2r : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' BCLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3UNO2r : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3UNO2r : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3UNO2r :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3UNO2r : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3UNO2r : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3UNO2r : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3UNO2r : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3UNO2r :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3UNO2r : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3UNO2r : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3UNO2r ---------------------------------------------------- / !/ @@ -734,52 +848,74 @@ SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2, & JN, JP -!/S INTEGER, SAVE :: IENT = 0 -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC REAL :: FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UNO2s') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'CFLL' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3UNO2s') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, BCLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX IADN1 = MY*NX IADN2 = IAD02 + MY*NX ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IY) +#endif ! DO IY=1, NY Q (IY+IAD00) = Q (IY+IADN0) @@ -788,19 +924,27 @@ SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & CFLL(IY+IADN1) = CFLL( IY ) END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! ! 2. Fluxes for central points ------------------------------------- * ! ( 3rd order + limiter ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, & -!/OMPH/!/T1!$OMP QBO, IX, IY, IY2, IX2, QN & -!/OMPH/!$OMP IXYC, IXYD, QB) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, & +#ifdef W3_T1 +!$OMP QBO, IX, IY, IY2, IX2, QN & +#endif +!$OMP IXYC, IXYD, QB) +#endif ! DO IP=1, NB0 ! @@ -812,76 +956,92 @@ SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & *MIN(ABS(Q(IXYC+INC)-Q(IXYC)), & ABS(Q(IXYC)-Q(IXYC-INC)) ) ! -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif ! FLA(IXY) = CFL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, CFLL(IXY), CFLL(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! DO IP=NB0+1, NB1 IXY = MAPBOU(IP) CFL = CFLL(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! DO IP=NB1+1, NB2 IXY = MAPBOU(IP) CFL = CFLL(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 5. Global closure ----------------------------------------------- * ! IF ( BCLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -889,11 +1049,17 @@ SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif ! -!/OMPH/!$OMP PARALLEL DO & -!/OMPH/!/T2/!$OMP PRIVATE(QOLD), & -!/OMPH/!$OMP PRIVATE (IP, IXY, JN, JP) +#ifdef W3_OMPH +!$OMP PARALLEL DO & +#ifdef W3_T2 +!$OMP PRIVATE(QOLD), & +#endif +!$OMP PRIVATE (IP, IXY, JN, JP) +#endif ! DO IP=1, NACT ! @@ -909,47 +1075,67 @@ SUBROUTINE W3UNO2s (MX, MY, NX, NY, CFLL, TRANS, Q, BCLOSE, & JP = 0 END IF ! -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & - TRANS(IXY,JP) * FLA(IXY) ) -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 FLA(IXY-INC), FLA(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3UNO2s : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' BCLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3UNO2s : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3UNO2s : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3UNO2s :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3UNO2s : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3UNO2s : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' BCLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3UNO2s : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3UNO2s : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3UNO2s :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3UNO2s : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3UNO2s : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3UNO2s ---------------------------------------------------- / !/ diff --git a/model/ftn/w3uostmd.ftn b/model/src/w3uostmd.F90 similarity index 96% rename from model/ftn/w3uostmd.ftn rename to model/src/w3uostmd.F90 index 0bf5cf608..0efb0d6d8 100644 --- a/model/ftn/w3uostmd.ftn +++ b/model/src/w3uostmd.F90 @@ -39,7 +39,9 @@ MODULE W3UOSTMD USE W3GDATMD, ONLY: GRID, SGRD, GRIDS, SGRDS USE W3ODATMD, ONLY: NDSO, NDSE USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif IMPLICIT NONE @@ -127,9 +129,13 @@ SUBROUTINE UOST_INITGRID(IGRID, FILELOCAL, FILESHADOW, LOCALFACTOR, SHADOWFACTOR TYPE(GRID), POINTER :: GRD TYPE(SGRD), POINTER :: SGD REAL :: CGMAX, MINSIZE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_INITGRID') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_INITGRID') +#endif IF ( (IGRID .LE. 0) .OR. (.NOT. ALLOCATED(GRIDS)) ) THEN RETURN @@ -211,9 +217,13 @@ SUBROUTINE UOST_SETGRID(IGRID) IMPLICIT NONE INTEGER, INTENT(IN) :: IGRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SETGRID') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SETGRID') +#endif IF ( .NOT. ALLOCATED(SRCTRM) ) THEN ALLOCATE(SRCTRM) @@ -261,9 +271,13 @@ SUBROUTINE UOST_SRCTRMCOMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) REAL, INTENT(IN) :: SPEC(SRCTRM%SGD%NSPEC), CG(SRCTRM%SGD%NK) REAL, INTENT(IN) :: U10ABS, U10DIR REAL, INTENT(OUT) :: S(SRCTRM%SGD%NSPEC), D(SRCTRM%SGD%NSPEC) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SRCTRMCOMPUTE') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SRCTRMCOMPUTE') +#endif CALL SRCTRM%COMPUTE(IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S, D) END SUBROUTINE UOST_SRCTRMCOMPUTE @@ -309,9 +323,13 @@ SUBROUTINE LOAD_ALPHABETA(GRD, SGD, FILEUNIT) CHARACTER(256) :: FILENAME LOGICAL :: FILEEXISTS INTEGER :: JG, J, L, I, IX, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'LOAD_ALPHABETA') +#ifdef W3_S + CALL STRACE (IENT, 'LOAD_ALPHABETA') +#endif ! LOADING LOCAL ALPHA/BETA @@ -406,9 +424,13 @@ SUBROUTINE LOAD_ALPHABETA_FROMFILE(FILEUNIT, FILENAME, NX, NY, NK, NTH,& LOGICAL :: HEADER, FILESTART, READINGCELLSIZE, READINGALPHA INTEGER :: IX, IY, SPGRDS_SIZE, IK REAL, ALLOCATABLE :: TRANS(:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'LOAD_ALPHABETA_FROMFILE') +#ifdef W3_S + CALL STRACE (IENT, 'LOAD_ALPHABETA_FROMFILE') +#endif ! INITIALIZING LOGICALS REPRESENTING THE DIFFERENT PHASES OF THE LOAD FILESTART = .TRUE. @@ -517,9 +539,13 @@ SUBROUTINE UOST_SOURCETERM_SETGRID(THIS, GRD, SGD) TYPE(GRID), TARGET, INTENT(IN) :: GRD TYPE(SGRD), TARGET, INTENT(IN) :: SGD INTEGER :: ITH, NTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SOURCETERM_SETGRID') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SOURCETERM_SETGRID') +#endif THIS%GRD => GRD THIS%SGD => SGD @@ -589,9 +615,13 @@ SUBROUTINE COMPUTE_REDUCTION_PSI(U10ABS, U10DIR, CGABS, CGDIR, DT, PSI) REAL, INTENT(IN) :: U10ABS, U10DIR, CGABS, CGDIR, DT REAL, INTENT(OUT) :: PSI REAL :: THDELTA, CP, WA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'COMPUTE_REDUCTION_PSI') +#ifdef W3_S + CALL STRACE (IENT, 'COMPUTE_REDUCTION_PSI') +#endif ! computing the wave age THDELTA = ABS(U10DIR - CGDIR) @@ -675,9 +705,13 @@ SUBROUTINE UOST_SOURCETERM_COMPUTE_LD(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR REAL :: ALPHA, BETA, CGI, CELLSIZE, SPECI, SFC LOGICAL :: CELLOBSTRUCTED REAL :: TH, PSI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_LD') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_LD') +#endif S = 0 D = 0 @@ -782,9 +816,13 @@ SUBROUTINE UOST_SOURCETERM_COMPUTE_SE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR INTEGER :: N = 8, ITHDIAG, ISP, NK, NTH, NX, NY LOGICAL :: CELLOBSTRUCTED REAL :: TH, PSI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_SE') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE_SE') +#endif S = 0 D = 0 @@ -891,9 +929,13 @@ SUBROUTINE UOST_SOURCETERM_COMPUTE(THIS, IX, IY, SPEC, CG, DT, U10ABS, U10DIR, S REAL :: S_LD(THIS%SGD%NSPEC), S_SE(THIS%SGD%NSPEC) REAL :: D_LD(THIS%SGD%NSPEC), D_SE(THIS%SGD%NSPEC) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif -!/S CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE') +#ifdef W3_S + CALL STRACE (IENT, 'UOST_SOURCETERM_COMPUTE') +#endif IF (.NOT. THIS%GRD%UOSTENABLED) THEN S = 0 diff --git a/model/ftn/w3updtmd.ftn b/model/src/w3updtmd.F90 similarity index 72% rename from model/ftn/w3updtmd.ftn rename to model/src/w3updtmd.F90 index f5d591fba..0ed3b32bb 100644 --- a/model/ftn/w3updtmd.ftn +++ b/model/src/w3updtmd.F90 @@ -127,7 +127,9 @@ MODULE W3UPDTMD !/ ------------------------------------------------------------------- / USE CONSTANTS USE W3ODATMD, ONLY: NDSE, NDST, NAPROC, IAPROC, NAPERR -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: DSEC21 !/ !/ ------------------------------------------------------------------- / @@ -211,15 +213,19 @@ SUBROUTINE W3UCUR ( FLFRST ) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF -!/SMC USE W3GDATMD, ONLY: NARC, NGLO, ANGARC -!/SMC USE W3GDATMD, ONLY: FSWND, ARCTC +#ifdef W3_SMC + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC + USE W3GDATMD, ONLY: FSWND, ARCTC +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: CX, CY, CA0, CAI, CD0, CDI USE W3IDATMD, ONLY: TC0, CX0, CY0, TCN, CXN, CYN -!/TIDE USE W3GDATMD, ONLY: YGRD -!/TIDE USE W3TIMEMD -!/TIDE USE W3IDATMD, ONLY: FLCURTIDE, CXTIDE, CYTIDE, NTIDE -!/TIDE USE W3TIDEMD +#ifdef W3_TIDE + USE W3GDATMD, ONLY: YGRD + USE W3TIMEMD + USE W3IDATMD, ONLY: FLCURTIDE, CXTIDE, CYTIDE, NTIDE + USE W3TIDEMD +#endif ! IMPLICIT NONE !/ @@ -231,32 +237,44 @@ SUBROUTINE W3UCUR ( FLFRST ) !/ ------------------------------------------------------------------- / !/ INTEGER :: ISEA, IX, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: D0, DN, DD, DT0N, DT0T, RD, CABS, CDIR -!/CRT2 REAL :: RD2, CI2 -!/TIDE INTEGER :: J,K -!/TIDE INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" -!/TIDE REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY -!/TIDE REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau -!/TIDE REAL :: FX(44),UX(44),VX(44) +#ifdef W3_CRT2 + REAL :: RD2, CI2 +#endif +#ifdef W3_TIDE + INTEGER :: J,K + INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" + REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY + REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + REAL :: FX(44),UX(44),VX(44) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UCUR') +#ifdef W3_S + CALL STRACE (IENT, 'W3UCUR') +#endif ! ! 1. Prepare auxiliary arrays ! IF ( FLFRST ) THEN DO ISEA=1, NSEA -!/SMC !!Li For sea-point SMC grid current, the 1-D current is stored on -!/SMC !!Li 2-D CX0(NSEA, 1) variable. -!/SMC IF( FSWND ) THEN -!/SMC IX = ISEA -!/SMC IY = 1 -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea-point SMC grid current, the 1-D current is stored on + !!Li 2-D CX0(NSEA, 1) variable. + IF( FSWND ) THEN + IX = ISEA + IY = 1 + ELSE +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif CA0(ISEA) = SQRT ( CX0(IX,IY)**2 + CY0(IX,IY)**2 ) CAI(ISEA) = SQRT ( CXN(IX,IY)**2 + CYN(IX,IY)**2 ) @@ -287,101 +305,125 @@ SUBROUTINE W3UCUR ( FLFRST ) DT0N = DSEC21 ( TC0, TCN ) DT0T = DSEC21 ( TC0, TIME ) ! -!/CRT0 RD = 0. -!/CRT1 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/CRT2 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/CRT2 RD2 = 1. - RD -!/OASOCM RD = 1. -! -!/T WRITE (NDST,9000) DT0N, DT0T, RD +#ifdef W3_CRT0 + RD = 0. +#endif +#ifdef W3_CRT1 + RD = DT0T / MAX ( 1.E-7 , DT0N ) +#endif +#ifdef W3_CRT2 + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD +#endif +#ifdef W3_OASOCM + RD = 1. +#endif +! +#ifdef W3_T + WRITE (NDST,9000) DT0N, DT0T, RD +#endif -!/TIDE IF (FLCURTIDE) THEN -!/TIDE! WRITE(6,*) 'TIME CUR:',TIME, '##',TC0, '##',TCN -!/TIDE TIDE_HOUR = TIME2HOURS(TIME) -!/TIDE! -!/TIDE!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION -!/TIDE!* AT THE MID POINT OF THE ANALYSIS PERIOD. -!/TIDE d1=TIDE_HOUR/24.d0 -!/TIDE TIDE_KD0= 2415020 -!/TIDE d1=d1-dfloat(TIDE_kd0)-0.5d0 -!/TIDE call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) -!/TIDE INT24=24 -!/TIDE INTDYS=int((TIDE_HOUR+0.00001)/INT24) -!/TIDE HH=TIDE_HOUR-dfloat(INTDYS*INT24) -!/TIDE TAU=HH/24.D0+H-S -!/TIDE END IF -!/TIDE! -!/TIDE! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- -!/TIDE! TING THE LUNAR TIME TAU. -!/TIDE! +#ifdef W3_TIDE + IF (FLCURTIDE) THEN +! WRITE(6,*) 'TIME CUR:',TIME, '##',TC0, '##',TCN + TIDE_HOUR = TIME2HOURS(TIME) +! +!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION +!* AT THE MID POINT OF THE ANALYSIS PERIOD. + d1=TIDE_HOUR/24.d0 + TIDE_KD0= 2415020 + d1=d1-dfloat(TIDE_kd0)-0.5d0 + call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((TIDE_HOUR+0.00001)/INT24) + HH=TIDE_HOUR-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + END IF +! +! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- +! TING THE LUNAR TIME TAU. +! +#endif ! ! 3. Actual currents for all grid points ! DO ISEA=1, NSEA -!/TIDE IF (FLCURTIDE) THEN ! could move IF test outside of ISEA loop ... -!/TIDE! VUF should only be updated in latitude changes significantly ... -!/TIDE IX = MAPSF(ISEA,1) -!/TIDE IY = MAPSF(ISEA,2) -!/TIDE CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),FX,UX,VX) -!/TIDE WCURTIDEX = CXTIDE(IX,IY,1,1) -!/TIDE WCURTIDEY = CYTIDE(IX,IY,1,1) -!/TIDE -!/TIDE DO J=2,TIDE_MF -!/TIDE TIDE_ARGX=(VX(J)+UX(J))*twpi-CXTIDE(IX,IY,J,2)*DERA -!/TIDE TIDE_ARGY=(VX(J)+UX(J))*twpi-CYTIDE(IX,IY,J,2)*DERA -!/TIDE WCURTIDEX = WCURTIDEX+FX(J)*CXTIDE(IX,IY,J,1)*COS(TIDE_ARGX) -!/TIDE WCURTIDEY = WCURTIDEY+FX(J)*CYTIDE(IX,IY,J,1)*COS(TIDE_ARGY) -!/TIDE END DO -!/TIDE +#ifdef W3_TIDE + IF (FLCURTIDE) THEN ! could move IF test outside of ISEA loop ... +! VUF should only be updated in latitude changes significantly ... + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),FX,UX,VX) + WCURTIDEX = CXTIDE(IX,IY,1,1) + WCURTIDEY = CYTIDE(IX,IY,1,1) + + DO J=2,TIDE_MF + TIDE_ARGX=(VX(J)+UX(J))*twpi-CXTIDE(IX,IY,J,2)*DERA + TIDE_ARGY=(VX(J)+UX(J))*twpi-CYTIDE(IX,IY,J,2)*DERA + WCURTIDEX = WCURTIDEX+FX(J)*CXTIDE(IX,IY,J,1)*COS(TIDE_ARGX) + WCURTIDEY = WCURTIDEY+FX(J)*CYTIDE(IX,IY,J,1)*COS(TIDE_ARGY) + END DO + +#endif + +#ifdef W3_TIDET + !Verification + IF (ISEA.EQ.1) THEN + + TIDE_AMPC(1:NTIDE,1)=CXTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,1 )=CXTIDE(IX,IY,1:NTIDE,2) + TIDE_AMPC(1:NTIDE,2)=CYTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,2) =CYTIDE(IX,IY,1:NTIDE,2) -!/TIDET !Verification -!/TIDET IF (ISEA.EQ.1) THEN -!/TIDET -!/TIDET TIDE_AMPC(1:NTIDE,1)=CXTIDE(IX,IY,1:NTIDE,1) -!/TIDET TIDE_PHG(1:NTIDE,1 )=CXTIDE(IX,IY,1:NTIDE,2) -!/TIDET TIDE_AMPC(1:NTIDE,2)=CYTIDE(IX,IY,1:NTIDE,1) -!/TIDET TIDE_PHG(1:NTIDE,2) =CYTIDE(IX,IY,1:NTIDE,2) -!/TIDET -!/TIDET WRITE(993,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & -!/TIDET d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) -!/TIDET -!/TIDET DO J=1,TIDE_MF -!/TIDET WRITE(993,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & -!/TIDET FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) -!/TIDET END DO -!/TIDET DO K=1,2 -!/TIDET DO J=1,TIDE_MF -!/TIDET WRITE(993,'(A,5I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,K,J,TIME,TIDE_HOUR, & -!/TIDET FX(J),UX(J),VX(J),TIDE_AMPC(J,K),TIDE_PHG(J,K) -!/TIDET END DO -!/TIDET END DO -!/TIDET -!/TIDET WRITE(993,'(A,2F8.4,A,2F8.4)') '#:',CX0(IX,IY),CY0(IX,IY),'##',WCURTIDEX,WCURTIDEY -!/TIDET CLOSE(993) -!/TIDET END IF -!/TIDET ! End of verification -!/TIDE CX(ISEA) = WCURTIDEX -!/TIDE CY(ISEA) = WCURTIDEY -!/TIDE ELSE + WRITE(993,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & + d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) + + DO J=1,TIDE_MF + WRITE(993,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + END DO + DO K=1,2 + DO J=1,TIDE_MF + WRITE(993,'(A,5I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,K,J,TIME,TIDE_HOUR, & + FX(J),UX(J),VX(J),TIDE_AMPC(J,K),TIDE_PHG(J,K) + END DO + END DO + + WRITE(993,'(A,2F8.4,A,2F8.4)') '#:',CX0(IX,IY),CY0(IX,IY),'##',WCURTIDEX,WCURTIDEY + CLOSE(993) + END IF + ! End of verification +#endif +#ifdef W3_TIDE + CX(ISEA) = WCURTIDEX + CY(ISEA) = WCURTIDEY + ELSE +#endif CABS = CA0(ISEA) + RD * CAI(ISEA) -!/CRT2 CI2 = SQRT ( RD2 * CA0(ISEA)**2 + & -!/CRT2 RD *(CA0(ISEA)+CAI(ISEA))**2 ) -!/CRT2 CABS = CABS * MIN( 1.25 , CI2/MAX(1.E-7,CABS) ) +#ifdef W3_CRT2 + CI2 = SQRT ( RD2 * CA0(ISEA)**2 + & + RD *(CA0(ISEA)+CAI(ISEA))**2 ) + CABS = CABS * MIN( 1.25 , CI2/MAX(1.E-7,CABS) ) +#endif CDIR = CD0(ISEA) + RD * CDI(ISEA) -!/SMC !Li Rotate curreent direction by ANGARC for Arctic part cells. JGLi23Mar2016 -!/SMC IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN -!/SMC DN = CDIR + ANGARC( ISEA - NGLO )*DERA -!/SMC CDIR = MOD ( TPI + DN, TPI ) -!/SMC ENDIF +#ifdef W3_SMC + !Li Rotate curreent direction by ANGARC for Arctic part cells. JGLi23Mar2016 + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + DN = CDIR + ANGARC( ISEA - NGLO )*DERA + CDIR = MOD ( TPI + DN, TPI ) + ENDIF +#endif CX(ISEA) = CABS * COS(CDIR) CY(ISEA) = CABS * SIN(CDIR) -!/TIDE ! IF (ISEA.EQ.1) WRITE(6,'(A,4F8.4,A,4F8.4)') 'CUR#:',RD,CA0(ISEA),CAI(ISEA),CABS,'##', & -!/TIDE ! CX(ISEA), CY(ISEA),WCURTIDEX, WCURTIDEY -!/TIDE END IF +#ifdef W3_TIDE + ! IF (ISEA.EQ.1) WRITE(6,'(A,4F8.4,A,4F8.4)') 'CUR#:',RD,CA0(ISEA),CAI(ISEA),CABS,'##', & + ! CX(ISEA), CY(ISEA),WCURTIDEX, WCURTIDEY + END IF +#endif ! END DO ! @@ -389,7 +431,9 @@ SUBROUTINE W3UCUR ( FLFRST ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3UCUR : DT0N, DT0T, RD :',2F8.1,F6.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3UCUR : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif !/ !/ End of W3UCUR ----------------------------------------------------- / !/ @@ -484,10 +528,18 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF -!/WCOR USE W3GDATMD, ONLY: WWCOR -!/RWND USE W3GDATMD, ONLY: RWINDC -!/ST2 USE W3GDATMD, ONLY: ZWIND, OFSTAB, FFNG, FFPS, CCNG, CCPS, SHSTAB -!/SMC USE W3GDATMD, ONLY: NARC, NGLO, ANGARC, ARCTC, FSWND +#ifdef W3_WCOR + USE W3GDATMD, ONLY: WWCOR +#endif +#ifdef W3_RWND + USE W3GDATMD, ONLY: RWINDC +#endif +#ifdef W3_ST2 + USE W3GDATMD, ONLY: ZWIND, OFSTAB, FFNG, FFPS, CCNG, CCPS, SHSTAB +#endif +#ifdef W3_SMC + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC, ARCTC, FSWND +#endif USE W3WDATMD, ONLY: TIME, ASF USE W3ADATMD, ONLY: DW, CX, CY, UA, UD, U10, U10D, AS, & UA0, UAI, UD0, UDI, AS0, ASI @@ -504,30 +556,42 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) !/ ------------------------------------------------------------------- / !/ INTEGER :: ISEA, IX, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: D0, DN, DD, DT0N, DT0T, RD, UI2, & UXR, UYR -!/WNT2 REAL :: RD2 -!/STAB2 REAL :: STAB0, STAB, THARG1, THARG2, COR1, COR2 +#ifdef W3_WNT2 + REAL :: RD2 +#endif +#ifdef W3_STAB2 + REAL :: STAB0, STAB, THARG1, THARG2, COR1, COR2 +#endif REAL :: UDARC !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UWND') +#ifdef W3_S + CALL STRACE (IENT, 'W3UWND') +#endif ! ! 1. Prepare auxiliary arrays ! IF ( FLFRST ) THEN DO ISEA=1, NSEA -!/SMC !!Li For sea-point only SMC grid wind 1-D wind is stored on -!/SMC !!Li 2-D WX0(NSEA, 1) variable. -!/SMC IF( FSWND ) THEN -!/SMC IX = ISEA -!/SMC IY = 1 -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea-point only SMC grid wind 1-D wind is stored on + !!Li 2-D WX0(NSEA, 1) variable. + IF( FSWND ) THEN + IX = ISEA + IY = 1 + ELSE +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif UA0(ISEA) = SQRT ( WX0(IX,IY)**2 + WY0(IX,IY)**2 ) UAI(ISEA) = SQRT ( WXN(IX,IY)**2 + WYN(IX,IY)**2 ) @@ -560,34 +624,52 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) DT0N = DSEC21 ( TW0, TWN ) DT0T = DSEC21 ( TW0, TIME ) ! -!/WNT0 RD = 0. -!/WNT1 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/WNT2 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/WNT2 RD2 = 1. - RD -!/OASACM RD = 1. -! -!/T WRITE (NDST,9000) DT0N, DT0T, RD +#ifdef W3_WNT0 + RD = 0. +#endif +#ifdef W3_WNT1 + RD = DT0T / MAX ( 1.E-7 , DT0N ) +#endif +#ifdef W3_WNT2 + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD +#endif +#ifdef W3_OASACM + RD = 1. +#endif +! +#ifdef W3_T + WRITE (NDST,9000) DT0N, DT0T, RD +#endif ! ! 3. Actual wind for all grid points ! -!/OMPG/!$OMP PARALLEL DO PRIVATE (ISEA,UI2,UXR,UYR,UDARC) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE (ISEA,UI2,UXR,UYR,UDARC) +#endif ! DO ISEA=1, NSEA ! UA(ISEA) = UA0(ISEA) + RD * UAI(ISEA) -!/WNT2 UI2 = SQRT ( RD2 * UA0(ISEA)**2 + & -!/WNT2 RD *(UA0(ISEA)+UAI(ISEA))**2 ) -!/WNT2 UA(ISEA) = UA(ISEA) * MIN(1.25,UI2/MAX(1.E-7,UA(ISEA))) +#ifdef W3_WNT2 + UI2 = SQRT ( RD2 * UA0(ISEA)**2 + & + RD *(UA0(ISEA)+UAI(ISEA))**2 ) + UA(ISEA) = UA(ISEA) * MIN(1.25,UI2/MAX(1.E-7,UA(ISEA))) +#endif UD(ISEA) = UD0(ISEA) + RD * UDI(ISEA) -!/MGW UXR = UA(ISEA)*COS(UD(ISEA)) + VGX -!/MGW UYR = UA(ISEA)*SIN(UD(ISEA)) + VGY -!/MGW UA(ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) -!/MGW UD(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) -!/SMC !Li Rotate wind direction by ANGARC for Arctic part cells. -!/SMC IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN -!/SMC UDARC = UD(ISEA) + ANGARC( ISEA - NGLO )*DERA -!/SMC UD(ISEA) = MOD ( TPI + UDARC, TPI ) -!/SMC ENDIF +#ifdef W3_MGW + UXR = UA(ISEA)*COS(UD(ISEA)) + VGX + UYR = UA(ISEA)*SIN(UD(ISEA)) + VGY + UA(ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) + UD(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) +#endif +#ifdef W3_SMC + !Li Rotate wind direction by ANGARC for Arctic part cells. + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + UDARC = UD(ISEA) + ANGARC( ISEA - NGLO )*DERA + UD(ISEA) = MOD ( TPI + UDARC, TPI ) + ENDIF +#endif ! AS(ISEA) = AS0(ISEA) + RD * ASI(ISEA) ! IF (UA(ISEA).NE.UA(ISEA)) WRITE(6,*) 'BUG WIND:',ISEA,UA(ISEA),MAPSF(ISEA,1), MAPSF(ISEA,2),UA0(ISEA),RD,UAI(ISEA) @@ -595,35 +677,51 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) ! END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! ! 3.b Bias correction ( !/WCOR ) -!/WCOR WHERE ( UA .GE. WWCOR(1) ) UA = UA+(UA-WWCOR(1))*WWCOR(2) +#ifdef W3_WCOR + WHERE ( UA .GE. WWCOR(1) ) UA = UA+(UA-WWCOR(1))*WWCOR(2) +#endif ! ! 4. Correct for currents and grid motion ! -!/RWND IF ( FLCUR ) THEN +#ifdef W3_RWND + IF ( FLCUR ) THEN +#endif ! -!/RWND DO ISEA=1, NSEA -!/RWND UXR = UA(ISEA)*COS(UD(ISEA)) - RWINDC*CX(ISEA) -!/RWND UYR = UA(ISEA)*SIN(UD(ISEA)) - RWINDC*CY(ISEA) -!/RWND U10 (ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) -!/RWND U10D(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) -!/RWND END DO +#ifdef W3_RWND + DO ISEA=1, NSEA + UXR = UA(ISEA)*COS(UD(ISEA)) - RWINDC*CX(ISEA) + UYR = UA(ISEA)*SIN(UD(ISEA)) - RWINDC*CY(ISEA) + U10 (ISEA) = MAX ( 0.001 , SQRT(UXR**2+UYR**2) ) + U10D(ISEA) = MOD ( TPI+ATAN2(UYR,UXR) , TPI ) + END DO +#endif ! -!/RWND ELSE +#ifdef W3_RWND + ELSE +#endif ! -!/OMPG/!$OMP PARALLEL DO PRIVATE (ISEA) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE (ISEA) +#endif ! DO ISEA=1, NSEA U10 (ISEA) = MAX ( UA(ISEA) , 0.001 ) U10D(ISEA) = UD(ISEA) END DO ! -!/OMPG/!$OMP END PARALLEL DO +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif ! -!/RWND END IF +#ifdef W3_RWND + END IF +#endif ! ! 5. Stability correction ( !/STAB2 ) ! Original settings : @@ -635,26 +733,36 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) ! FFNG = -150. ! FFPS = 150. ! -!/STAB2 STAB0 = ZWIND * GRAV / 273. -! -!/STAB2 DO ISEA=1, NSEA -!/STAB2 STAB = STAB0 * AS(ISEA) / MAX(5.,U10(ISEA))**2 -!/STAB2 STAB = MAX ( -1. , MIN ( 1. , STAB ) ) -! -!/STAB2 THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) -!/STAB2 THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) -!/STAB2 COR1 = CCNG * TANH(THARG1) -!/STAB2 COR2 = CCPS * TANH(THARG2) +#ifdef W3_STAB2 + STAB0 = ZWIND * GRAV / 273. +#endif ! -!/STAB2 ASF(ISEA) = SQRT ( (1.+COR1+COR2)/SHSTAB ) -!/STAB2 U10(ISEA) = U10(ISEA) / ASF(ISEA) -!/STAB2 END DO +#ifdef W3_STAB2 + DO ISEA=1, NSEA + STAB = STAB0 * AS(ISEA) / MAX(5.,U10(ISEA))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) +#endif +! +#ifdef W3_STAB2 + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) +#endif +! +#ifdef W3_STAB2 + ASF(ISEA) = SQRT ( (1.+COR1+COR2)/SHSTAB ) + U10(ISEA) = U10(ISEA) / ASF(ISEA) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3UWND : DT0N, DT0T, RD :',2F8.1,F6.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3UWND : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif !/ !/ End of W3UWND ----------------------------------------------------- / !/ @@ -730,8 +838,10 @@ SUBROUTINE W3UTAU ( FLFRST ) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NSEA, MAPSF -!/SMC USE W3GDATMD, ONLY: NARC, NGLO, ANGARC -!/SMC USE W3GDATMD, ONLY: FSWND, ARCTC +#ifdef W3_SMC + USE W3GDATMD, ONLY: NARC, NGLO, ANGARC + USE W3GDATMD, ONLY: FSWND, ARCTC +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: TAUA, TAUADIR, MA0, MAI, MD0, MDI USE W3IDATMD, ONLY: TU0, UX0, UY0, TUN, UXN, UYN @@ -746,29 +856,39 @@ SUBROUTINE W3UTAU ( FLFRST ) !/ ------------------------------------------------------------------- / !/ INTEGER :: ISEA, IX, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: D0, DN, DD, DT0N, DT0T, RD, MI2, & MXR, MYR -!/WNT2 REAL :: RD2 +#ifdef W3_WNT2 + REAL :: RD2 +#endif REAL :: MDARC !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UTAU') +#ifdef W3_S + CALL STRACE (IENT, 'W3UTAU') +#endif ! ! 1. Prepare auxiliary arrays ! IF ( FLFRST ) THEN DO ISEA=1, NSEA -!/SMC !!Li For sea-point only SMC grid momentum 1-D momentum is stored on -!/SMC !!Li 2-D UX0(NSEA, 1) variable. -!/SMC IF( FSWND ) THEN -!/SMC IX = ISEA -!/SMC IY = 1 -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea-point only SMC grid momentum 1-D momentum is stored on + !!Li 2-D UX0(NSEA, 1) variable. + IF( FSWND ) THEN + IX = ISEA + IY = 1 + ELSE +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif MA0(ISEA) = SQRT ( UX0(IX,IY)**2 + UY0(IX,IY)**2 ) MAI(ISEA) = SQRT ( UXN(IX,IY)**2 + UYN(IX,IY)**2 ) @@ -799,30 +919,46 @@ SUBROUTINE W3UTAU ( FLFRST ) DT0N = DSEC21 ( TU0, TUN ) DT0T = DSEC21 ( TU0, TIME ) ! -!/WNT0 RD = 0. -!/WNT1 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/WNT2 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/WNT2 RD2 = 1. - RD -!/OASACM RD = 1. -! -!/T WRITE (NDST,9000) DT0N, DT0T, RD +#ifdef W3_WNT0 + RD = 0. +#endif +#ifdef W3_WNT1 + RD = DT0T / MAX ( 1.E-7 , DT0N ) +#endif +#ifdef W3_WNT2 + RD = DT0T / MAX ( 1.E-7 , DT0N ) + RD2 = 1. - RD +#endif +#ifdef W3_OASACM + RD = 1. +#endif +! +#ifdef W3_T + WRITE (NDST,9000) DT0N, DT0T, RD +#endif ! ! 3. Actual momentum for all grid points ! -!/OMPG/!$OMP PARALLEL DO PRIVATE (ISEA,MI2,MXR,MYR,MDARC) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE (ISEA,MI2,MXR,MYR,MDARC) +#endif ! DO ISEA=1, NSEA ! TAUA(ISEA) = MA0(ISEA) + RD * MAI(ISEA) -!/WNT2 MI2 = SQRT ( RD2 * MA0(ISEA)**2 + & -!/WNT2 RD *(MA0(ISEA)+MAI(ISEA))**2 ) -!/WNT2 TAUA(ISEA) = TAUA(ISEA) * MIN(1.25,MI2/MAX(1.E-7,TAUA(ISEA))) +#ifdef W3_WNT2 + MI2 = SQRT ( RD2 * MA0(ISEA)**2 + & + RD *(MA0(ISEA)+MAI(ISEA))**2 ) + TAUA(ISEA) = TAUA(ISEA) * MIN(1.25,MI2/MAX(1.E-7,TAUA(ISEA))) +#endif TAUADIR(ISEA) = MD0(ISEA) + RD * MDI(ISEA) -!/SMC !Li Rotate momentum direction by ANGARC for Arctic part cells. -!/SMC IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN -!/SMC MDARC = TAUADIR(ISEA) + ANGARC( ISEA - NGLO )*DERA -!/SMC TAUADIR(ISEA) = MOD ( TPI + MDARC, TPI ) -!/SMC ENDIF +#ifdef W3_SMC + !Li Rotate momentum direction by ANGARC for Arctic part cells. + IF( ARCTC .AND. (ISEA .GT. NGLO) ) THEN + MDARC = TAUADIR(ISEA) + ANGARC( ISEA - NGLO )*DERA + TAUADIR(ISEA) = MOD ( TPI + MDARC, TPI ) + ENDIF +#endif ! END DO ! @@ -830,7 +966,9 @@ SUBROUTINE W3UTAU ( FLFRST ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3UTAU : DT0N, DT0T, RD :',2F8.1,F6.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3UTAU : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif !/ !/ End of W3UTAU ----------------------------------------------------- / !/ @@ -917,7 +1055,9 @@ SUBROUTINE W3UINI ( A ) USE W3ADATMD, ONLY: U10, U10D, CG USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA USE W3PARALL, only : GET_JSEA_IBELONG -!/T USE W3ARRYMD, ONLY : PRTBLK +#ifdef W3_T + USE W3ARRYMD, ONLY : PRTBLK +#endif ! IMPLICIT NONE !/ @@ -930,9 +1070,13 @@ SUBROUTINE W3UINI ( A ) !/ Local variables !/ INTEGER :: IX, IY, ISEA, JSEA, IK, ITH, ISPROC -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: IX0, IXN, MAPOUT(NX,NY) -!/T INTEGER :: NXP = 60 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: IX0, IXN, MAPOUT(NX,NY) + INTEGER :: NXP = 60 +#endif REAL :: ALFA(NSEAL), FP(NSEAL), YLN(NSEAL), & AA, BB, CC REAL :: XGR, U10C, U10DIR, XSTAR, FSTAR, & @@ -940,16 +1084,22 @@ SUBROUTINE W3UINI ( A ) REAL :: ETOT, E1I REAL :: U10MIN = 1. REAL :: U10MAX = 20. -!/T REAL :: HSIG(NX,NY) +#ifdef W3_T + REAL :: HSIG(NX,NY) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UINI') +#ifdef W3_S + CALL STRACE (IENT, 'W3UINI') +#endif ! ! ! Pre-process JONSWAP data for all grid points ----------------------- * ! -!/T1 WRITE (NDST,9010) +#ifdef W3_T1 + WRITE (NDST,9010) +#endif ! ! this is not clear what is going on betwen w3init and this ... A(:,:,:)=0 @@ -976,8 +1126,10 @@ SUBROUTINE W3UINI ( A ) FP (JSEA) = FSTAR * GRAV / U10C YLN (JSEA) = LOG ( GAMMA ) ! -!/T1 WRITE (NDST,9011) ISEA, U10C, XSTAR, & -!/T1 ALFA(JSEA), FP(JSEA), GAMMA +#ifdef W3_T1 + WRITE (NDST,9011) ISEA, U10C, XSTAR, & + ALFA(JSEA), FP(JSEA), GAMMA +#endif ! END DO ! @@ -1026,42 +1178,52 @@ SUBROUTINE W3UINI ( A ) ! ! Test output -------------------------------------------------------- * ! -!/T HSIG = 0. -!/T MAPOUT = 0 -! -!/T DO ISEA=IAPROC, NSEA, NAPROC -!/T JSEA = 1 + (ISEA-1)/NAPROC -!/T ETOT = 0. -!/T DO IK=1, NK -!/T E1I = 0. -!/T DO ITH=1, NTH -!/T E1I = E1I + A(ITH,IK,JSEA) -!/T END DO -!/T ETOT = ETOT + E1I * DSIP(IK) * SIG(IK) / CG(IK,ISEA) -!/T END DO -!/T IX = MAPSF(ISEA,1) -!/T IY = MAPSF(ISEA,2) -!/T HSIG (IX,IY) = 4. * SQRT ( ETOT * DTH ) -!/T MAPOUT(IX,IY) = 1 -!/T END DO -! -!/T IX0 = 1 -!/T DO -!/T IXN = MIN ( NX , IX0+NXP-1 ) -!/T CALL PRTBLK (NDST, NX, NY, NX, HSIG, MAPOUT, 0, 0., & -!/T IX0, IXN, 1, 1, NY, 1, 'Hs', 'm') -!/T IF ( IXN .EQ. NX ) EXIT -!/T IX0 = IX0 + NXP -!/T END DO +#ifdef W3_T + HSIG = 0. + MAPOUT = 0 +#endif +! +#ifdef W3_T + DO ISEA=IAPROC, NSEA, NAPROC + JSEA = 1 + (ISEA-1)/NAPROC + ETOT = 0. + DO IK=1, NK + E1I = 0. + DO ITH=1, NTH + E1I = E1I + A(ITH,IK,JSEA) + END DO + ETOT = ETOT + E1I * DSIP(IK) * SIG(IK) / CG(IK,ISEA) + END DO + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HSIG (IX,IY) = 4. * SQRT ( ETOT * DTH ) + MAPOUT(IX,IY) = 1 + END DO +#endif +! +#ifdef W3_T + IX0 = 1 + DO + IXN = MIN ( NX , IX0+NXP-1 ) + CALL PRTBLK (NDST, NX, NY, NX, HSIG, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Hs', 'm') + IF ( IXN .EQ. NX ) EXIT + IX0 = IX0 + NXP + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3UINI : XGR = ',E10.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3UINI : XGR = ',E10.3) +#endif ! -!/T1 9010 FORMAT (' TEST W3UINI : ISEA, U10C, XSTAR, ALPHA, FP, GAMMA') -!/T1 9011 FORMAT (' ',I6,F8.2,F10.1,2F6.3,F6.2) +#ifdef W3_T1 + 9010 FORMAT (' TEST W3UINI : ISEA, U10C, XSTAR, ALPHA, FP, GAMMA') + 9011 FORMAT (' ',I6,F8.2,F10.1,2F6.3,F6.2) +#endif !/ !/ End of W3UINI ----------------------------------------------------- / !/ @@ -1136,9 +1298,11 @@ SUBROUTINE W3UBPT ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NSPEC, MAPWN, SIG2, DDEN -!/RTD !! Use rotation angle and action conversion sub. JGLi12Jun2012 -!/RTD USE W3GDATMD, ONLY: NK, NTH, NSPEC, AnglD, PoLat -!/RTD USE W3SERVMD, ONLY: W3ACTURN +#ifdef W3_RTD + !! Use rotation angle and action conversion sub. JGLi12Jun2012 + USE W3GDATMD, ONLY: NK, NTH, NSPEC, AnglD, PoLat + USE W3SERVMD, ONLY: W3ACTURN +#endif USE W3ADATMD, ONLY: CG USE W3ODATMD, ONLY: NBI, ABPI0, ABPIN, ISBPI, IPBPI, RDBPI, & BBPI0, BBPIN @@ -1151,20 +1315,30 @@ SUBROUTINE W3UBPT !/ ------------------------------------------------------------------- / !/ INTEGER :: IBI, ISP, ISEA -!/S INTEGER, SAVE :: IENT = 0 -!/T0 REAL :: HS1, HS2 -!/RTD !! Declare a temporary spectr variable. JGLi12Jun2012 -!/RTD REAL :: Spectr(NSPEC), AnglBP +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T0 + REAL :: HS1, HS2 +#endif +#ifdef W3_RTD + !! Declare a temporary spectr variable. JGLi12Jun2012 + REAL :: Spectr(NSPEC), AnglBP +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UBPT') +#ifdef W3_S + CALL STRACE (IENT, 'W3UBPT') +#endif ! ! 1. Process BBPI0 -------------------------------------------------- * ! 1.a First intialization -!/DEBUGIOBC WRITE(740+IAPROC,*) 'Beginning of W3UBPT' -!/DEBUGIOBC FLUSH(740+IAPROC) +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'Beginning of W3UBPT' + FLUSH(740+IAPROC) +#endif ! IF ( BBPI0(1,0) .EQ. -1. ) THEN @@ -1203,47 +1377,55 @@ SUBROUTINE W3UBPT + RDBPI(IBI,4) * ABPIN(ISP,IPBPI(IBI,4)) ) END DO ! -!/RTD !! Rotate the spectra if model is on rotated grid. JGLi12Jun2012 -!/RTD !! PoLat == 90. if the grid is standard lat/lon (C. Hansen 20190613) -!/RTD IF ( PoLat < 90. ) THEN -!/RTD Spectr = BBPIN(:,IBI) -!/RTD AnglBP = AnglD(ISEA) -!/RTD CALL W3ACTURN( NTH, NK, AnglBP, Spectr ) -!/RTD BBPIN(:,IBI) = Spectr -!/RTD END IF -!/RTD +#ifdef W3_RTD + !! Rotate the spectra if model is on rotated grid. JGLi12Jun2012 + !! PoLat == 90. if the grid is standard lat/lon (C. Hansen 20190613) + IF ( PoLat < 90. ) THEN + Spectr = BBPIN(:,IBI) + AnglBP = AnglD(ISEA) + CALL W3ACTURN( NTH, NK, AnglBP, Spectr ) + BBPIN(:,IBI) = Spectr + END IF + +#endif ! END DO ! 3. Wave height test output ---------------------------------------- * ! -!/T0 WRITE (NDST,9000) -!/T0 DO IBI=1, NBI -!/T0 HS1 = 0. -!/T0 HS2 = 0. -!/T0 DO ISP=1, NSPEC -!/T0 HS1 = HS1 + BBPI0(ISP,IBI) * DDEN(MAPWN(ISP)) / & -!/T0 CG(MAPWN(ISP),ISBPI(IBI)) -!/T0 HS2 = HS2 + BBPIN(ISP,IBI) * DDEN(MAPWN(ISP)) / & -!/T0 CG(MAPWN(ISP),ISBPI(IBI)) -!/T0 END DO -!/T0 HS1 = 4. * SQRT ( HS1 ) -!/T0 HS2 = 4. * SQRT ( HS2 ) -!/T0 WRITE (NDST,9001) IBI, ISBPI(IBI), HS1, HS2 -!/T0 END DO -! -!/DEBUGIOBC WRITE(740+IAPROC,*) 'sum(abs(ABPI0))=', sum(abs(ABPI0)) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'sum(abs(ABPIN))=', sum(abs(ABPIN)) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'sum(abs(BBPI0))=', sum(abs(BBPI0)) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'sum(abs(BBPIN))=', sum(abs(BBPIN)) -!/DEBUGIOBC WRITE(740+IAPROC,*) 'End of W3UBPT' -!/DEBUGIOBC FLUSH(740+IAPROC) +#ifdef W3_T0 + WRITE (NDST,9000) + DO IBI=1, NBI + HS1 = 0. + HS2 = 0. + DO ISP=1, NSPEC + HS1 = HS1 + BBPI0(ISP,IBI) * DDEN(MAPWN(ISP)) / & + CG(MAPWN(ISP),ISBPI(IBI)) + HS2 = HS2 + BBPIN(ISP,IBI) * DDEN(MAPWN(ISP)) / & + CG(MAPWN(ISP),ISBPI(IBI)) + END DO + HS1 = 4. * SQRT ( HS1 ) + HS2 = 4. * SQRT ( HS2 ) + WRITE (NDST,9001) IBI, ISBPI(IBI), HS1, HS2 + END DO +#endif +! +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'sum(abs(ABPI0))=', sum(abs(ABPI0)) + WRITE(740+IAPROC,*) 'sum(abs(ABPIN))=', sum(abs(ABPIN)) + WRITE(740+IAPROC,*) 'sum(abs(BBPI0))=', sum(abs(BBPI0)) + WRITE(740+IAPROC,*) 'sum(abs(BBPIN))=', sum(abs(BBPIN)) + WRITE(740+IAPROC,*) 'End of W3UBPT' + FLUSH(740+IAPROC) +#endif RETURN ! ! Formats ! -!/T0 9000 FORMAT ( ' TEST W3UBPT : WAVE HEIGHTS BBPI0/N (NO TAIL)') -!/T0 9001 FORMAT ( ' ',2I8,2X,2F8.2) +#ifdef W3_T0 + 9000 FORMAT ( ' TEST W3UBPT : WAVE HEIGHTS BBPI0/N (NO TAIL)') + 9001 FORMAT ( ' ',2I8,2X,2F8.2) +#endif !/ !/ End of W3UBPT ----------------------------------------------------- / @@ -1326,7 +1508,9 @@ SUBROUTINE W3UIC1( FLFRST ) ! 1. Preparations --------------------------------------------------- * ! 1.a Update times ! -!/T WRITE (NDST,9010) TIME, TIC1, TI1 +#ifdef W3_T + WRITE (NDST,9010) TIME, TIC1, TI1 +#endif TIC1(1) = TI1(1) TIC1(2) = TI1(2) @@ -1340,9 +1524,11 @@ SUBROUTINE W3UIC1( FLFRST ) END DO ! RETURN -!/T 9010 FORMAT ( ' TEST W3UIC1 : TIME :',I9.8,I7.6/ & -!/T ' OLD TICE :',I9.8,I7.6/ & -!/T ' NEW TICE :',I9.8,I7.6) +#ifdef W3_T + 9010 FORMAT ( ' TEST W3UIC1 : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) +#endif !/ !/ End of W3UIC1 ----------------------------------------------------- / !/ @@ -1427,7 +1613,9 @@ SUBROUTINE W3UIC5( FLFRST ) ! 1. Preparations --------------------------------------------------- * ! 1.a Update times ! -!/T WRITE (NDST,9010) TIME, TIC5, TI5 +#ifdef W3_T + WRITE (NDST,9010) TIME, TIC5, TI5 +#endif TIC5(1) = TI5(1) TIC5(2) = TI5(2) @@ -1448,9 +1636,11 @@ SUBROUTINE W3UIC5( FLFRST ) END DO ! RETURN -!/T 9010 FORMAT ( ' TEST W3UIC5 : TIME :',I9.8,I7.6/ & -!/T ' OLD TICE :',I9.8,I7.6/ & -!/T ' NEW TICE :',I9.8,I7.6) +#ifdef W3_T + 9010 FORMAT ( ' TEST W3UIC5 : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) +#endif !/ !/ @@ -1555,30 +1745,40 @@ SUBROUTINE W3UICE ( A, VA ) !/ ------------------------------------------------------------------- / !/ INTEGER :: IK, ITH, ISEA, JSEA, IX, IY, ISP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: MAPICE(NY,NX), ISPROC LOGICAL :: LOCAL !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UICE') +#ifdef W3_S + CALL STRACE (IENT, 'W3UICE') +#endif ! LOCAL = IAPROC .LE. NAPROC ! -!/T WRITE (NDST,9000) FICEN -!/T IF ( .NOT. LOCAL ) WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9000) FICEN + IF ( .NOT. LOCAL ) WRITE (NDST,9001) +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Update times ! -!/T WRITE (NDST,9010) TIME, TICE, TIN +#ifdef W3_T + WRITE (NDST,9010) TIME, TICE, TIN +#endif TICE(1) = TIN(1) TICE(2) = TIN(2) ! ! 1.b Process maps ! -!/IC0 MAPICE = MOD(MAPST2,2) -!/IC0 MAPST2 = MAPST2 - MAPICE +#ifdef W3_IC0 + MAPICE = MOD(MAPST2,2) + MAPST2 = MAPST2 - MAPICE +#endif ! ! 2. Main loop over sea points -------------------------------------- * ! @@ -1593,76 +1793,132 @@ SUBROUTINE W3UICE ( A, VA ) ! ! 2.b Sea point to be de-activated.. ! -!/IC0 IF ( ICEI(IX,IY).GE.FICEN .AND. MAPICE(IY,IX).EQ.0 ) THEN -!/IC0 MAPSTA(IY,IX) = - ABS(MAPSTA(IY,IX)) -!/IC0 MAPICE(IY,IX) = 1 +#ifdef W3_IC0 + IF ( ICEI(IX,IY).GE.FICEN .AND. MAPICE(IY,IX).EQ.0 ) THEN + MAPSTA(IY,IX) = - ABS(MAPSTA(IY,IX)) + MAPICE(IY,IX) = 1 +#endif !AR: Take care here situation is not totally clear! -!/IC0 CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/IC0 IF (LOCAL .AND. (IAPROC .eq. ISPROC)) THEN -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'ICE (NEW)' -!/IC0 VA(:,JSEA) = 0. -!/IC0 ELSE -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'ICE (NEW X)' -!/IC0 END IF -! -!/IC0 ELSE IF ( ICEI(IX,IY).GE.FICEN ) THEN -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'ICE' -!/IC0 END IF +#ifdef W3_IC0 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF (LOCAL .AND. (IAPROC .eq. ISPROC)) THEN +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE (NEW)' +#endif +#ifdef W3_IC0 + VA(:,JSEA) = 0. + ELSE +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE (NEW X)' +#endif +#ifdef W3_IC0 + END IF +#endif +! +#ifdef W3_IC0 + ELSE IF ( ICEI(IX,IY).GE.FICEN ) THEN +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'ICE' +#endif +#ifdef W3_IC0 + END IF +#endif ! ! 2.b Ice point to be re-activated. ! -!/IC0 IF ( ICEI(IX,IY).LT.FICEN .AND. MAPICE(IY,IX).EQ.1 ) THEN -! -!/IC0 MAPICE(IY,IX) = 0 -!/IC0 UST(ISEA) = 0.05 -! -!/IC0 IF ( MAPST2(IY,IX) .EQ. 0 ) THEN -!/IC0 MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) -! -!/IC0 CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/IC0 IF ( LOCAL .AND. (IAPROC .eq. ISPROC) ) THEN -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'SEA (NEW)' -!/IC0 VA(:,JSEA) = 0. -! -!/IC0 ELSE -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'SEA (NEW X)' -!/IC0 END IF +#ifdef W3_IC0 + IF ( ICEI(IX,IY).LT.FICEN .AND. MAPICE(IY,IX).EQ.1 ) THEN +#endif +! +#ifdef W3_IC0 + MAPICE(IY,IX) = 0 + UST(ISEA) = 0.05 +#endif +! +#ifdef W3_IC0 + IF ( MAPST2(IY,IX) .EQ. 0 ) THEN + MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) +#endif +! +#ifdef W3_IC0 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF ( LOCAL .AND. (IAPROC .eq. ISPROC) ) THEN +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA (NEW)' +#endif +#ifdef W3_IC0 + VA(:,JSEA) = 0. +#endif +! +#ifdef W3_IC0 + ELSE +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA (NEW X)' +#endif +#ifdef W3_IC0 + END IF +#endif ! -!/IC0 ELSE -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'DIS' -!/IC0 END IF +#ifdef W3_IC0 + ELSE +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'DIS' +#endif +#ifdef W3_IC0 + END IF +#endif ! -!/IC0 ELSE IF ( ICEI(IX,IY).LT.FICEN ) THEN -!/T WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & -!/T ICEI(IX,IY), 'SEA' +#ifdef W3_IC0 + ELSE IF ( ICEI(IX,IY).LT.FICEN ) THEN +#endif +#ifdef W3_T + WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & + ICEI(IX,IY), 'SEA' +#endif ! -!/IC0 END IF +#ifdef W3_IC0 + END IF +#endif ! END DO ! ! 3. Update MAPST2 -------------------------------------------------- * ! -!/IC0 MAPST2 = MAPST2 + MAPICE +#ifdef W3_IC0 + MAPST2 = MAPST2 + MAPICE +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3UICE : FICEN :',F9.3) -!/T 9001 FORMAT ( ' TEST W3UICE : NO LOCAL SPECTRA') +#ifdef W3_T + 9000 FORMAT ( ' TEST W3UICE : FICEN :',F9.3) + 9001 FORMAT ( ' TEST W3UICE : NO LOCAL SPECTRA') +#endif ! -!/T 9010 FORMAT ( ' TEST W3UICE : TIME :',I9.8,I7.6/ & -!/T ' OLD TICE :',I9.8,I7.6/ & -!/T ' NEW TICE :',I9.8,I7.6) +#ifdef W3_T + 9010 FORMAT ( ' TEST W3UICE : TIME :',I9.8,I7.6/ & + ' OLD TICE :',I9.8,I7.6/ & + ' NEW TICE :',I9.8,I7.6) +#endif ! -!/T 9020 FORMAT ( ' TEST W3UICE : ISEA, IX, IY, MAP, ICE, STATUS :') -!/T 9021 FORMAT ( ' ',I8,3I4,F6.2,2X,A) +#ifdef W3_T + 9020 FORMAT ( ' TEST W3UICE : ISEA, IX, IY, MAP, ICE, STATUS :') + 9021 FORMAT ( ' ',I8,3I4,F6.2,2X,A) +#endif !/ !/ End of W3UICE ----------------------------------------------------- / !/ @@ -1767,14 +2023,20 @@ SUBROUTINE W3ULEV ( A, VA ) USE W3PARALL, only : INIT_GET_JSEA_ISPROC, INIT_GET_ISEA USE W3PARALL, only : GET_JSEA_IBELONG USE W3DISPMD, ONLY: WAVNU1 -!/TIDE USE W3GDATMD, ONLY: YGRD -!/TIDE USE W3IDATMD, ONLY: FLLEVTIDE, WLTIDE, NTIDE -!/TIDE USE W3TIDEMD -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP -!/SETUP USE W3GDATMD, ONLY : DO_CHANGE_WLV +#ifdef W3_TIDE + USE W3GDATMD, ONLY: YGRD + USE W3IDATMD, ONLY: FLLEVTIDE, WLTIDE, NTIDE + USE W3TIDEMD +#endif +#ifdef W3_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3GDATMD, ONLY : DO_CHANGE_WLV +#endif -!/T3 USE W3ARRYMD, ONLY: PRT2DS +#ifdef W3_T3 + USE W3ARRYMD, ONLY: PRT2DS +#endif !/ IMPLICIT NONE !/ @@ -1787,7 +2049,9 @@ SUBROUTINE W3ULEV ( A, VA ) !/ INTEGER :: ISEA, JSEA, IX, IY, IK, I1, I2, & ISPEC, IK0, ITH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: MAPDRY(NY,NX), ISPROC REAL :: DWO(NSEA), KDCHCK, WNO(0:NK+1), & CGO(0:NK+1), DEPTH, & @@ -1795,34 +2059,48 @@ SUBROUTINE W3ULEV ( A, VA ) OWN(NK), DWN(NK) REAL :: KDMAX = 4., RDKMIN = 0.05 REAL :: WLVeff -!/T3 REAL :: OUT(NK,NTH) +#ifdef W3_T3 + REAL :: OUT(NK,NTH) +#endif LOGICAL :: LOCAL INTEGER :: IBELONG ! -!/TIDE INTEGER :: J -!/TIDE INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" -!/TIDE REAL :: WLEVTIDE, TIDE_ARG, WLEVTIDE2(1) -!/TIDE REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau -!/TIDE REAL :: FX(44),UX(44),VX(44) -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 1' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_TIDE + INTEGER :: J + INTEGER(KIND=4) :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" + REAL :: WLEVTIDE, TIDE_ARG, WLEVTIDE2(1) + REAL(KIND=8) :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau + REAL :: FX(44),UX(44),VX(44) +#endif +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 1' + FLUSH(740+IAPROC) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3ULEV') +#ifdef W3_S + CALL STRACE (IENT, 'W3ULEV') +#endif ! LOCAL = IAPROC .LE. NAPROC -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 2' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 2' + FLUSH(740+IAPROC) +#endif ! -!/T WRITE (NDST,9000) KDMAX, RDKMIN +#ifdef W3_T + WRITE (NDST,9000) KDMAX, RDKMIN +#endif ! ! 1. Preparations --------------------------------------------------- * ! 1.a Check NK ! -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 3' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 3' + FLUSH(740+IAPROC) +#endif IF ( NK .LT. 2 ) THEN IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) CALL EXTCDE ( 1 ) @@ -1830,92 +2108,114 @@ SUBROUTINE W3ULEV ( A, VA ) ! ! 1.b Update times ! -!/T WRITE (NDST,9010) TIME, TLEV +#ifdef W3_T + WRITE (NDST,9010) TIME, TLEV +#endif TLEV = TLN -!/T WRITE (NDST,9011) TLEV +#ifdef W3_T + WRITE (NDST,9011) TLEV +#endif ! ! 1.c Extract dry point map, and residual MAPST2 ! MAPDRY = MOD(MAPST2/2,2) MAPST2 = MAPST2 - 2*MAPDRY -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 4' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 4' + FLUSH(740+IAPROC) +#endif ! ! 1.d Update water levels and save old ! -!/TIDE IF (FLLEVTIDE) THEN -!/TIDE! WRITE(6,*) 'TIME:',TIME -!/TIDE TIDE_HOUR = TIME2HOURS(TIME) -!/TIDE! -!/TIDE!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION -!/TIDE!* AT THE MID POINT OF THE ANALYSIS PERIOD. -!/TIDE d1=TIDE_HOUR/24.d0 -!/TIDE TIDE_KD0= 2415020 -!/TIDE d1=d1-dfloat(TIDE_kd0)-0.5d0 -!/TIDE call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) -!/TIDE INT24=24 -!/TIDE INTDYS=int((TIDE_HOUR+0.00001)/INT24) -!/TIDE HH=TIDE_HOUR-dfloat(INTDYS*INT24) -!/TIDE TAU=HH/24.D0+H-S -!/TIDE END IF -!/TIDE! -!/TIDE! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- -!/TIDE! TING THE LUNAR TIME TAU. -!/TIDE! -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 5' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_TIDE + IF (FLLEVTIDE) THEN +! WRITE(6,*) 'TIME:',TIME + TIDE_HOUR = TIME2HOURS(TIME) +! +!* THE ASTRONOMICAL ARGUMENTS ARE CALCULATED BY LINEAR APPROXIMATION +!* AT THE MID POINT OF THE ANALYSIS PERIOD. + d1=TIDE_HOUR/24.d0 + TIDE_KD0= 2415020 + d1=d1-dfloat(TIDE_kd0)-0.5d0 + call astr(d1,h,pp,s,p,enp,dh,dpp,ds,dp,dnp) + INT24=24 + INTDYS=int((TIDE_HOUR+0.00001)/INT24) + HH=TIDE_HOUR-dfloat(INTDYS*INT24) + TAU=HH/24.D0+H-S + END IF +! +! ONLY THE FRACTIONAL PART OF A SOLAR DAY NEED BE RETAINED FOR COMPU- +! TING THE LUNAR TIME TAU. +! +#endif +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 5' + FLUSH(740+IAPROC) +#endif DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) DWO(ISEA) = DW(ISEA) ! -!/TIDE IF (FLLEVTIDE) THEN -!/TIDE! VUF should be updated only if latitude changes significantly ... -!/TIDE CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),FX,UX,VX) -!/TIDE WLEVTIDE = WLTIDE(IX,IY,1,1) -!/TIDE !Verification -!/TIDE ! IF (ISEA.EQ.1) THEN -!/TIDE -!/TIDE TIDE_AMPC(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,1) -!/TIDE TIDE_PHG(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,2) -!/TIDE! -!/TIDE ! WRITE(991,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & -!/TIDE ! d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) -!/TIDE J=1 -!/TIDE ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & -!/TIDE ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) -!/TIDE DO J=2,TIDE_MF -!/TIDE TIDE_ARG=(VX(J)+UX(J))*twpi-WLTIDE(IX,IY,J,2)*DERA -!/TIDE WLEVTIDE =WLEVTIDE+FX(J)*WLTIDE(IX,IY,J,1)*COS(TIDE_ARG) -!/TIDE ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & -!/TIDE ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) -!/TIDE END DO -!/TIDE DO J=1,TIDE_MF -!/TIDE ! WRITE(991,'(A,4I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,J,TIME,TIDE_HOUR, & -!/TIDE ! FX(J),UX(J),VX(J),TIDE_AMPC(J,1),TIDE_PHG(J,1) -!/TIDE END DO -!/TIDE ! WRITE(991,'(A,3F7.3)') '#:',WLEV(IX,IY),WLEVTIDE,WLEV(IX,IY)-WLEVTIDE +#ifdef W3_TIDE + IF (FLLEVTIDE) THEN +! VUF should be updated only if latitude changes significantly ... + CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),FX,UX,VX) + WLEVTIDE = WLTIDE(IX,IY,1,1) + !Verification + ! IF (ISEA.EQ.1) THEN -!/TIDE ! CLOSE(991) -!/TIDE ! END IF -!/TIDE ! End of verification -!/TIDE WLV(ISEA) = WLEVTIDE -!/TIDE ELSE + TIDE_AMPC(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,1) + TIDE_PHG(1:NTIDE,1)=WLTIDE(IX,IY,1:NTIDE,2) +! + ! WRITE(991,'(A,F20.2,13F8.3)') 'TEST ISEA 0:', & + ! d1,H,S,TAU,pp,s,p,enp,dh,dpp,ds,dp,dnp,YGRD(IY,IX) + J=1 + ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + DO J=2,TIDE_MF + TIDE_ARG=(VX(J)+UX(J))*twpi-WLTIDE(IX,IY,J,2)*DERA + WLEVTIDE =WLEVTIDE+FX(J)*WLTIDE(IX,IY,J,1)*COS(TIDE_ARG) + ! WRITE(991,'(A,4I9,F12.0,3F8.3,I4,X,A)') 'TEST ISEA 1:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_INDEX2(J),TIDECON_ALLNAMES(TIDE_INDEX2(J)) + END DO + DO J=1,TIDE_MF + ! WRITE(991,'(A,4I9,F12.0,5F8.3)') 'TEST ISEA 2:',IX,J,TIME,TIDE_HOUR, & + ! FX(J),UX(J),VX(J),TIDE_AMPC(J,1),TIDE_PHG(J,1) + END DO + ! WRITE(991,'(A,3F7.3)') '#:',WLEV(IX,IY),WLEVTIDE,WLEV(IX,IY)-WLEVTIDE +#endif + +#ifdef W3_TIDE + ! CLOSE(991) + ! END IF + ! End of verification + WLV(ISEA) = WLEVTIDE + ELSE +#endif ! WLV(ISEA) = WLEV(IX,IY) WLVeff=WLV(ISEA) -!/SETUP IF (DO_CHANGE_WLV) THEN -!/SETUP WLVeff=WLVeff + ZETA_SETUP(ISEA) -!/SETUP END IF -!/TIDE ENDIF +#ifdef W3_SETUP + IF (DO_CHANGE_WLV) THEN + WLVeff=WLVeff + ZETA_SETUP(ISEA) + END IF +#endif +#ifdef W3_TIDE + ENDIF +#endif DW (ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) END DO -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 6' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 6' + FLUSH(740+IAPROC) +#endif ! ! 2. Loop over all sea points --------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif ! DO ISEA=1, NSEA ! @@ -1955,11 +2255,13 @@ SUBROUTINE W3ULEV ( A, VA ) END IF MAPDRY(IY,IX) = 1 MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) -!/T2 WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & -!/T2 0., 0., ' (NEW DRY)' -!/T2 ELSE -!/T2 WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & -!/T2 0., 0., ' (DRY)' +#ifdef W3_T2 + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW DRY)' + ELSE + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (DRY)' +#endif ENDIF CYCLE END IF @@ -1979,11 +2281,13 @@ SUBROUTINE W3ULEV ( A, VA ) UST(ISEA) = 0.05 IF ( MAPST2(IY,IX) .EQ. 0 ) THEN MAPSTA(IY,IX) = ABS(MAPSTA(IY,IX)) -!/T2 WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & -!/T2 0., 0., ' (NEW WET)' -!/T2 ELSE -!/T2 WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & -!/T2 0., 0., ' (NEW WET INACTIVE)' +#ifdef W3_T2 + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW WET)' + ELSE + WRITE (NDST,9021) ISEA, WLV(ISEA)-ZB(ISEA), & + 0., 0., ' (NEW WET INACTIVE)' +#endif END IF CYCLE END IF @@ -1992,16 +2296,18 @@ SUBROUTINE W3ULEV ( A, VA ) ! RDK = ABS(WNO(1)-WN(1,ISEA)) / DWN(1) ! -!/T2 IF ( MAPSTA(IY,IX) .LT. 0 ) THEN -!/T2 WRITE (NDST,9021) & -!/T2 ISEA, DW(ISEA), KDCHCK, RDK, ' (INACTIVE)' -!/T2 ELSE IF ( RDK .LT. RDKMIN ) THEN -!/T2 WRITE (NDST,9021) & -!/T2 ISEA, DW(ISEA), KDCHCK, RDK, ' (NEGL)' -!/T2 ELSE -!/T2 WRITE (NDST,9021) & -!/T2 ISEA, DW(ISEA), KDCHCK, RDK, ' ' -!/T2 END IF +#ifdef W3_T2 + IF ( MAPSTA(IY,IX) .LT. 0 ) THEN + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' (INACTIVE)' + ELSE IF ( RDK .LT. RDKMIN ) THEN + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' (NEGL)' + ELSE + WRITE (NDST,9021) & + ISEA, DW(ISEA), KDCHCK, RDK, ' ' + END IF +#endif ! IF ( RDK.LT.RDKMIN .OR. MAPSTA(IY,IX).LT.0 ) CYCLE CALL GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) @@ -2013,15 +2319,19 @@ SUBROUTINE W3ULEV ( A, VA ) ! DO IK=1, NK DO ITH=1, NTH -!/T3 OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CGO(IK) +#ifdef W3_T3 + OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CGO(IK) +#endif TA(ITH,IK) = A(ITH,IK,JSEA) * OWN(IK) END DO END DO ! VA(:,JSEA) = 0. ! -!/T3 CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & -!/T3 TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'Before' ) +#ifdef W3_T3 + CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & + TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'Before' ) +#endif ! ! 2.e Redistribute discrete action density ! @@ -2093,22 +2403,30 @@ SUBROUTINE W3ULEV ( A, VA ) END DO END IF ! -!/T3 DO ISPEC=1, NSPEC -!/T3 IK = MAPWN(ISPEC) -!/T3 ITH = MAPTH(ISPEC) -!/T3 OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CG(IK,ISEA) -!/T3 END DO +#ifdef W3_T3 + DO ISPEC=1, NSPEC + IK = MAPWN(ISPEC) + ITH = MAPTH(ISPEC) + OUT(IK,ITH) = A(ITH,IK,JSEA) * SIG(IK) / CG(IK,ISEA) + END DO +#endif ! -!/T3 CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & -!/T3 TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'After' ) +#ifdef W3_T3 + CALL PRT2DS ( NDST, NK, NK, NTH, OUT, SIG, ' ', & + TPI, 0., 1.E-5, 'F(f,th)', 'm2s', 'After' ) +#endif ! -!/T2 ELSE -!/T2 WRITE (NDST,9021) ISEA, KDCHCK, ' (DEEP)' +#ifdef W3_T2 + ELSE + WRITE (NDST,9021) ISEA, KDCHCK, ' (DEEP)' +#endif END IF ! END DO -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 7' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 7' + FLUSH(740+IAPROC) +#endif ! ! 3. Reconstruct new MAPST2 ----------------------------------------- * ! @@ -2116,19 +2434,29 @@ SUBROUTINE W3ULEV ( A, VA ) ! ! 4. Re-generates the boundary data ---------------------------------- * ! -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 8' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 8' + FLUSH(740+IAPROC) +#endif IF (GTYPE.EQ.UNGTYPE) THEN -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 9' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 9' + FLUSH(740+IAPROC) +#endif CALL SETUGIOBP -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 10' -!/DEBUGW3ULEV FLUSH(740+IAPROC) -!/REF1 ELSE -!/REF1 CALL W3SETREF +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 10' + FLUSH(740+IAPROC) +#endif +#ifdef W3_REF1 + ELSE + CALL W3SETREF +#endif ENDIF -!/DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 11' -!/DEBUGW3ULEV FLUSH(740+IAPROC) +#ifdef W3_DEBUGW3ULEV + WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 11' + FLUSH(740+IAPROC) +#endif ! RETURN ! @@ -2137,16 +2465,22 @@ SUBROUTINE W3ULEV ( A, VA ) 1000 FORMAT (/' *** ERROR W3ULEV *** '/ & ' THIS ROUTINE REQUIRES NK > 1 '/) ! -!/T 9000 FORMAT ( ' TEST W3ULEV : KDMAX :',F6.1/ & -!/T ' RDKMIN :',F8.3) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3ULEV : KDMAX :',F6.1/ & + ' RDKMIN :',F8.3) +#endif ! -!/T 9010 FORMAT ( ' TEST W3ULEV : TIME :',I9.8,I7.6/ & -!/T ' OLD TLEV :',I9.8,I7.6) -!/T 9011 FORMAT ( ' NEW TLEV :',I9.8,I7.6) +#ifdef W3_T + 9010 FORMAT ( ' TEST W3ULEV : TIME :',I9.8,I7.6/ & + ' OLD TLEV :',I9.8,I7.6) + 9011 FORMAT ( ' NEW TLEV :',I9.8,I7.6) +#endif ! -!/T2 9020 FORMAT ( ' TEST W3ULEV : LOOP OVER ALL POINTS:', & -!/T2 ' ISEA, DW, KDMIN, RDK : ') -!/T2 9021 FORMAT ( ' ',I6,F8.2,F6.2,F7.3,A) +#ifdef W3_T2 + 9020 FORMAT ( ' TEST W3ULEV : LOOP OVER ALL POINTS:', & + ' ISEA, DW, KDMIN, RDK : ') + 9021 FORMAT ( ' ',I6,F8.2,F6.2,F7.3,A) +#endif !/ !/ End of W3ULEV ----------------------------------------------------- / !/ @@ -2222,7 +2556,9 @@ SUBROUTINE W3URHO ( FLFRST ) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NSEA, MAPSF -!/SMC USE W3GDATMD, ONLY: FSWND +#ifdef W3_SMC + USE W3GDATMD, ONLY: FSWND +#endif USE W3WDATMD, ONLY: TIME, TRHO, RHOAIR USE W3IDATMD, ONLY: TR0, TRN, RH0, RHN USE W3ADATMD, ONLY: RA0, RAI @@ -2238,26 +2574,34 @@ SUBROUTINE W3URHO ( FLFRST ) !/ ------------------------------------------------------------------- / !/ INTEGER :: ISEA, IX, IY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DT0N, DT0T, RD !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3URHO') +#ifdef W3_S + CALL STRACE (IENT, 'W3URHO') +#endif ! ! 1. Prepare auxiliary arrays ! IF ( FLFRST ) THEN DO ISEA=1, NSEA -!/SMC !!Li For sea-point only SMC grid air density is stored on -!/SMC !!Li 2-D RH0(NSEA, 1) variable. -!/SMC IF( FSWND ) THEN -!/SMC IX = ISEA -!/SMC IY = 1 -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea-point only SMC grid air density is stored on + !!Li 2-D RH0(NSEA, 1) variable. + IF( FSWND ) THEN + IX = ISEA + IY = 1 + ELSE +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif RA0(ISEA) = RH0(IX,IY) RAI(ISEA) = RHN(IX,IY) - RH0(IX,IY) @@ -2269,16 +2613,28 @@ SUBROUTINE W3URHO ( FLFRST ) DT0N = DSEC21 ( TR0, TRN ) DT0T = DSEC21 ( TR0, TIME ) ! -!/WNT0 RD = 0. -!/WNT1 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/WNT2 RD = DT0T / MAX ( 1.E-7 , DT0N ) -!/OASACM RD = 1. -! -!/T WRITE (NDST,9000) DT0N, DT0T, RD +#ifdef W3_WNT0 + RD = 0. +#endif +#ifdef W3_WNT1 + RD = DT0T / MAX ( 1.E-7 , DT0N ) +#endif +#ifdef W3_WNT2 + RD = DT0T / MAX ( 1.E-7 , DT0N ) +#endif +#ifdef W3_OASACM + RD = 1. +#endif +! +#ifdef W3_T + WRITE (NDST,9000) DT0N, DT0T, RD +#endif ! ! 3. Actual momentum for all grid points ! -!/OMPG/!$OMP PARALLEL DO PRIVATE (ISEA,RA0,RAI) +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE (ISEA,RA0,RAI) +#endif ! DO ISEA=1, NSEA ! @@ -2290,7 +2646,9 @@ SUBROUTINE W3URHO ( FLFRST ) ! ! Formats ! -!/T 9000 FORMAT (' TEST W3URHO : DT0N, DT0T, RD :',2F8.1,F6.3) +#ifdef W3_T + 9000 FORMAT (' TEST W3URHO : DT0N, DT0T, RD :',2F8.1,F6.3) +#endif !/ !/ End of W3URHO ----------------------------------------------------- / !/ @@ -2381,35 +2739,51 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) !/ ------------------------------------------------------------------- / !/ INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER :: ILEV, NLEV +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER :: ILEV, NLEV +#endif REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & LICE0, LICEN -!/T REAL :: LEVS(0:10) +#ifdef W3_T + REAL :: LEVS(0:10) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3UTRN') -!/T WRITE (NDST,9000) TRFLAG +#ifdef W3_S + CALL STRACE (IENT, 'W3UTRN') +#endif +#ifdef W3_T + WRITE (NDST,9000) TRFLAG +#endif ! ! 1. Preparations --------------------------------------------------- * ! ATRNX = 1. ATRNY = 1. -!/T WRITE (NDST,9001) 'INITIALIZING ATRNX/Y' +#ifdef W3_T + WRITE (NDST,9001) 'INITIALIZING ATRNX/Y' +#endif ! ! 2. Filling arrays from TRNX/Y for obstructions -------------------- * ! 2.a TRFLAG = 0, no action needed IF ( TRFLAG .EQ. 0 ) THEN -!/T WRITE (NDST,9001) 'NO FURTHER ACTION REQUIRED' +#ifdef W3_T + WRITE (NDST,9001) 'NO FURTHER ACTION REQUIRED' +#endif RETURN ! ! 2.b TRFLAG = 1,3: TRNX/Y defined at boundaries ! ELSE IF ( TRFLAG.EQ.1 .OR. TRFLAG.EQ.3 .OR. TRFLAG.EQ.5 ) THEN -!/T WRITE (NDST,9001) 'DATA APPLIED AT CELL BOUNDARIES' -!/T LEVS = 0. +#ifdef W3_T + WRITE (NDST,9001) 'DATA APPLIED AT CELL BOUNDARIES' + LEVS = 0. +#endif ! DO ISEA=1, NSEA ! @@ -2429,16 +2803,20 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) ATRNY(IXY,-1) = TRNY(IXY-1) ATRNY(IXY, 1) = TRNY(IXY) ! -!/T ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) -!/T LEVS(ILEV) = LEVS(ILEV) + 1. +#ifdef W3_T + ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. +#endif ! END DO ! ! 2.c TRFLAG = 2,4: TRNX/Y defined at cell centers ! ELSE -!/T WRITE (NDST,9001) 'DATA APPLIED AT CELL CENTERS' -!/T LEVS = 0. +#ifdef W3_T + WRITE (NDST,9001) 'DATA APPLIED AT CELL CENTERS' + LEVS = 0. +#endif ! DO ISEA=1, NSEA ! @@ -2498,31 +2876,39 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) END IF END IF ! -!/T ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) -!/T LEVS(ILEV) = LEVS(ILEV) + 1. +#ifdef W3_T + ILEV = NINT(10.*MIN(TRNX(IXY),TRNY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. +#endif ! END DO END IF ! -!/T WRITE(NDST,9010) 'ISLANDS' -!/T NLEV = 0 -!/T DO ILEV=0, 10 -!/T WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) -!/T NLEV = NLEV + NINT(LEVS(ILEV)) -!/T END DO +#ifdef W3_T + WRITE(NDST,9010) 'ISLANDS' + NLEV = 0 + DO ILEV=0, 10 + WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) + NLEV = NLEV + NINT(LEVS(ILEV)) + END DO +#endif ! ! 3. Adding ice to obstructions ------------------------------------- * ! 3.a TRFLAG < 3, no action needed ! IF ( TRFLAG.LT.3 .OR. FICEN-FICE0.LT.1.E-6 ) THEN -!/T WRITE (NDST,9001) 'NO ICE ACTION REQUIRED' +#ifdef W3_T + WRITE (NDST,9001) 'NO ICE ACTION REQUIRED' +#endif RETURN ! ! 3.b TRFLAG = 3,4: Calculate ice transparencies ! ELSE -!/T WRITE (NDST,9001) 'CALCULATE ICE TRANSPARENCIES' -!/T LEVS = 0. +#ifdef W3_T + WRITE (NDST,9001) 'CALCULATE ICE TRANSPARENCIES' + LEVS = 0. +#endif TRIX = 1. TRIY = 1. ! @@ -2540,15 +2926,19 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) END IF ! -!/IC0 IF (ICE(ISEA).GT.0) THEN -!/IC0 IF (FICEL.GT.0.) THEN -!/IC0 TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) -!/IC0 TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) -!/IC0 ELSE +#ifdef W3_IC0 + IF (ICE(ISEA).GT.0) THEN + IF (FICEL.GT.0.) THEN + TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) + TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) + ELSE +#endif ! Otherwise: original Tolman expression (Tolman 2003) -!/IC0 LICE0 = FICE0*DX -!/IC0 LICEN = FICEN*DX -!/IC0 TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) +#ifdef W3_IC0 + LICE0 = FICE0*DX + LICEN = FICEN*DX + TRIX(IXY) = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) +#endif ! begin temporary notes ! TRIX = ( LICEN - ICE(ISEA)*DX ) / ( LICEN - LICE0 ) @@ -2558,14 +2948,18 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) ! and the variables LICE0 LICEN are not necessary. ! end temporary notes -!/IC0 LICE0 = FICE0*DY -!/IC0 LICEN = FICEN*DY -!/IC0 TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) -!/IC0 END IF +#ifdef W3_IC0 + LICE0 = FICE0*DY + LICEN = FICEN*DY + TRIY(IXY) = ( LICEN - ICE(ISEA)*DY ) / ( LICEN - LICE0 ) + END IF +#endif ! -!/IC0 TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) -!/IC0 TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) -!/IC0 END IF +#ifdef W3_IC0 + TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) + TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) + END IF +#endif ! ! Adding iceberg attenuation ! @@ -2574,17 +2968,21 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) TRIY(IXY) = TRIY(IXY)*EXP(-BERG(ISEA)*FFACBERG *DY*0.0001) END IF ! -!/T ILEV = NINT(10.*MIN(TRIX(IXY),TRIY(IXY))) -!/T LEVS(ILEV) = LEVS(ILEV) + 1. +#ifdef W3_T + ILEV = NINT(10.*MIN(TRIX(IXY),TRIY(IXY))) + LEVS(ILEV) = LEVS(ILEV) + 1. +#endif ! END DO ! -!/T WRITE(NDST,9010) 'ICE' -!/T NLEV = 0 -!/T DO ILEV=0, 10 -!/T WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) -!/T NLEV = NLEV + NINT(LEVS(ILEV)) -!/T END DO +#ifdef W3_T + WRITE(NDST,9010) 'ICE' + NLEV = 0 + DO ILEV=0, 10 + WRITE (NDST,9011) ILEV, LEVS(ILEV)/REAL(NSEA) + NLEV = NLEV + NINT(LEVS(ILEV)) + END DO +#endif ! ! 3.c Combine transparencies, ice always defined at cell center ! ! @@ -2633,10 +3031,12 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3UTRN : TRFLAG = ',I3) -!/T 9001 FORMAT ( ' TEST W3UTRN : ',A) -!/T 9010 FORMAT ( ' TEST W3UTRN : OBSTRICTION LEVELS FOR ',A,' :') -!/T 9011 FORMAT ( ' ',I4,F8.5) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3UTRN : TRFLAG = ',I3) + 9001 FORMAT ( ' TEST W3UTRN : ',A) + 9010 FORMAT ( ' TEST W3UTRN : OBSTRICTION LEVELS FOR ',A,' :') + 9011 FORMAT ( ' ',I4,F8.5) +#endif !/ !/ End of W3UTRN ----------------------------------------------------- / !/ @@ -2729,7 +3129,9 @@ SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) ICLOSE_NONE, ICLOSE_SMPL, ICLOSE_TRPL USE W3ODATMD, ONLY: NDSE, IAPROC, NAPERR, NAPROC USE W3SERVMD, ONLY: EXTCDE -!/T USE W3ARRYMD, ONLY : PRTBLK +#ifdef W3_T + USE W3ARRYMD, ONLY : PRTBLK +#endif !/ IMPLICIT NONE !/ @@ -2743,17 +3145,27 @@ SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) CHARACTER, INTENT(IN) :: ZUNIT*(*) REAL, INTENT(OUT) :: DZZDX(NY,NX), DZZDY(NY,NX) INTEGER :: ISEA, IX, IY, IXP, IXM, IYP, IYM -!/T INTEGER :: ISX, ISY, MAPOUT(NX,NY) -!/S INTEGER, SAVE :: IENT = 0 -!/T INTEGER, SAVE :: NXS = 49 +#ifdef W3_T + INTEGER :: ISX, ISY, MAPOUT(NX,NY) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + INTEGER, SAVE :: NXS = 49 +#endif REAL :: DFAC , STX, STY INTEGER :: IXPS,IYPS,IXMS,IYMS,IXTRPL,IXTRPLS INTEGER :: IXSTART,IXEND -!/T REAL :: XOUT(NX,NY) +#ifdef W3_T + REAL :: XOUT(NX,NY) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3DZXY') +#ifdef W3_S + CALL STRACE (IENT, 'W3DZXY') +#endif ! ! 1. Preparations --------------------------------------------------- * @@ -2909,39 +3321,43 @@ SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) ! ! 3. Test output of fields ------------------------------------------ * ! -!/T WRITE (NDST,9010) -!/T ISX = 1 + NX/NXS -!/T ISY = 1 + NY/NXS -!/T DO IY=1, NY -!/T DO IX=1, NX -!/T MAPOUT(IX,IY) = MAPSTA(IY,IX) -!/T IF ( MAPFS(IY,IX) .NE. 0 ) & -!/T XOUT(IX,IY) = ZZ(MAPFS(IY,IX)) -!/T END DO -!/T END DO -!/T CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & -!/T 1, NX, ISX, 1, NY, ISY, 'ZZ', ZUNIT) -!/T DO IY=1, NY -!/T DO IX=1, NX -!/T XOUT(IX,IY) = DZZDX(IY,IX) -!/T END DO -!/T END DO -!/T CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & -!/T 1, NX, ISX, 1, NY, ISY, 'DZZDX',TRIM(ZUNIT)//'/m') -!/T DO IY=1, NY -!/T DO IX=1, NX -!/T XOUT(IX,IY) = DZZDY(IY,IX) -!/T END DO -!/T END DO -!/T CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & -!/T 1, NX, ISX, 1, NY, ISY, 'DZZDY',TRIM(ZUNIT)//'/m') +#ifdef W3_T + WRITE (NDST,9010) + ISX = 1 + NX/NXS + ISY = 1 + NY/NXS + DO IY=1, NY + DO IX=1, NX + MAPOUT(IX,IY) = MAPSTA(IY,IX) + IF ( MAPFS(IY,IX) .NE. 0 ) & + XOUT(IX,IY) = ZZ(MAPFS(IY,IX)) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'ZZ', ZUNIT) + DO IY=1, NY + DO IX=1, NX + XOUT(IX,IY) = DZZDX(IY,IX) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'DZZDX',TRIM(ZUNIT)//'/m') + DO IY=1, NY + DO IX=1, NX + XOUT(IX,IY) = DZZDY(IY,IX) + END DO + END DO + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + 1, NX, ISX, 1, NY, ISY, 'DZZDY',TRIM(ZUNIT)//'/m') +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT (' TEST W3DZXY : DX0I, DY0I : ',2E12.5) -!/T 9010 FORMAT (' TEST W3DZXY : FIELDS ') +#ifdef W3_T + 9000 FORMAT (' TEST W3DZXY : DX0I, DY0I : ',2E12.5) + 9010 FORMAT (' TEST W3DZXY : FIELDS ') +#endif !/ !/ End of W3DZXY ----------------------------------------------------- / !/ diff --git a/model/ftn/w3uqckmd.ftn b/model/src/w3uqckmd.F90 similarity index 63% rename from model/ftn/w3uqckmd.ftn rename to model/src/w3uqckmd.F90 index 7d2910be6..fdb020b4f 100644 --- a/model/ftn/w3uqckmd.ftn +++ b/model/src/w3uqckmd.F90 @@ -65,7 +65,9 @@ MODULE W3UQCKMD ! 7. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -177,45 +179,65 @@ SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & !/ INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2 -!/S INTEGER, SAVE :: IENT = 0 -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC REAL :: FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3QCK1') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'CFLL' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3QCK1') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX @@ -232,8 +254,10 @@ SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & ! 2. Fluxes for central points ------------------------------------- * ! ( 3rd order + limiter ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! DO IP=1, NB0 ! @@ -250,7 +274,9 @@ SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) ! -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) QBR = Q(IXYU) + QBN*DQ @@ -259,70 +285,82 @@ SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & ! FLA(IXY) = CFL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, CFLL(IXY), CFLL(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! DO IP=NB0+1, NB1 IXY = MAPBOU(IP) CFL = CFLL(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! DO IP=NB1+1, NB2 IXY = MAPBOU(IP) CFL = CFLL(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY+INC), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 5. Global closure ----------------------------------------------- * ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -330,46 +368,66 @@ SUBROUTINE W3QCK1 (MX, MY, NX, NY, CFLL, Q, CLOSE, INC, & ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif DO IP=1, NACT IXY = MAPACT(IP) -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif Q(IXY) = MAX ( 0. , Q(IXY) + FLA(IXY-INC) - FLA(IXY) ) -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 FLA(IXY-INC), FLA(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) +#endif END DO ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3QCK1 : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' CLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3QCK1 : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3QCK1 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3QCK1 :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3QCK1 : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3QCK1 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3QCK1 : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3QCK1 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3QCK1 :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3QCK1 : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3QCK1 : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3QCK1 ----------------------------------------------------- / !/ @@ -481,46 +539,66 @@ SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& !/ INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2 -!/S INTEGER, SAVE :: IENT -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, VEL, QB, DQ, DQNZ, QCN, QBN, & QBR, CFAC, FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN, XCFL -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN, XCFL +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3QCK2') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, DT, CLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'VELO' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & -!/T0 *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3QCK2') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, DT, CLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'VELO' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*VELO(IY+(IX-1)*MY) & + *DT/DX1(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX @@ -540,8 +618,10 @@ SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& ! 2. Fluxes for central points ------------------------------------- * ! ( 3rd order + limiter ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! DO IP=1, NB0 ! @@ -561,7 +641,9 @@ SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) ! -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) QBR = Q(IXYU) + QBN*DQ @@ -570,73 +652,85 @@ SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& ! FLA(IXY) = VEL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, DT*VELO(IXY)/DX1(IXY), & -!/T1 DT*VELO(IXY+INC)/DX1(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, DT*VELO(IXY)/DX1(IXY), & + DT*VELO(IXY+INC)/DX1(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! DO IP=NB0+1, NB1 IXY = MAPBOU(IP) VEL = VELO(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) FLA(IXY) = VEL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & -!/T1 DT*VELO(IXY)/DX2(IXY), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! DO IP=NB1+1, NB2 IXY = MAPBOU(IP) VEL = VELO(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,VEL) ) ) FLA(IXY) = VEL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & -!/T1 DT*VELO(IXY+INC)/DX2(IXY), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, XCFL, & + DT*VELO(IXY+INC)/DX2(IXY), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! ! 5. Global closure ----------------------------------------------- * ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -644,49 +738,69 @@ SUBROUTINE W3QCK2 (MX, MY, NX, NY, VELO, DT, DX1, DX2, Q, CLOSE,& ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif DO IP=1, NACT IXY = MAPACT(IP) -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif Q(IXY) = MAX ( 0. , Q(IXY) + DT/DX1(IXY) * & (FLA(IXY-INC)-FLA(IXY)) ) -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 DT*FLA(IXY-INC)/DX1(IXY), & -!/T2 DT*FLA(IXY)/DX1(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + DT*FLA(IXY-INC)/DX1(IXY), & + DT*FLA(IXY)/DX1(IXY) +#endif END DO ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3QCK2 : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' TIME STEP :',F8.1/ & -!/T ' CLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3QCK2 : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3QCK2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3QCK2 :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3QCK2 : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3QCK2 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' TIME STEP :',F8.1/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3QCK2 : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3QCK2 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3QCK2 :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3QCK2 : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3QCK2 : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3QCK2 ----------------------------------------------------- / !/ @@ -796,52 +910,74 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & INTEGER :: IXY, IP, IXYC, IXYU, IXYD, IY, IX, & IAD00, IAD02, IADN0, IADN1, IADN2, & JN, JP -!/S INTEGER, SAVE :: IENT = 0 -!/T1 INTEGER :: IX2, IY2 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T1 + INTEGER :: IX2, IY2 +#endif REAL :: CFL, QB, DQ, DQNZ, QCN, QBN, QBR, CFAC REAL :: FLA(1-MY:MY*MX) -!/T0 REAL :: QMAX -!/T1 REAL :: QBO, QN -!/T2 REAL :: QOLD +#ifdef W3_T0 + REAL :: QMAX +#endif +#ifdef W3_T1 + REAL :: QBO, QN +#endif +#ifdef W3_T2 + REAL :: QOLD +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3QCK3') -! -!/T WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 -! -!/T0 QMAX = 0. -!/T0 DO IY=1, NY -!/T0 DO IX=1, NX -!/T0 QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) -!/T0 END DO -!/T0 END DO -!/T0 QMAX = MAX ( 0.01*QMAX , 1.E-10 ) -! -!/T0 WRITE (NDST,9001) 'CFLL' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO -!/T0 WRITE (NDST,9001) 'MAPACT' -!/T0 WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#ifdef W3_S + CALL STRACE (IENT, 'W3QCK3') +#endif +! +#ifdef W3_T + WRITE (NDST,9000) MX, MY, NX, NY, CLOSE, INC, NB0, NB1, NB2 +#endif +! +#ifdef W3_T0 + QMAX = 0. + DO IY=1, NY + DO IX=1, NX + QMAX = MAX ( QMAX , Q(IY+(IX-1)*MY) ) + END DO + END DO + QMAX = MAX ( 0.01*QMAX , 1.E-10 ) +#endif +! +#ifdef W3_T0 + WRITE (NDST,9001) 'CFLL' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(100.*CFLL(IY+(IX-1)*MY)),IX=1,NX) + END DO + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO + WRITE (NDST,9001) 'MAPACT' + WRITE (NDST,9003) (MAPACT(IXY),IXY=1,NACT) +#endif ! ! 1. Initialize aux. array FLA and closure ------------------------- * ! FLA = 0. ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9005) +#ifdef W3_T + WRITE (NDST,9005) +#endif IAD00 = -MY IAD02 = MY IADN0 = IAD00 + MY*NX IADN1 = MY*NX IADN2 = IAD02 + MY*NX ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IY) +#endif ! DO IY=1, NY Q (IY+IAD00) = Q (IY+IADN0) ! 1 ghost column to left @@ -850,19 +986,27 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & CFLL(IY+IADN1) = CFLL( IY ) ! as for Q above, 1st to rt END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! END IF ! ! 2. Fluxes for central points ------------------------------------- * ! ( 3rd order + limiter ) ! -!/T1 WRITE (NDST,9010) -!/T1 WRITE (NDST,9011) NB0, 'CENTRAL' +#ifdef W3_T1 + WRITE (NDST,9010) + WRITE (NDST,9011) NB0, 'CENTRAL' +#endif ! -!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC, QB, IXYU, IXYD, & -!/OMPH/!/T1!$OMP QBO, QN, IX, IY, IX2, IY2, & -!/OMPH/!$OMP& DQ, DQNZ, QCN, QBN, QBR, CFAC ) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC, QB, IXYU, IXYD, & +#ifdef W3_T1 +!$OMP QBO, QN, IX, IY, IX2, IY2, & +#endif +!$OMP& DQ, DQNZ, QCN, QBN, QBR, CFAC ) +#endif ! DO IP=1, NB0 ! @@ -879,7 +1023,9 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & QCN = ( Q(IXYC) - Q(IXYU) ) / DQNZ QCN = MIN ( 1.1, MAX ( -0.1 , QCN ) ) ! -!/T1 QBO = QB +#ifdef W3_T1 + QBO = QB +#endif QBN = MAX ( (QB-Q(IXYU))/DQNZ , QCN ) QBN = MIN ( QBN , 1. , QCN/MAX(1.E-10,ABS(CFL)) ) QBR = Q(IXYU) + QBN*DQ @@ -888,28 +1034,34 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & ! FLA(IXY) = CFL * QB ! -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & -!/T1 Q(IXY+INC), Q(IXY+2*INC) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & -!/T1 CFL, CFLL(IXY), CFLL(IXY+INC), & -!/T1 QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & -!/T1 Q(IXY+INC)*QN, Q(IXY+2*INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( QB, QBO, Q(IXY-INC), Q( IXY ), & + Q(IXY+INC), Q(IXY+2*INC) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9012) IP, IX, IY, IX2, IY2, & + CFL, CFLL(IXY), CFLL(IXY+INC), & + QBO*QN, QB*QN, Q(IXY-INC)*QN, Q( IXY )*QN, & + Q(IXY+INC)*QN, Q(IXY+2*INC)*QN + END IF +#endif ! END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! ! 3. Fluxes for points with boundary above ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#ifdef W3_T1 + WRITE (NDST,9011) NB1-NB0, 'BOUNDARY ABOVE' +#endif ! !!!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC) !!! @@ -918,16 +1070,18 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & CFL = CFLL(IXY) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & -!/T1 CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9013) IP, IX, IY, IX2, IY2, CFL, & + CFLL(IXY), Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO !!! !!!/OMPH/!$OMP END PARALLEL DO @@ -935,7 +1089,9 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & ! 4. Fluxes for points with boundary below ------------------------- * ! ( 1st order without limiter ) ! -!/T1 WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#ifdef W3_T1 + WRITE (NDST,9011) NB2-NB1, 'BOUNDARY BELOW' +#endif ! !!!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, CFL, IXYC) !!! @@ -944,16 +1100,18 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & CFL = CFLL(IXY+INC) IXYC = IXY - INC * INT( MIN ( 0. , SIGN(1.1,CFL) ) ) FLA(IXY) = CFL * Q(IXYC) -!/T1 IY = MOD ( IXY , MY ) -!/T1 IX = 1 + IXY/MY -!/T1 IY2 = MOD ( IXY+INC , MY ) -!/T1 IX2 = 1 + (IXY+INC)/MY -!/T1 QN = MAX ( Q(IXY+INC), Q(IXY) ) -!/T1 IF ( QN .GT. 1.E-10 ) THEN -!/T1 QN = 1. /QN -!/T1 WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & -!/T1 Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN -!/T1 END IF +#ifdef W3_T1 + IY = MOD ( IXY , MY ) + IX = 1 + IXY/MY + IY2 = MOD ( IXY+INC , MY ) + IX2 = 1 + (IXY+INC)/MY + QN = MAX ( Q(IXY+INC), Q(IXY) ) + IF ( QN .GT. 1.E-10 ) THEN + QN = 1. /QN + WRITE (NDST,9014) IP, IX, IY, IX2, IY2, CFL, CFLL(IXY+INC), & + Q(IXYC)*QN, Q(IXY)*QN, Q(IXY+INC)*QN + END IF +#endif END DO ! !!!/OMPH/!$OMP END PARALLEL DO @@ -961,7 +1119,9 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & ! 5. Global closure ----------------------------------------------- * ! IF ( CLOSE ) THEN -!/T WRITE (NDST,9015) +#ifdef W3_T + WRITE (NDST,9015) +#endif DO IY=1, NY FLA (IY+IAD00) = FLA (IY+IADN0) END DO @@ -969,8 +1129,12 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & ! ! 6. Propagation -------------------------------------------------- * ! -!/T2 WRITE (NDST,9020) -!/OMPH/!$OMP PARALLEL DO PRIVATE (IP, IXY, JN, JP ) +#ifdef W3_T2 + WRITE (NDST,9020) +#endif +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE (IP, IXY, JN, JP ) +#endif ! DO IP=1, NACT ! @@ -986,47 +1150,67 @@ SUBROUTINE W3QCK3 (MX, MY, NX, NY, CFLL, TRANS, Q, CLOSE, & JP = 0 END IF ! -!/T2 QOLD = Q(IXY) +#ifdef W3_T2 + QOLD = Q(IXY) +#endif Q(IXY) = MAX ( 0. , Q(IXY) + TRANS(IXY,JN) * FLA(IXY-INC) & - TRANS(IXY,JP) * FLA(IXY) ) -!/T2 IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & -!/T2 WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & -!/T2 FLA(IXY-INC), FLA(IXY) +#ifdef W3_T2 + IF ( QOLD + Q(IXY) .GT. 1.E-10 ) & + WRITE (NDST,9021) IP, IXY, QOLD, Q(IXY), & + FLA(IXY-INC), FLA(IXY) +#endif END DO ! -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ! -!/T0 WRITE (NDST,9001) 'Q' -!/T0 DO IY=NY,1,-1 -!/T0 WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) -!/T0 END DO +#ifdef W3_T0 + WRITE (NDST,9001) 'Q' + DO IY=NY,1,-1 + WRITE (NDST,9002) (NINT(Q(IY+(IX-1)*MY)/QMAX),IX=1,NX) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( ' TEST W3QCK3 : ARRAY DIMENSIONS :',2I6/ & -!/T ' USED :',2I6/ & -!/T ' CLOSE, INC :',L6,I6/ & -!/T ' NB0, NB1, NB2 :',3I6) -!/T0 9001 FORMAT ( ' TEST W3QCK3 : DUMP ARRAY ',A,' :') -!/T0 9002 FORMAT ( 1X,43I3) -!/T0 9003 FORMAT ( 1X,21I6) -!/T 9005 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (1)') -! -!/T1 9010 FORMAT (' TEST W3QCK3 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & -!/T1 ' Q (b,b,i-1,i,i+1,i+2)') -!/T1 9011 FORMAT (' TEST W3QCK3 :',I6,' POINTS OF TYPE ',A) -!/T1 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) -!/T1 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T1 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& -!/T1 2F6.2,' --- ') -!/T 9015 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (2)') -! -!/T2 9020 FORMAT (' TEST W3QCK3 : IP, IXY, 2Q, 2FL') -!/T2 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3QCK3 : ARRAY DIMENSIONS :',2I6/ & + ' USED :',2I6/ & + ' CLOSE, INC :',L6,I6/ & + ' NB0, NB1, NB2 :',3I6) +#endif +#ifdef W3_T0 + 9001 FORMAT ( ' TEST W3QCK3 : DUMP ARRAY ',A,' :') + 9002 FORMAT ( 1X,43I3) + 9003 FORMAT ( 1X,21I6) +#endif +#ifdef W3_T + 9005 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (1)') +#endif +! +#ifdef W3_T1 + 9010 FORMAT (' TEST W3QCK3 : IP, 2x(IX,IY), CFL (b,i,i+1), ', & + ' Q (b,b,i-1,i,i+1,i+2)') + 9011 FORMAT (' TEST W3QCK3 :',I6,' POINTS OF TYPE ',A) + 9012 FORMAT (10X,I6,4I4,1X,3F6.2,1X,F7.2,F6.2,1X,4F6.2) + 9013 FORMAT (10X,I6,4I4,1X,F6.2,F6.2,' --- ',1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') + 9014 FORMAT (10X,I6,4I4,1X,F6.2,' --- ',F6.2,1X,F7.2,1X,' --- ',& + 2F6.2,' --- ') +#endif +#ifdef W3_T + 9015 FORMAT (' TEST W3QCK3 : GLOBAL CLOSURE (2)') +#endif +! +#ifdef W3_T2 + 9020 FORMAT (' TEST W3QCK3 : IP, IXY, 2Q, 2FL') + 9021 FORMAT (' ',2I6,2(1X,2E11.3)) +#endif !/ !/ End of W3QCK3 ----------------------------------------------------- / !/ diff --git a/model/src/w3wavemd.F90 b/model/src/w3wavemd.F90 new file mode 100644 index 000000000..b48c3577d --- /dev/null +++ b/model/src/w3wavemd.F90 @@ -0,0 +1,4337 @@ +#include "w3macros.h" +!/ ------------------------------------------------------------------- / + MODULE W3WAVEMD +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 22-Mar-2021 | +!/ +-----------------------------------+ +!/ +!/ 04-Feb-2000 : Origination. ( version 2.00 ) +!/ For upgrades see subroutines. +!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) +!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) +!/ without output. +!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) +!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) +!/ 23-Feb-2001 : Check for barrier after source +!/ terms added ( W3NMIN ). ( delayed version 2.07 ) +!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) +!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) +!/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) +!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) +!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) +!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) +!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) +!/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) +!/ 09-May-2002 : Switch clean up. ( version 2.21 ) +!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) +!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) +!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) +!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) +!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) +!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn +!/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) +!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) +!/ Fix NRQSG1/2 = 0 array bound issue. +!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) +!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) +!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) +!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) +!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) +!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) +!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) +!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) +!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) +!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) +!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) +!/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) +!/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) +!/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) +!/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) +!/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) +!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) +!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) +!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) +!/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) +!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) +!/ structure and smaller memory footprint. +!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) +!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) +!/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) +!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main +!/ trunk ( version 4.13 ) +!/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) +!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) +!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) +!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) +!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) +!/ (M. Accensi & F. Ardhuin, IFREMER) +!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) +!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) +!/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) +!/ defunct OMPX switches. +!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) +!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) +!/ 19-Jul-2021 : Momentum and air density support ( version 7.xx ) +!/ +!/ Copyright 2009-2014 National Weather Service (NWS), +!/ National Oceanic and Atmospheric Administration. All rights +!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ No unauthorized use without permission. +!/ +! 1. Purpose : +! +! 2. Variables and types : +! +! 3. Subroutines and functions : +! +! Name Type Scope Description +! ---------------------------------------------------------------- +! W3WAVE Subr. Public Actual wave model. +! W3GATH Subr. Public Data transpose before propagation. +! W3SCAT Subr. Public Data transpose after propagation. +! W3NMIN Subr. Public Calculate minimum number of sea +! points per processor. +! ---------------------------------------------------------------- +! +! 4. Subroutines and functions used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3SETx Subr. W3xDATMD Point to data structure. +! +! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. +! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. +! W3UINI Subr. W3UPDTMD Update initial conditions if init. +! with initial wind conditions. +! W3UBPT Subr. W3UPDTMD Update boundary points. +! W3UICE Subr. W3UPDTMD Update ice coverage. +! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. +! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. +! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. +! +! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. +! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. +! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. +! +! W3SRCE Subr. W3SRCEMD Source term integration and calculation. +! +! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. +! W3OUTG Subr. W3IOGOMD Generate gridded output fields. +! W3IOGO Subr. W3IOGOMD Read/write gridded output. +! W3IOPE Subr. W3IOPOMD Extract point output. +! W3IOPO Subr. W3IOPOMD Read/write point output. +! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. +! W3IORS Subr. W3IORSMD Read/write restart files. +! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. +! W3CPRT Subr. W3IOSFMD Partition spectra. +! W3IOSF Subr. Id. Write partitioned spectral data. +! +! STRACE Subr. W3SERVMD Subroutine tracing. +! WWTIME Subr. Id. System time in readable format. +! EXTCDE Subr. Id. Program abort. +! +! TICK21 Subr. W3TIMEMD Advance the clock. +! DSEC21 Func. Id. Difference between times. +! STME21 Subr. Id. Time in readable format. +! +! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL +! Subr. Basic MPI routines. +! ---------------------------------------------------------------- +! +! 5. Remarks : +! +! 6. Switches : +! +! !/SHRD Switch for shared / distributed memory architecture. +! !/DIST Id. +! !/MPI Id. +! !/OMPG Id. +! +! !/PR1 First order propagation schemes. +! !/PR2 ULTIMATE QUICKEST scheme. +! !/PR3 Averaged ULTIMATE QUICKEST scheme. +! !/SMC UNO2 scheme on SMC grid. +! +! !/S Enable subroutine tracing. +! !/T Test output. +! !/MPIT Test output for MPI specific code. +! +! 7. Source code : +! +!/ ------------------------------------------------------------------- / +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF +#endif +! + PUBLIC +!/ + CONTAINS +!/ ------------------------------------------------------------------- / + SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & +#ifdef W3_OASIS + ,ID_LCOMM, TIMEN & +#endif + ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 22-Mar-2021 | +!/ +-----------------------------------+ +!/ +!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Major changes to logistics. +!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) +!/ without output. +!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) +!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) +!/ 23-Feb-2001 : Check for barrier after source +!/ terms added ( W3NMIN ). ( delayed version 2.07 ) +!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) +!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) +!/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) +!/ declaration of FLIWND. +!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) +!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) +!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) +!/ 09-May-2002 : Switch clean up. ( version 2.21 ) +!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) +!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) +!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) +!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) +!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) +!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) +!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) +!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) +!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) +!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) +!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) +!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) +!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) +!/ Improve MPI_WAITALL call tests/allocations. +!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) +!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) +!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) +!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) +!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) +!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) +!/ (W. E. Rogers & T. J. Campbell, NRL) +!/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) +!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) +!/ (A. Roland and F. Ardhuin) +!/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) +!/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) +!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) +!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) +!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) +!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) +!/ structure and smaller memory footprint. +!/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) +!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) +!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) +!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) +!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) +!/ (M. Accensi & F. Ardhuin, IFREMER) +!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) +!/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) +!/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING +!/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH +!/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) +!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) +!/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) +!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) +!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) +!/ +! 1. Purpose : +! +! Run WAVEWATCH III for a given time interval. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! IMOD Int. I Model number. +! TEND I.A. I Ending time of integration. +! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). +! NO_OUT Log. I Skip output (optional, defaults to F). +! Skip at ending time only! +! ---------------------------------------------------------------- +! +! Local parameters : Flags +! ---------------------------------------------------------------- +! FLOUTG Log. Flag for running W3OUTG. +! FLPART Log. Flag for running W3CPRT. +! FLZERO Log. Flag for zero time interval. +! FLAG0 Log. Flag for processors without tasks. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! See module documentation. +! +! 5. Called by : +! +! Any program shell or integrated model which uses WAVEWATCH III. +! +! 6. Error messages : +! +! 7. Remarks : +! +! - Currents are updated before winds as currents are used in wind +! and USTAR processing. +! - Ice and water levels can be updated only once per call. +! - If ice or water level time are undefined, the update +! takes place asap, otherwise around the "half-way point" +! betweem the old and new times. +! - To increase accuracy, the calculation of the intra-spectral +! propagation is performed in two parts around the spatial propagation. +! +! 8. Structure : +! +! ----------------------------------------------------------- +! 0. Initializations +! a Point to data structures +! b Subroutine tracing +! c Local parameter initialization +! d Test output +! 1. Check the consistency of the input. +! a Ending time versus initial time. +! b Water level time. +! c Current time interval. +! d Wind time interval. +! e Ice time. +! 2. Determine next time from ending and output +! time and get corresponding time step. +! 3. Loop over time steps (see below). +! 4. Perform output to file if requested. +! a Check if time is output time. +! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) +! c Reset next output time. +! -------------- loop over output types ------------------ +! d Perform output. ( W3IOxx ) +! e Update next output time. +! -------------------- end loop -------------------------- +! 5. Update log file. +! 6. If time is not ending time, branch back to 2. +! ----------------------------------------------------------- +! +! Section 3. +! ---------------------------------------------------------- +! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) +! ( W3UWND ) +! ( W3UINI ) +! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) +! 3.3 Update ice coverage (if new ice map). ( W3UICE ) +! 3.4 Transform grid (if new water level). ( W3ULEV ) +! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) +! ( W3NMIN, W3UTRN ) +! Update grid advection vector. +! 3.6 Perform propagation +! a Preparations. +! b Intra spectral part 1. ( W3KTPn ) +! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) +! b Intra spectral part 2. ( W3KTPn ) +! 3.7 Calculate and integrate source terms. ( W3SRCE ) +! 3.8 Update global time step. +! ---------------------------------------------------------- +! +! 9. Switches : +! +! See module documentation. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / + USE CONSTANTS +!/ + USE W3GDATMD + USE W3WDATMD + USE W3ADATMD + USE W3IDATMD + USE W3ODATMD +!/ + USE W3UPDTMD + USE W3SRCEMD +#ifdef W3_PR1 + USE W3PRO1MD +#endif +#ifdef W3_PR2 + USE W3PRO2MD +#endif +#ifdef W3_PR3 + USE W3PRO3MD +#endif +#ifdef W3_SMC + USE W3PSMCMD +#endif +! +#ifdef W3_PR1 + USE W3PROFSMD +#endif +#ifdef W3_PR2 + USE W3PROFSMD +#endif +#ifdef W3_PR3 + USE W3PROFSMD +#endif +!/ + USE W3TRIAMD + USE W3IOGRMD + USE W3IOGOMD + USE W3IOPOMD + USE W3IOTRMD + USE W3IORSMD + USE W3IOBCMD + USE W3IOSFMD +#ifdef W3_PDLIB + USE PDLIB_W3PROFSMD, only : APPLY_BOUNDARY_CONDITION_VA + USE PDLIB_W3PROFSMD, only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT + USE PDLIB_W3PROFSMD, only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT + USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM + USE yowNodepool, only: npa, iplg +#endif +!/ + USE W3SERVMD + USE W3TIMEMD +#ifdef W3_IC3 + USE W3SIC3MD +#endif +#ifdef W3_IS2 + USE W3SIS2MD +#endif +#ifdef W3_UOST + USE W3UOSTMD, ONLY: UOST_SETGRID +#endif + USE W3PARALL, ONLY : INIT_GET_ISEA +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif +#ifdef W3_SETUP + USE W3WAVSET, only : WAVE_SETUP_COMPUTATION +#endif +!/NETCDF_QAD USE W3NETCDF, only : OUTPUT_NETCDF_QUICK_AND_DIRTY + +#ifdef W3_OASIS + USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 +#endif +#ifdef W3_OASOCM + USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN +#endif +#ifdef W3_OASACM + USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS +#endif +#ifdef W3_OASICM + USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE +#endif + +#ifdef W3_PDLIB + USE PDLIB_FIELD_VEC, only : DO_OUTPUT_EXCHANGES +#endif +#ifdef W3_TIMINGS + USE W3PARALL, only : PRINT_MY_TIME +#endif +! + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: IMOD, TEND(2),ODAT(35) + LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT +#ifdef W3_OASIS + INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM + INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters : +!/ +#ifdef W3_T + INTEGER :: ILEN +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif + INTEGER :: IP + INTEGER :: TCALC(2), IT, IT0, NT, ITEST, & + ITLOC, ITLOCH, NTLOC, ISEA, JSEA, & + IX, IY, ISPEC, J, TOUT(2), TLST(2), & + REFLED(6), IK, ITH, IS, NKCFL + INTEGER :: ISP, IP_glob + INTEGER :: TTEST(2),DTTEST + REAL :: ICEDAVE +! +#ifdef W3_MPI + LOGICAL :: SBSED +#endif +#ifdef W3_SEC1 + INTEGER :: ISEC1 +#endif +#ifdef W3_SBS + INTEGER :: JJ, NDSOFLG +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI, NRQMAX + INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) +#endif + INTEGER :: IXrel + REAL :: DTTST, DTTST1, DTTST2, DTTST3, & + DTL0, DTI0, DTR0, DTI10, DTI50, & + DTGA, DTG, DTGpre, DTRES, & + FAC, VGX, VGY, FACK, FACTH, & + FACX, XXX, REFLEC(4), & + DELX, DELY, DELA, DEPTH, D50, PSIC + REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) + LOGICAL :: SHAVETOTioDummy +#ifdef W3_SEC1 + REAL :: DTGTEMP +#endif +! + REAL, ALLOCATABLE :: FIELD(:) + REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) +#ifdef W3_IC3 + REAL, ALLOCATABLE :: WN_I(:) +#endif +#ifdef W3_REFRX + REAL, ALLOCATABLE :: CIK(:) +#endif +! +! Orphaned arrays from old data structure +! + REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) +! + LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP,& + SKIP_O, FLAG_O, FLDDIR, READBC, & + FLAG0 = .FALSE., FLOUTG, FLPFLD, & + FLPART, LOCAL, FLOUTG2 +! +#ifdef W3_MPI + LOGICAL :: FLGMPI(0:8) +#endif +#ifdef W3_IC3 + REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS + REAL :: USE_CHENG, USE_CGICE, HICE +#endif + LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=21) :: IDACT + CHARACTER(LEN=13) :: OUTID + CHARACTER(LEN=23) :: IDTIME + INTEGER eIOBP + INTEGER ITH_F +#ifdef W3_PDLIB + REAL :: VS_SPEC(NSPEC) + REAL :: VD_SPEC(NSPEC) +#endif + +! +#ifdef W3_SBS + CHARACTER(LEN=30) :: FOUTNAME +#endif +! +#ifdef W3_T + REAL :: INDSORT(NSEA), DTCFL1(NSEA) +#endif +!/ +#ifdef W3_SMC + !Li Temperature spectra for Arctic boundary update. + REAL, ALLOCATABLE :: BACSPEC(:) + REAL :: BACANGL + +#endif + +!/ ------------------------------------------------------------------- / +! 0. Initializations +! +! 0.a Set pointers to data structure +! +#ifdef W3_COU + SCREEN = 333 +#endif +! +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3WAVE, step 1' +#endif +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'Step 1 : max(UST)=', maxval(UST) +#endif +#ifdef W3_DEBUGINIT + FLUSH(740+IAPROC) +#endif + IF ( IOUTP .NE. IMOD ) CALL W3SETO ( IMOD, NDSE, NDST ) + IF ( IGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + IF ( IWDATA .NE. IMOD ) CALL W3SETW ( IMOD, NDSE, NDST ) + IF ( IADATA .NE. IMOD ) CALL W3SETA ( IMOD, NDSE, NDST ) + IF ( IIDATA .NE. IMOD ) CALL W3SETI ( IMOD, NDSE, NDST ) +#ifdef W3_UOST + CALL UOST_SETGRID(IMOD) +#endif + +#ifdef W3_DEBUGRUN + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'NEGATIVE ACTION 1', IS, JSEA, VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + CALL EXTCDE(666) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 1', SUM(VA) + CALL FLUSH(740+IAPROC) + CALL EXTCDE(666) + ENDIF +#endif + + +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1") +#endif +#ifdef W3_DEBUGIOBP + IF (NX .ge. 10210) WRITE(*,*) 'CRIT 1:', MAPSTA(1,10210), IOBP(10210) +#endif +#endif + +! + ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL)) +#ifdef W3_REFRX + ALLOCATE(CIK(NSEAL)) +#endif +! + IF ( PRESENT(STAMP) ) THEN + TSTAMP = STAMP + ELSE + TSTAMP = .TRUE. + END IF +! + IF ( PRESENT(NO_OUT) ) THEN + SKIP_O = NO_OUT + ELSE + SKIP_O = .FALSE. + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3WAVE, step 2' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2") +#endif +#endif +! +! 0.b Subroutine tracing +! +#ifdef W3_S + CALL STRACE (IENT, 'W3WAVE') +#endif +! +! +! 0.c Local parameter initialization +! + IPASS = IPASS + 1 + IDACT = ' ' + OUTID = ' ' + FLACT = ITIME .EQ. 0 + FLMAP = ITIME .EQ. 0 + FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION & + .OR. FLCK .OR. FSFREQSHIFT ) +! + FLPFLD = .FALSE. + DO J=1,NOGE(4) + FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) + END DO +! + IF ( IAPROC .EQ. NAPLOG ) BACKSPACE ( NDSO ) +! + IF ( FLCOLD ) THEN + DTDYN = 0. + FCUT = SIG(NK) * TPIINV + END IF +! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 +#ifdef W3_SMC + !!Li Use sea point only field for SMC grid. + ALLOCATE ( FIELD(NCel) ) +#endif + ELSE + ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) + ENDIF +! + LOCAL = IAPROC .LE. NAPROC + UGDTUPDATE = .FALSE. + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF +! +#ifdef W3_SBS + NDSOFLG = 99 +#endif +#ifdef W3_MPI + SBSED = .FALSE. +#endif +#ifdef W3_SBS + SBSED = .TRUE. +#endif +! + TAUWX = 0. + TAUWY = 0. +! +! 0.d Test output +! +#ifdef W3_T + ILEN = LEN_TRIM(FILEXT) + WRITE (NDST,9000) IMOD, FILEXT(:ILEN), TEND +#endif +! +! 1. Check the consistency of the input ----------------------------- / +! 1.a Ending time versus initial time +! + DTTST = DSEC21 ( TIME , TEND ) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) '1 : DTTST=', DTTST, TIME, TEND +#endif + FLZERO = DTTST .EQ. 0. +#ifdef W3_T + WRITE (NDST,9010) DTTST, FLZERO +#endif + IF ( DTTST .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) + CALL EXTCDE ( 1 ) + END IF +! +! 1.b Water level time +! + IF ( FLLEV ) THEN + IF ( TLEV(1) .GE. 0. ) THEN + DTL0 = DSEC21 ( TLEV , TLN ) + ELSE + DTL0 = 1. + END IF +#ifdef W3_T + WRITE (NDST,9011) DTL0 +#endif + IF ( DTL0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + CALL EXTCDE ( 2 ) + END IF + ELSE + DTL0 = 0. + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3WAVE, step 4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4") +#endif +#endif +! +! 1.c Current interval +! + IF ( FLCUR ) THEN + DTTST1 = DSEC21 ( TC0 , TCN ) + DTTST2 = DSEC21 ( TC0 , TIME ) + DTTST3 = DSEC21 ( TEND , TCN ) +#ifdef W3_T + WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 +#endif + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(7:7) = 'F' + TOFRST = TIME + END IF + END IF +! +! 1.d Wind interval +! + IF ( FLWIND ) THEN + DTTST1 = DSEC21 ( TW0 , TWN ) + DTTST2 = DSEC21 ( TW0 , TIME ) + DTTST3 = DSEC21 ( TEND , TWN ) +#ifdef W3_T + WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 +#endif + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) + CALL EXTCDE ( 4 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(3:3) = 'F' + TOFRST = TIME + END IF + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3WAVE, step 5' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5") +#endif +#endif +! +! 1.e Ice concentration interval +! + IF ( FLICE ) THEN + IF ( TICE(1) .GE. 0 ) THEN + DTI0 = DSEC21 ( TICE , TIN ) + ELSE + DTI0 = 1. + END IF +#ifdef W3_T + WRITE (NDST,9014) DTI0 +#endif + IF ( DTI0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI0 = 0. + END IF +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3WAVE, step 6' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6") +#endif +#endif +! +! 1.f Momentum interval +! + IF ( FLTAUA ) THEN + DTTST1 = DSEC21 ( TU0 , TUN ) + DTTST2 = DSEC21 ( TU0 , TIME ) + DTTST3 = DSEC21 ( TEND , TUN ) +#ifdef W3_T + WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 +#endif + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(9:9) = 'F' + TOFRST = TIME + END IF + END IF +! +! 1.g Air density time +! + IF ( FLRHOA ) THEN + DTTST1 = DSEC21 ( TU0 , TUN ) + DTTST2 = DSEC21 ( TU0 , TIME ) + DTTST3 = DSEC21 ( TEND , TUN ) +#ifdef W3_T + WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 +#endif + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) + CALL EXTCDE ( 2 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(11:11) = 'F' + TOFRST = TIME + END IF + END IF +! +! 1.e Ice thickness interval +! + IF ( FLIC1 ) THEN + IF ( TIC1(1) .GE. 0 ) THEN + DTI10 = DSEC21 ( TIC1 , TI1 ) + ELSE + DTI10 = 1. + END IF +#ifdef W3_T + WRITE (NDST,9015) DTI10 +#endif + IF ( DTI10 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI10 = 0. + END IF +! +! 1.e Ice floe interval +! +#ifdef W3_IS2 + IF ( FLIC5 ) THEN + IF ( TIC5(1) .GE. 0 ) THEN + DTI50 = DSEC21 ( TIC5 , TI5 ) + ELSE + DTI50 = 1. + END IF +#ifdef W3_T + WRITE (NDST,9016) DTI50 +#endif + IF ( DTI50 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI50 = 0. + END IF +#endif +! +! 2. Determine next time from ending and output --------------------- / +! time and get corresponding time step. +! + FLFRST = .TRUE. + DO +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'First entry in the TIME LOOP' + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("First entry in the TIME LOOP") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.1' + FLUSH(740+IAPROC) +#endif +! DO JSEA = 1, NSEAL +! DO IS = 1, NSPEC +! IF (VA(IS, JSEA) .LT. 0.) THEN +! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) +! CALL FLUSH(740+IAPROC) +! ENDIF +! ENDDO +! ENDDO +! IF (SUM(VA) .NE. SUM(VA)) THEN +! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) +! CALL FLUSH(740+IAPROC) +! STOP +! ENDIF + + +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1") +#endif +#endif +! +! +! 2.a Pre-calculate table for IC3 ------------------------------------ / +#ifdef W3_IC3 + USE_CHENG=IC3PARS(9) + IF( USE_CHENG==1.0 )THEN + FIXEDVISC=IC3PARS(14) + FIXEDDENS=IC3PARS(15) + FIXEDELAS=IC3PARS(16) + IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. & + (FIXEDELAS.LT.0.0) ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'Cheng method requires stationary', & + ' and uniform rheology from namelist.' + CALL EXTCDE(2) + END IF + IF (CALLEDIC3TABLE==0) THEN + CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) + CALLEDIC3TABLE = 1 + ENDIF + ENDIF +#endif + +! 2.b Update group velocity and wavenumber from ice parameters ------- / +! from W3SIC3MD module. ------------------------------------------ / +! Note: "IF FLFRST" can be added for efficiency, but testing req'd + + JSEA=1 ! no switch (intentional) + +#ifdef W3_IC3 + USE_CGICE=IC3PARS(12) + IF ( USE_CGICE==1.0 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) +#endif + +#ifdef W3_IC3 + DO JSEA=1,NSEAL +#endif +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif +#ifdef W3_IC3 + ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) + WN_I(:) = 0. + DEPTH = MAX( DMIN , DW(ISEA) ) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) +#endif + +! 2.b.1 Using Cheng method: requires stationary/uniform rheology. +! However, ice thickness may be input by either method + +#ifdef W3_IC3 + IF ( USE_CHENG==1.0 ) THEN + IF (FLIC1) THEN + HICE=ICEP1(IX,IY) + ELSEIF (IC3PARS(13).GE.0.0)THEN + HICE=IC3PARS(13) + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + ENDIF + IF (HICE > 0.0) THEN ! non-zero ice + CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),HICE,FIXEDVISC, & + FIXEDDENS, FIXEDELAS, DEPTH) + END IF ! non-zero ice +#endif + +#ifdef W3_IC3 + ELSE ! not using Cheng method +#endif +! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly +! necesssary, but makes code simpler) + +#ifdef W3_IC3 + IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN + IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice + CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & + ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) + END IF ! non-zero ice + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + END IF + ENDIF ! IF USE_CHENG... +#endif + +#ifdef W3_IC3 + DEALLOCATE(WN_I) + END DO ! DO JSEA=1,NSEAL + END IF ! IF USE_CGICE ... +#endif +! + IF ( TOFRST(1) .GT. 0 ) THEN + DTTST = DSEC21 ( TEND , TOFRST ) + ELSE + DTTST = 0. + ENDIF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) '2 : DTTST=', DTTST, TEND, TOFRST +#endif +! + IF ( DTTST.GE.0. ) THEN + TCALC = TEND + ELSE + TCALC = TOFRST + END IF +! + DTTST = DSEC21 ( TIME , TCALC ) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) '3 : DTTST=', DTTST, TEND, TOFRST +#endif + NT = 1 + INT ( DTTST / DTMAX - 0.001 ) + DTGA = DTTST / REAL(NT) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'DTTST=', DTTST, ' NT=', NT +#endif + IF ( DTTST .EQ. 0. ) THEN + IT0 = 0 + IF ( .NOT.FLZERO ) ITIME = ITIME - 1 + NT = 0 + ELSE + IT0 = 1 + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +#ifdef W3_T + WRITE (NDST,9020) IT0, NT, DTGA +#endif +! +! ==================================================================== / +! +! 3. Loop over time steps +! + DTRES = 0. + +#ifdef W3_DEBUGRUN + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 3', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 3', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF + WRITE(740+IAPROC,*) 'IT0=', IT0, ' NT=', NT + FLUSH(740+IAPROC) +#endif +! + DO IT=IT0, NT +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Begin of IT loop") +#endif +#ifdef W3_SETUP + CALL WAVE_SETUP_COMPUTATION +#endif +! copy old values +#ifdef W3_PDLIB + DO IP=1,NSEAL + DO ISPEC=1,NSPEC + VAOLD(ISPEC,IP)=VA(ISPEC,IP) + END DO + END DO +#endif +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After assigning VAOLD") +#endif +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 0' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + ITIME = ITIME + 1 +! + DTG = REAL(NINT(DTGA+DTRES+0.0001)) + DTRES = DTRES + DTGA - DTG + IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. + CALL TICK21 ( TIME , DTG ) +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'DTGA=', DTGA, ' DTRES=', DTRES + WRITE(740+IAPROC,*) 'DTG 1 : DTG=', DTG + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN + CALL WWTIME ( STTIME ) + CALL STME21 ( TIME , IDTIME ) + WRITE (SCREEN,950) IDTIME, STTIME + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DEBUGRUN + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 4', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 4', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF +#endif +! + VGX = 0. + VGY = 0. + IF(INFLAGS1(10)) THEN + DTTST1 = DSEC21 ( TIME, TGN ) + DTTST2 = DSEC21 ( TG0, TGN ) + FAC = DTTST1 / MAX ( 1. , DTTST2 ) + VGX = (FAC*GA0+(1.-FAC)*GAN) * & + COS(FAC*GD0+(1.-FAC)*GDN) + VGY = (FAC*GA0+(1.-FAC)*GAN) * & + SIN(FAC*GD0+(1.-FAC)*GDN) + END IF +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After VGX/VGY assignation") +#endif +! +#ifdef W3_T + WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, & + VGX, VGY, DTG, DTRES +#endif +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'DTG 2 : DTG=', DTG + WRITE(740+IAPROC,*) 'max(UST)=', maxval(UST) + FLUSH(740+IAPROC) +#endif +! +! 3.1 Interpolate winds, currents, and momentum. +! (Initialize wave fields with winds) +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + FLUSH(740+IAPROC) +#endif +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3a ' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( FLCUR ) THEN +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before UCUR") +#endif +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") +#endif + +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.2 before W3UCUR' + FLUSH(740+IAPROC) +#endif + CALL W3UCUR ( FLFRST ) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1 after W3UCUR' + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3b ' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 +#ifdef W3_SMC + !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. + CALL SMCDCXY +#endif + ELSE IF (GTYPE .EQ. UNGTYPE) THEN +#ifdef W3_DEBUGDCXDX + WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' +#endif + CALL UG_GRADIENTS(CX, DCXDX, DCXDY) + CALL UG_GRADIENTS(CY, DCYDX, DCYDY) + CALL GET_INTERFACE + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + ELSE + CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT + CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT + ENDIF !! End GTYPE +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + ELSE IF ( FLFRST ) THEN + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + CX = 0. + CY = 0. + END IF ! FLCUR +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After CX/CY assignation") +#endif +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( FLWIND ) THEN + IF ( FLFRST ) ASF = 1. + CALL W3UWND ( FLFRST, VGX, VGY ) + ELSE IF ( FLFRST ) THEN + U10 = 0.01 + U10D = 0. + UST = 0.05 + USTDIR = 0.05 + END IF + +! DO JSEA = 1, NSEAL +! DO IS = 1, NSPEC +! IF (VA(IS, JSEA) .LT. 0.) THEN +! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) +! CALL FLUSH(740+IAPROC) +! ENDIF +! ENDDO +! ENDDO +! IF (SUM(VA) .NE. SUM(VA)) THEN +! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) +! CALL FLUSH(740+IAPROC) +! STOP +! ENDIF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After U10, etc. assignation") +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.5' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before call W3UINI") +#endif + IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.5.1 DTG=', DTG + FLUSH(740+IAPROC) +#endif +! + IF ( FLTAUA ) THEN + CALL W3UTAU ( FLFRST ) + ELSE IF ( FLFRST ) THEN + TAUA = 0.01 + TAUADIR = 0. + END IF +! + IF ( FLRHOA ) THEN + CALL W3URHO ( FLFRST ) + ELSE IF ( FLFRST ) THEN + RHOAIR = DAIR + END IF +! +! 3.2 Update boundary conditions if boundary flag is true (FLBPI) +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before boundary update") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + WRITE(740+IAPROC,*) 'LOCAL=', LOCAL + FLUSH(740+IAPROC) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( FLBPI .AND. LOCAL ) THEN +! + DO + IF ( TBPIN(1) .EQ. -1 ) THEN + READBC = .TRUE. + IDACT(1:1) = 'F' + ELSE + READBC = DSEC21(TIME,TBPIN).LT.0. + IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' + END IF + FLACT = READBC .OR. FLACT +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'READBC=', READBC + FLUSH(740+IAPROC) +#endif + + IF ( READBC ) THEN +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'Before call to W3IOBC' + FLUSH(740+IAPROC) +#endif + CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, & + ITEST, IMOD ) +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'After call to W3IOBC' + WRITE(740+IAPROC,*) 'ITEST=', ITEST + FLUSH(740+IAPROC) +#endif + IF ( ITEST .NE. 1 ) CALL W3UBPT + ELSE + ITEST = 0 + END IF + IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' + IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' + IF ( .NOT. (READBC.AND.FLBPI) ) EXIT + END DO + + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + +#ifdef W3_PDLIB + CALL APPLY_BOUNDARY_CONDITION_VA +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After FLBPI and LOCAL") +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! 3.3.1 Update ice coverage (if new ice map). +! Need to be run on output nodes too, to update MAPSTx +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLICE=', FLICE + WRITE(740+IAPROC,*) 'DTI0=', DTI0 + FLUSH(740+IAPROC) +#endif + IF ( FLICE .AND. DTI0.NE.0. ) THEN +! + IF ( TICE(1).GE.0 ) THEN + IF ( DTI0 .LT. 0. ) THEN + IDACT(13:13) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TIN ) + IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' + END IF + ELSE + IDACT(13:13) = 'I' + END IF +! + IF ( IDACT(13:13).NE.' ' ) THEN + CALL W3UICE ( VA, VA ) + DTI0 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + END IF + END IF +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After FLICE and DTI0") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.7 DTG=', DTG + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGIOBP + IF (NX .ge. 10210) WRITE(*,*) 'Before W3ULEV:', MAPSTA(1,10210), IOBP(10210) +#endif +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! 3.3.2 Update ice thickness +! + IF ( FLIC1 .AND. DTI10.NE.0. ) THEN +! + IF ( TIC1(1).GE.0 ) THEN + IF ( DTI10 .LT. 0. ) THEN + IDACT(15:15) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI1 ) + IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' + END IF + ELSE + IDACT(15:15) = 'I' + END IF + +! + IF ( IDACT(15:15).NE.' ' ) THEN + CALL W3UIC1 ( FLFRST ) + DTI10 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + END IF +! + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 10' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +! 3.3.3 Update ice floe diameter +! +#ifdef W3_IS2 + IF ( FLIC5 .AND. DTI50.NE.0. ) THEN +#endif +! +#ifdef W3_IS2 + IF ( TIC5(1).GE.0 ) THEN + IF ( DTI50 .LT. 0. ) THEN + IDACT(18:18) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI5 ) + IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' + END IF + ELSE + IDACT(18:18) = 'I' + END IF +#endif +! +#ifdef W3_IS2 + IF ( IDACT(18:18).NE.' ' ) THEN + CALL W3UIC5( FLFRST ) + DTI50 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + END IF +#endif +! +#ifdef W3_IS2 + END IF +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! 3.4 Transform grid (if new water level). +! +! write(740+IAPROC,*) 'TEST ARON', FLLEV, DTL0, TLEV(1), IDACT(5:5), DSEC21 ( TIME, TLN ), TIME, TLN +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLLEV=', FLLEV, ' DTL0=', DTL0 + FLUSH(740+IAPROC) +#endif + IF ( FLLEV .AND. DTL0 .NE.0. ) THEN +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'Before time works' + FLUSH(740+IAPROC) +#endif + IF ( TLEV(1) .GE. 0 ) THEN + IF ( DTL0 .LT. 0. ) THEN + IDACT(5:5) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TLN ) + IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' + END IF + ELSE + IDACT(5:5) = 'I' + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After time works' + FLUSH(740+IAPROC) +#endif +! + IF ( IDACT(5:5).NE.' ' ) THEN + +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'Before W3ULEV' + FLUSH(740+IAPROC) +#endif + CALL W3ULEV ( VA, VA ) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After W3ULEV' + FLUSH(740+IAPROC) +#endif + + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + DTL0 = 0. + FLACT = .TRUE. + FLMAP = .TRUE. + FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION & + .OR. FLCK .OR. FSFREQSHIFT + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After IDACT if test' + FLUSH(740+IAPROC) +#endif + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After FLLEV test' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0") +#endif +#ifdef W3_DEBUGIOBP + IF (NX .ge. 10210) WRITE(*,*) ' After W3ULEV:', MAPSTA(1,10210), IOBP(10210) +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After FFLEV and DTL0") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLMAP=', FLMAP + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +! 3.5 Update maps and derivatives. +! + IF ( FLMAP ) THEN + IF ( GTYPE .NE. SMCTYPE ) THEN +#ifdef W3_PR1 + CALL W3MAP1 ( MAPSTA ) +#endif +#ifdef W3_PR2 + CALL W3MAP2 +#endif +#ifdef W3_PR3 + CALL W3MAP3 +#endif + CALL W3UTRN ( TRNX, TRNY ) +#ifdef W3_PR3 + CALL W3MAPT +#endif + END IF !! GTYPE + CALL W3NMIN ( MAPSTA, FLAG0 ) + IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD + FLMAP = .FALSE. + END IF +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.1 DTG=', DTG + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.2 DTG=', DTG + WRITE(740+IAPROC,*) 'FLDDIR=', FLDDIR + FLUSH(740+IAPROC) +#endif + IF ( FLDDIR ) THEN + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 +#ifdef W3_SMC + !!Li Use new sub for DDDX and DDDY assignment. + CALL SMCDHXY +#endif + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + CALL UG_GRADIENTS(DW, DDDX, DDDY) + ELSE + CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) + END IF + FLDDIR = .FALSE. + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 12' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.3 DTG=', DTG + FLUSH(740+IAPROC) +#endif +! +! Calculate PHASE SPEED GRADIENT. + DCDX = 0. + DCDY = 0. +#ifdef W3_REFRX + CIK = 0. +! + IF (GTYPE .NE. UNGTYPE) THEN + DO IK=0,NK+1 + CIK = SIG(IK) / WN(IK,1:NSEA) + CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) + END DO + ELSE + WRITE (NDSE,1040) + CALL EXTCDE(2) + ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.4' + FLUSH(740+IAPROC) +#endif +! + FLIWND = .FALSE. + FLFRST = .FALSE. +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF +#endif + IF (IT .eq. 0) THEN + DTGpre = 1. + ELSE + DTGpre = DTG + END IF +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 13' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + IF ( FLSOU .and. LPDLIB) THEN +! +#ifdef W3_OMP0 +!$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1) +#endif + D50=0.0002 + REFLEC(:)=0. + REFLED(:)=0 + PSIC=0. +#ifdef W3_PDLIB + VSTOT = 0. + VDTOT = 0. +#endif + + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DELA=1. + DELX=1. + DELY=1. +#ifdef W3_REF1 + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN +! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF +#endif +! +#ifdef W3_REF1 + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) +#endif +#ifdef W3_BT4 + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) +#endif +#ifdef W3_REF1 + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) +#endif +#ifdef W3_BT4 + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) +#endif +! +#ifdef W3_DEBUGRUN + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 7', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO +#endif +! + IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN + IF (FSSOURCE) THEN +#ifdef W3_PDLIB +#ifdef W3_DEBUGSRC + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA + END IF + WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD + WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA + WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) + FLUSH(740+IAPROC) +#endif + CALL W3SRCE(srce_imp_pre, IT, JSEA, IX, IY, IMOD, & + VAoldDummy, VA(:,JSEA), & + VSTOT(:,JSEA), VDTOT(:,JSEA), SHAVETOT(JSEA), & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTGpre, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC, TMP2, & + PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) + FLUSH(740+IAPROC) +#endif +#endif + ENDIF + ELSE + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + DTDYN (JSEA) = UNDEF + FCUT (JSEA) = UNDEF + END IF + END DO ! JSEA + END IF ! PDLIB +#ifdef W3_PDLIB +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF +#endif +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 14' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + + IF ( FLZERO ) THEN +#ifdef W3_T + WRITE (NDST,9022) +#endif + GOTO 400 + END IF + IF ( IT.EQ.0 ) THEN + DTG = 1. +! DTG = 60. + GOTO 370 + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.5' + WRITE(740+IAPROC,*) 'FLDRY=', FLDRY + FLUSH(740+IAPROC) +#endif + IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN +#ifdef W3_T + WRITE (NDST,9023) +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'Jump to 380' + FLUSH(740+IAPROC) +#endif + GOTO 380 + END IF +! +! Estimation of the local maximum CFL for XY propagation +! +#ifdef W3_T + WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'FLOGRD(9,3) = ', FLOGRD(9,3) + WRITE(740+IAPROC,*) 'UGDTUPDATE=', UGDTUPDATE + FLUSH(740+IAPROC) +#endif + IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.6' + FLUSH(740+IAPROC) +#endif + IF (FSTOTALIMP .eqv. .FALSE.) THEN + NKCFL=NK +#ifdef W3_T + NKCFL=1 +#endif +! +#ifdef W3_OMPG +!$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) +#endif +! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) +#ifdef W3_PR3 + IF (GTYPE .EQ. UNGTYPE) THEN + IF ( FLOGRD(9,3) ) THEN +#endif +#ifdef W3_T + IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA +#endif +#ifdef W3_PDLIB + IF (.NOT. LPDLIB) THEN +#endif +#ifdef W3_PR3 + CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, & + MAPFS, CFLXYMAX(JSEA), VGX, VGY ) +#endif +#ifdef W3_PDLIB + ENDIF +#endif +#ifdef W3_PR3 + END IF + ELSE + CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, & + CFLXYMAX(JSEA), VGX, VGY ) + END IF +#endif + END DO +! +#ifdef W3_OMPG +!$OMP END PARALLEL DO +#endif +! + END IF + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.7' + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 15' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_DEBUGRUN + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 8', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 6 ', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF +#endif + +! +#ifdef W3_T + IF (GTYPE .EQ. UNGTYPE) THEN + IF ( FLOGRD(9,3) ) THEN + DTCFL1(:)=1. + DO JSEA=1,NSEAL + INDSORT(JSEA)=FLOAT(JSEA) + DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) + END DO + CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) + DO JSEA = 1, MIN(NSEAL,200) + ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI + IX = MAPSF(ISEA,1) + IF (JSEA.EQ.1) & + WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' + WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XYB(IX,1), XYB(IX,2), XYB(IX,3) + END DO ! JSEA + CLOSE(995) + END IF + END IF +#endif + +! +! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = +! 3.6.1 Preparations +! +#ifdef W3_SEC1 + DTGTEMP=DTG + DTG=DTG/NITERSEC1 + DO ISEC1=1,NITERSEC1 +#endif + NTLOC = 1 + INT( DTG/DTCFLI - 0.001 ) +#ifdef W3_SEC1 + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 +#endif +! + FACTH = DTG / (DTH*REAL(NTLOC)) +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, DTCFLI=', DTCFLI + WRITE(740+IAPROC,*) 'W3WAVE, DTG=', DTG + WRITE(740+IAPROC,*) 'W3WAVE, DTH=', DTH + WRITE(740+IAPROC,*) 'W3WAVE, NTLOC=', NTLOC + FLUSH(740+IAPROC) +#endif + FACK = DTG / REAL(NTLOC) + + TTEST(1) = TIME(1) + TTEST(2) = 0 + DTTEST = DSEC21(TTEST,TIME) + ITLOCH = ( NTLOC + 1 - MOD(NINT(DTTEST/DTG),2) ) / 2 +! +! 3.6.2 Intra-spectral part 1 +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before intraspectral part 1") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before intraspectral") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.10' + WRITE(740+IAPROC,*) 'FLCTH=', FLCTH, ' FLCK=', FLCK + FLUSH(740+IAPROC) +#endif + IF ( FLCTH .OR. FLCK ) THEN + DO ITLOC=1, ITLOCH +! +#ifdef W3_OMPG +!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) +!$OMP DO SCHEDULE (DYNAMIC,1) +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) ' ITLOC=', ITLOC + WRITE(740+IAPROC,*) ' 1: Before call to W3KTP1 / W3KTP2 / W3KTP3' +#endif + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + +#ifdef W3_DEBUGRUN + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) +#endif + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (IOBP(ISEA) .NE. 1) CYCLE + ENDIF + + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + DEPTH = MAX ( DMIN , DW(ISEA) ) + IF (LPDLIB) THEN + IXrel = JSEA + ELSE + IXrel = IX + END IF +! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 +#ifdef W3_SMC + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif +! + ELSE + J = 1 +! +#ifdef W3_PR1 + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) +#endif +#ifdef W3_PR2 + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) +#endif +#ifdef W3_PR3 + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif +! + END IF !! GTYPE +! + END IF + END DO +! +#ifdef W3_OMPG +!$OMP END DO +!$OMP END PARALLEL +#endif +! + END DO + END IF + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 16' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before spatial advection") +#endif +! +! 3.6.3 Longitude-latitude +! (time step correction in routine) +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12' + WRITE(740+IAPROC,*) 'FSN=', FSN + WRITE(740+IAPROC,*) 'FSPSI=', FSPSI + WRITE(740+IAPROC,*) 'FSFCT=', FSFCT + WRITE(740+IAPROC,*) 'FSNIMP=', FSNIMP + WRITE(740+IAPROC,*) 'FLCTH=', FLCTH + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FLCK=', FLCK + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'FLSOU=', FLSOU + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP + WRITE(740+IAPROC,*) 'FSTOTALEXP=', FSTOTALEXP + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + WRITE(740+IAPROC,*) 'PDLIB=', LPDLIB + WRITE(740+IAPROC,*) 'GTYPE=', GTYPE + WRITE(740+IAPROC,*) 'UNGTYPE=', UNGTYPE + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, 'NTPROC=', NTPROC + WRITE(740+IAPROC,*) 'FLCX=', FLCX, ' FLCY=', FLCY + FLUSH(740+IAPROC) +#endif +! +!/NETCDF_QAD CALL OUTPUT_NETCDF_QUICK_AND_DIRTY(IMOD, DTG) +! + IF (GTYPE .EQ. UNGTYPE) THEN + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF + END IF + IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN +! +#ifdef W3_PDLIB + IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + DO ISPEC=1,NSPEC + CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, & + VGX, VGY, UGDTUPDATE ) + END DO +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.2' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + END IF +#endif +! +#ifdef W3_PDLIB + IF (FSTOTALIMP .and. (IT .ne. 0)) THEN +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3A' + WRITE(*,*), 'W3WAVE, step 6.12.3A' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT (FACX, FACX, DTG, VGX, VGY) +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4A' + WRITE(*,*), 'W3WAVE, step 6.12.4A' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3B' + WRITE(*,*), 'W3WAVE, step 6.12.3B' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(FACX, FACX, DTG, VGX, VGY) +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4B' + WRITE(*,*), 'W3WAVE, step 6.12.4B' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ENDIF +#endif + ELSE + IF (FLCX .or. FLCY) THEN +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.13' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_MPI + IF ( NRQSG1 .GT. 0 ) THEN + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.14' + FLUSH(740+IAPROC) +#endif +! +! Initialize FIELD variable + FIELD = 0. +! + DO ISPEC=1, NSPEC + IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN +! + IF( GTYPE .EQ. SMCTYPE ) THEN + IX = 1 +#ifdef W3_SMC + !!Li Use SMC sub to gether field + CALL W3GATHSMC ( ISPEC, FIELD ) +#endif + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3GATH ( ISPEC, FIELD ) + END IF !! GTYPE +! + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 +#ifdef W3_SMC + !!Li Propagation on SMC grid uses UNO2 scheme. + CALL W3PSMC ( ISPEC, DTG, FIELD ) +#endif +! + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + IX = 1 +#ifdef W3_MPI + IF (.NOT. LPDLIB) THEN +#endif +#ifdef W3_PR1 + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & + FIELD, VGX, VGY, UGDTUPDATE ) +#endif +#ifdef W3_PR2 + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & + FIELD, VGX, VGY, UGDTUPDATE ) +#endif +#ifdef W3_PR3 + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & + FIELD, VGX, VGY, UGDTUPDATE ) +#endif +#ifdef W3_MPI + END IF +#endif +! + ELSE + IX = 1 +#ifdef W3_PR1 + CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) +#endif +#ifdef W3_PR2 + CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) +#endif +#ifdef W3_PR3 + CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) +#endif +! + END IF !! GTYPE +! + IF( GTYPE .EQ. SMCTYPE ) THEN + IX = 1 +#ifdef W3_SMC + !!Li Use SMC sub to scatter field + CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) +#endif + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) + END IF !! GTYPE + + END IF + END DO +! +#ifdef W3_MPI + IF ( NRQSG1 .GT. 0 ) THEN + ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, & + IERR_MPI) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, & + IERR_MPI) + DEALLOCATE ( STATCO ) + END IF +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 17' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +!Li Initialise IK IX IY in case ARC option is not used to avoid warnings. + IK=1 + IX=1 + IY=1 +#ifdef W3_SMC + !Li Find source boundary spectra and assign to SPCBAC + IF( ARCTC ) THEN + + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IY = ICLBAC(IK) + ELSE + IY = NGLO + IK + ENDIF + + !Li Work out root PE (ISPEC) and JSEA numbers for IY +#ifdef W3_DIST + ISPEC = MOD( IY-1, NAPROC ) + JSEA = 1 + (IY - ISPEC - 1)/NAPROC +#endif +#ifdef W3_SHRD + ISPEC = 0 + JSEA = IY +#endif +#endif +! +#ifdef W3_SMC + !!Li Assign boundary cell spectra. + IF( IAPROC .EQ. ISPEC+1 ) THEN + SPCBAC(:,IK)=VA(:,JSEA) + ENDIF +#endif +! +#ifdef W3_SMC + !!Li Broadcast local SPCBAC(:,IK) to all other PEs. +#ifdef W3_MPI + CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) +#endif +#endif +! +#ifdef W3_SMC + END DO !! Loop IK ends. +#endif +! +#ifdef W3_SMC + !!Li Update Arctic boundary cell spectra if within local range + ALLOCATE ( BACSPEC(NSPEC) ) + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IX = NGLO + IK + BACANGL = ANGARC(IK) + ELSE + IX = ICLBAC(IK) + BACANGL = - ANGARC(IK) + ENDIF + + !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX +#ifdef W3_DIST + ISPEC = MOD( IX-1, NAPROC ) + JSEA = 1 + (IX - ISPEC - 1)/NAPROC +#endif +#ifdef W3_SHRD + ISPEC = 0 + JSEA = IX +#endif +#endif +! +#ifdef W3_SMC + IF( IAPROC .EQ. ISPEC+1 ) THEN + BACSPEC = SPCBAC(:,IK) + + CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) + + VA(:,JSEA) = BACSPEC + !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK + ENDIF + + END DO !! Loop IK ends. + DEALLOCATE ( BACSPEC ) + + ENDIF !! ARCTC +#endif +! +! End of test FLCX.OR.FLCY + END IF +! + END IF + +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After spatial advection") +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.16' + WRITE(740+IAPROC,*) 'NTLOC=', NTLOC + WRITE(740+IAPROC,*) 'ITLOCH=', ITLOCH + FLUSH(740+IAPROC) +#endif +! +! 3.6.4 Intra-spectral part 2 +! + IF ( FLCTH .OR. FLCK ) THEN + DO ITLOC=ITLOCH+1, NTLOC +! +#ifdef W3_OMPG +!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) +!$OMP DO SCHEDULE (DYNAMIC,1) +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) ' ITLOC=', ITLOC + WRITE(740+IAPROC,*) ' 2: Before call to W3KTP1 / W3KTP2 / W3KTP3' +#endif + DO JSEA = 1, NSEAL + + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) +#ifdef W3_DEBUGRUN + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) +#endif + DEPTH = MAX ( DMIN , DW(ISEA) ) + + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (IOBP(ISEA) .NE. 1) CYCLE + ENDIF + + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + IF (LPDLIB) THEN + IXrel = JSEA + ELSE + IXrel = IX + END IF +! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 +#ifdef W3_SMC + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif +! + ELSE + J = 1 +#ifdef W3_PR1 + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) +#endif +#ifdef W3_PR2 + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) +#endif +#ifdef W3_PR3 + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif +! + END IF !! GTYPE +! + END IF + END DO +! +#ifdef W3_OMPG +!$OMP END DO +!$OMP END PARALLEL +#endif +! + END DO + END IF +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("fter intraspectral adv.") +#endif +! + UGDTUPDATE = .FALSE. +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.17' + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + FLUSH(740+IAPROC) +#endif +! +! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = + +! 3.7 Calculate and integrate source terms. +! + 370 CONTINUE + IF ( FLSOU ) THEN +! + D50=0.0002 + REFLEC(:)=0. + REFLED(:)=0 + PSIC=0. +#ifdef W3_PDLIB +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST") + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF +#endif +#endif +! +#ifdef W3_OMPG +!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & +!$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) +!$OMP DO SCHEDULE (DYNAMIC,1) +#endif +! + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DELA=1. + DELX=1. + DELY=1. +#ifdef W3_REF1 + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN +! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF +#endif +! +#ifdef W3_REF1 + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) +#endif +#ifdef W3_BT4 + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) +#endif + +#ifdef W3_DEBUGRUN + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', ISEA, JSEA, SUM(VA(:,JSEA)) +#endif + + IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN + TMP1 = WHITECAP(JSEA,1:4) + TMP2 = BEDFORMS(JSEA,1:3) + TMP3 = TAUBBL(JSEA,1:2) + TMP4 = TAUICE(JSEA,1:2) +#ifdef W3_PDLIB + IF (FSSOURCE) THEN + CALL W3SRCE(srce_imp_post,IT,JSEA,IX,IY,IMOD, & + VAOLD(:,JSEA), VA(:,JSEA), & + VSTOT(:,JSEA),VDTOT(:,JSEA),SHAVETOT(JSEA), & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2,& + PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) + ELSE +#endif + CALL W3SRCE(srce_direct, IT, JSEA, IX, IY, IMOD, & + VAoldDummy, VA(:,JSEA), & + VSioDummy, VDioDummy, SHAVETOTioDummy, & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & +#ifdef W3_FLX5 + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2,& + PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) +#ifdef W3_PDLIB + END IF +#endif + WHITECAP(JSEA,1:4) = TMP1 + BEDFORMS(JSEA,1:3) = TMP2 + TAUBBL(JSEA,1:2) = TMP3 + TAUICE(JSEA,1:2) = TMP4 + ELSE + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + DTDYN (JSEA) = UNDEF + FCUT (JSEA) = UNDEF +! VA(:,JSEA) = 0. + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'RET: min/max/sum(VA)=',minval(VA(:,JSEA)),maxval(VA(:,JSEA)),sum(VA(:,JSEA)) +#endif + END DO +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) + FLUSH(740+IAPROC) +#endif + +#ifdef W3_DEBUGRUN + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 9', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 7', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF +#endif +! +#ifdef W3_OMPG +!$OMP END DO +!$OMP END PARALLEL +#endif +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGSRC + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST") + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) + END IF +#endif +#endif + +! +! This barrier is from older code versions. It has been removed in 3.11 +! to optimize IO2/3 settings. May be needed on some systems still +! +!!/MPI IF (FLAG0) CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) +!!/MPI ELSE +!!/MPI CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) +! + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.18' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After source terms") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("After source terms") +#endif +! +! End of interations for DTMAX < 1s +! +#ifdef W3_SEC1 + IF (IT.EQ.0) EXIT + END DO + IF (IT.GT.0) DTG=DTGTEMP +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.19' + FLUSH(740+IAPROC) + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 10', VA(IS,JSEA) + CALL FLUSH(740+IAPROC) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 8', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF +#endif +! +! 3.8 Update global time step. +! (Branch point FLDRY, IT=0) +! + 380 CONTINUE +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.20' + FLUSH(740+IAPROC) +#endif + IF (IT.NE.NT) THEN + DTTST = DSEC21 ( TIME , TCALC ) + DTG = DTTST / REAL(NT-IT) + END IF +! + IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN + CALL STME21 ( TIME , IDTIME ) + IF ( IDLAST .NE. TIME(1) ) THEN + WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), & + IDACT, OUTID + IDLAST = TIME(1) + ELSE + WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & + IDACT, OUTID + END IF + FLACT = .FALSE. + IDACT = ' ' + END IF +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_PDLIB +#ifdef W3_DEBUGCOH + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop") +#endif +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("end of time loop") +#endif +! +! + END DO + +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") +#endif +! +#ifdef W3_T + WRITE (NDST,9030) +#endif +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END TIME LOOP' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +! End of loop over time steps +! ==================================================================== / +! + 400 CONTINUE +! +! 4. Perform output to file if requested ---------------------------- / +! 4.a Check if time is output time +! Delay if data assimilation time. +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.2' + FLUSH(740+IAPROC) +#endif +! + IF ( TOFRST(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, TOFRST ) + END IF +! + IF ( TDN(1) .EQ. -1 ) THEN + DTTST1 = 1. + ELSE + DTTST1 = DSEC21 ( TIME, TDN ) + END IF +! + DTTST2 = DSEC21 ( TIME, TEND ) + FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) +! +#ifdef W3_T + WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.3' + FLUSH(740+IAPROC) +#endif + IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.4' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9041) +#endif +! +! 4.b Processing and MPP preparations +! + IF ( FLOUT(1) ) THEN + FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. + ELSE + FLOUTG = .FALSE. + END IF +! + IF ( FLOUT(7) ) THEN + FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. + ELSE + FLOUTG2 = .FALSE. + END IF +! + FLPART = .FALSE. + IF ( FLOUT(1) .AND. FLPFLD ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.7' + FLUSH(740+IAPROC) +#endif + IF ( FLOUT(6) ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.8' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_T + WRITE (NDST,9042) LOCAL, FLPART, FLOUTG +#endif +! + IF ( LOCAL .AND. FLPART ) CALL W3CPRT ( IMOD ) + IF ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) & + CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) +! +#ifdef W3_MPI + FLGMPI = .FALSE. + NRQMAX = 0 +#endif +! +#ifdef W3_MPI + IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & + ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. & + SBSED ) ) THEN + IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN + IF (NRQGO.NE.0 ) THEN +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO.NE.0 , step 0', & + NRQGO, IRQGO, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO.NE.0, step 0' + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MPI + FLGMPI(0) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD +#endif +#ifdef W3_MPI + END IF +#endif +! +#ifdef W3_MPI + IF (NRQGO2.NE.0 ) THEN +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO2.NE.0, step 0', & + NRQGO2, IRQGO2, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO2.NE.0, step 0' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + FLGMPI(1) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO2 ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD +#endif +#ifdef W3_MPI + END IF + ELSE +#endif +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + CALL DO_OUTPUT_EXCHANGES(IMOD) +#endif +#ifdef W3_MPI + END IF + END IF +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 1' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) + FLGMPI(2) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQPO ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(4) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(8) .AND. NRQRS.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(8) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 3' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) + FLGMPI(5) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQBP ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 4' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. & + IAPROC.EQ.NAPBPT) THEN + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) + NRQMAX = MAX ( NRQMAX , NRQBP2 ) +#endif +#ifdef W3_MPIT + WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 5' + FLUSH(740+IAPROC) +#endif +#ifdef W3_MPI + IF ( NRQMAX .NE. 0 ) ALLOCATE & + ( STATIO(MPI_STATUS_SIZE,NRQMAX) ) +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +! 4.c Reset next output time + +#ifdef W3_DEBUGRUN + IF (MINVAL(VA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 12', SUM(VA), MINVAL(VA), MAXVAL(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 9', IX, IY, SUM(VA) + CALL FLUSH(740+IAPROC) + STOP + ENDIF +#endif +! + TOFRST(1) = -1 + TOFRST(2) = 0 +! + DO J=1, NOTYPE +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'NOTYPE, J=', J + FLUSH(740+IAPROC) +#endif + + IF ( FLOUT(J) ) THEN +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'Matching FLOUT(J)' + FLUSH(740+IAPROC) +#endif +! +! 4.d Perform output +! +#ifdef W3_NL5 + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) +#endif + TOUT(:) = TONEXT(:,J) + DTTST = DSEC21 ( TIME, TOUT ) +! + IF ( DTTST .EQ. 0. ) THEN + IF ( ( J .EQ. 1 ) & +#ifdef W3_SBS + .OR. ( J .EQ. 7 ) & +#endif + ) THEN + IF ( IAPROC .EQ. NAPFLD ) THEN +#ifdef W3_MPI + IF ( FLGMPI(1) ) CALL MPI_WAITALL & + ( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + FLGMPI(1) = .FALSE. +#endif +! +#ifdef W3_SBS + IF ( J .EQ. 1 ) THEN +#endif + CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) +#ifdef W3_SBS + ENDIF +#endif +! +#ifdef W3_SBS + ! + ! Generate output flag file for fields and SBS coupling. + ! + JJ = LEN_TRIM ( FILEXT ) + CALL STME21 ( TIME, IDTIME ) + FOUTNAME = 'Field_done.' // IDTIME(1:4) & + // IDTIME(6:7) // IDTIME(9:10) & + // IDTIME(12:13) // '.' // FILEXT(1:JJ) +#endif +! +#ifdef W3_SBS + OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) + CLOSE( NDSOFLG ) +#endif + END IF +! + ELSE IF ( J .EQ. 2 ) THEN +! +! Point output +! + IF ( IAPROC .EQ. NAPPNT ) THEN +! +! Gets the necessary spectral data +! + CALL W3IOPE ( VA ) + CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) + END IF +! + ELSE IF ( J .EQ. 3 ) THEN +! +! Track output +! + CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) + ELSE IF ( J .EQ. 4 ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + ELSE IF ( J .EQ. 5 ) THEN + IF ( IAPROC .EQ. NAPBPT ) THEN +#ifdef W3_MPI + IF (NRQBP2.NE.0) CALL MPI_WAITALL & + ( NRQBP2, IRQBP2,STATIO, IERR_MPI ) +#endif + CALL W3IOBC ( 'WRITE', NDS(10), & + TIME, TIME, ITEST, IMOD ) + END IF + ELSE IF ( J .EQ. 6 ) THEN + CALL W3IOSF ( NDS(13), IMOD ) +#ifdef W3_OASIS + ELSE IF ( J .EQ. 7 ) THEN + ! + ! Send variables to atmospheric or ocean circulation or ice model + ! + IF (DTOUT(7).NE.0) THEN + IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & + (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN + IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. & + .NOT. CPLT0 ) THEN + IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + +#endif +#ifdef W3_OASACM + CALL SND_FIELDS_TO_ATMOS() +#endif +#ifdef W3_OASOCM + CALL SND_FIELDS_TO_OCEAN() +#endif +#ifdef W3_OASICM + CALL SND_FIELDS_TO_ICE() +#endif +#ifdef W3_OASIS + IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + ENDIF + ENDIF + ENDIF +#endif + END IF +! + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. + IF ( FLOUT(J) ) THEN + OUTID(2*J-1:2*J-1) = 'X' +#ifdef W3_OASIS + IF ( (DTOUT(7).NE.0) .AND. & + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' +#endif + ELSE + OUTID(2*J-1:2*J-1) = 'L' + END IF + END IF +! +! 4.e Update next output time +! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF +! + END IF +! + END DO + + +! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. + J=8 + IF ( FLOUT(J) ) THEN +! +#ifdef W3_DEBUGRUN + WRITE(740+IAPROC,*) 'Matching FLOUT(J)' + FLUSH(740+IAPROC) +#endif +! +! 4.d Perform output +! + TOUT(:) = TONEXT(:,J) + DTTST = DSEC21 ( TIME, TOUT ) + IF ( DTTST .EQ. 0. ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. + IF ( FLOUT(J) ) THEN + OUTID(2*J-1:2*J-1) = 'X' +#ifdef W3_OASIS + IF ( (DTOUT(7).NE.0) .AND. & + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' +#endif + ELSE + OUTID(2*J-1:2*J-1) = 'L' + END IF + END IF +! +! 4.e Update next output time +! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF + END IF +! END OF CHECKPOINT +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +#ifdef W3_MPI + IF ( FLGMPI(0) ) CALL MPI_WAITALL & + ( NRQGO, IRQGO , STATIO, IERR_MPI ) + IF ( FLGMPI(2) ) CALL MPI_WAITALL & + ( NRQPO, IRQPO1, STATIO, IERR_MPI ) + IF ( FLGMPI(4) ) CALL MPI_WAITALL & + ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(8) ) CALL MPI_WAITALL & + ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(5) ) CALL MPI_WAITALL & + ( NRQBP, IRQBP1, STATIO, IERR_MPI ) + IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO ) +#endif +! +#ifdef W3_T + WRITE (NDST,9044) +#endif +! +! This barrier is from older code versions. It has been removed in 3.11 +! to optimize IO2/3 settings. May be needed on some systems still +! +!!/MPI IF (FLDRY) CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) +! + END IF +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Before update log file") +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +! +! 5. Update log file ------------------------------------------------ / + +! IF (MINVAL(VA) .LT. 0.) THEN +! WRITE(740+IAPROC,*) 'TEST W3WAVE 13', SUM(VA), MINVAL(VA), MAXVAL(VA) +! CALL FLUSH(740+IAPROC) +! STOP +! ENDIF +! + IF ( IAPROC.EQ.NAPLOG ) THEN +! + CALL STME21 ( TIME , IDTIME ) + IF ( FLCUR ) THEN + DTTST = DSEC21 ( TIME , TCN ) + IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' + END IF + IF ( FLWIND ) THEN + DTTST = DSEC21 ( TIME , TWN ) + IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' + END IF + IF ( FLTAUA ) THEN + DTTST = DSEC21 ( TIME , TUN ) + IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' + END IF + IF ( FLRHOA ) THEN + DTTST = DSEC21 ( TIME , TRN ) + IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' + END IF + IF ( TDN(1) .GT. 0 ) THEN + DTTST = DSEC21 ( TIME , TDN ) + IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' + END IF +! + IF ( IDLAST.NE.TIME(1) ) THEN + WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & + IDACT, OUTID + IDLAST = TIME(1) + ELSE + WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & + IDACT, OUTID + END IF +! + END IF +! + IDACT = ' ' + OUTID = ' ' + FLACT = .FALSE. +! +! 6. If time is not ending time, branch back to 2 ------------------- / +! + DTTST = DSEC21 ( TIME, TEND ) + IF ( DTTST .EQ. 0. ) EXIT +#ifdef W3_TIMINGS + CALL PRINT_MY_TIME("Continuing the loop") +#endif + END DO + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + + IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN + CALL WWTIME ( STTIME ) + WRITE (SCREEN,951) STTIME + END IF + + IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,902) +! + DEALLOCATE(FIELD) + DEALLOCATE(TAUWX, TAUWY) +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END W3WAVE' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + RETURN +! +! Formats +! + 900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') + 901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') + 902 FORMAT (2X,'--------+------+---------------------+' & + ,'-------------------+---------------+') +! +#ifdef W3_IC3 + 920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) +#endif + 950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) + 951 FORMAT (' WAVEWATCH III reached the end of a computation', & + ' loop at ',A) + 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ENDING TIME BEFORE STARTING TIME '/) + 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/) + 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ILLEGAL CURRENT INTERVAL '/) + 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' ILLEGAL WIND INTERVAL '/) + 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW ICE FIELD BEFORE OLD ICE FIELD '/) + 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/) + 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW ATM MOMENTUM BEFORE OLD ATM MOMENTUM '/) + 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW AIR DENSITY BEFORE OLD AIR DENSITY '/) +#ifdef W3_IS2 + 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/) +#endif + 1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & + ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & + ' IN GRID',I3) +#ifdef W3_REFRX + 1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/) +#endif +! +#ifdef W3_T + 9000 FORMAT ( & + '============================================================', & + '===================='/ & + ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & + '] UP TO ',I8.8,I7.6 / & + '====================', & + '============================================================') + 9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) + 9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) + 9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & + ' ',F12.1/ & + ' ',F12.1) + 9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & + ' ',F12.1/ & + ' ',F12.1) + 9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) + 9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) + 9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) + 9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) + 9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) + 9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) + 9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & + 2F6.2,F7.1,F6.2) + 9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') + 9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') + 9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') + 9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & + ' TOFRST :',I9.8,I7.6/ & + ' TND :',I9.8,I7.6/ & + ' DTTST[1], FLAG_O :',2F8.1,L4) + 9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') + 9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) +#endif +#ifdef W3_MPIT + 9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) +#endif +#ifdef W3_T + 9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') +#endif +!/ +!/ End of W3WAVE ----------------------------------------------------- / +!/ + END SUBROUTINE W3WAVE +!/ ------------------------------------------------------------------- / + SUBROUTINE W3GATH ( ISPEC, FIELD ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 26-Dec-2012 | +!/ +-----------------------------------+ +!/ +!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Major changes to logistics. +!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) +!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) +!/ +! 1. Purpose : +! +! Gather spectral bin information into a propagation field array. +! +! 2. Method : +! +! Direct copy or communication calls (MPP version). +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! ISPEC Int. I Spectral bin considered. +! FIELD R.A. O Full field to be propagated. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! STRACE Subr. W3SERVMD Subroutine tracing. +! +! MPI_STARTALL, MPI_WAITALL +! Subr. mpif.h MPI persistent comm. routines (!/MPI). +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3WAVE Subr. W3WAVEMD Actual wave model routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! None. +! +! 7. Remarks : +! +! - The field is extracted but not converted. +! - MPI version requires posing of send and receive calls in +! W3WAVE to match local calls. +! - MPI version does not require an MPI_TESTALL call for the +! posted gather operation as MPI_WAITALL is mandatory to +! reset persistent communication for next time step. +! - MPI version allows only two new pre-fetch postings per +! call to minimize chances to be slowed down by gathers that +! are not yet needed, while maximizing the pre-loading +! during the early (low-frequency) calls to the routine +! where the amount of calculation needed for proagation is +! the largest. +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/SHRD Switch for message passing method. +! !/MPI Id. +! +! !/S Enable subroutine tracing. +! !/MPIT MPI test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +!/ + USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN + USE W3PARALL, ONLY: INIT_GET_ISEA + USE W3WDATMD, ONLY: A => VA +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, GSTORE + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE +#endif +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: ISPEC + REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2)) +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ +#ifdef W3_SHRD + INTEGER :: ISEA, IXY +#endif +#ifdef W3_MPI + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & + IOFF, IERR_MPI, JSEA, ISEA, & + IXY, IS0, IB0, NPST, J +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_MPIT + CHARACTER(LEN=15) :: STR(MPIBUF), STRT +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3GATH') +#endif +! + FIELD = 0. +! +! 1. Shared memory version ------------------------------------------ / +! +#ifdef W3_SHRD + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + FIELD(IXY) = A(ISPEC,ISEA) + END DO +#endif +! +#ifdef W3_SHRD + RETURN +#endif +! +! 2. Distributed memory version ( MPI ) ----------------------------- / +! 2.a Update counters +! +#ifdef W3_MPI + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 +#endif +! +#ifdef W3_MPIT + IF ( ISPLOC .EQ. 1 ) THEN + STR = '--------------+' + WRITE (NDST,9000) STR + END IF + STR = ' |' + STRT = STR(IBFLOC) + STRT(9:9) = 'A' +#endif +! +! 2.b Check status of present buffer +! 2.b.1 Scatter (send) still in progress, wait to end +! +#ifdef W3_MPI + IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IBFLOC) = 0 +#endif +#ifdef W3_MPIT + STRT(13:13) = 'S' +#endif +#ifdef W3_MPI + END IF +#endif +! +! 2.b.2 Gather (recv) not yet posted, post now +! +#ifdef W3_MPI + IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN + BSTAT(IBFLOC) = 1 + BISPL(IBFLOC) = ISPLOC + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) +#endif +#ifdef W3_MPIT + STRT(10:10) = 'g' +#endif +#ifdef W3_MPI + END IF +#endif +! +! 2.c Put local spectral densities in store +! +#ifdef W3_MPI + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) + END DO +#endif +! +! 2.d Wait for remote spectral densities +! +#ifdef W3_MPI + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) +#endif +! +#ifdef W3_MPIT + STRT(11:11) = 'G' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT +#endif +! +! 2.e Convert storage array to field. +! +#ifdef W3_MPI + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + FIELD(IXY) = GSTORE(ISEA,IBFLOC) + END DO +#endif +! +! 2.f Pre-fetch data in available buffers +! +#ifdef W3_MPI + IS0 = ISPLOC + IB0 = IBFLOC + NPST = 0 +#endif +! +#ifdef W3_MPI + DO J=1, MPIBUF-1 + IS0 = IS0 + 1 + IF ( IS0 .GT. NSPLOC ) EXIT + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 0 ) THEN + BSTAT(IB0) = 1 + BISPL(IB0) = IS0 + IOFF = 1 + (IS0-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + NPST = NPST + 1 +#endif +#ifdef W3_MPIT + STRT = STR(IB0) + STRT(10:10) = 'g' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STR(IB0) = STRT +#endif +#ifdef W3_MPI + END IF + IF ( NPST .GE. 2 ) EXIT + END DO +#endif +! +! 2.g Test output +! +#ifdef W3_MPIT + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO + WRITE (NDST,9010) ISPLOC, STR +#endif +! +#ifdef W3_MPI + RETURN +#endif +! +! Formats +! +#ifdef W3_MPIT + 9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & + ' -------------------------------'/ & + ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & + ' FRIST COLLUMN : LOCAL ISPEC'/ & + ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & + ' 0 : INACTIVE'/ & + ' 1 : RECEIVING'/ & + ' 2 : SENDING'/ & + ' LOCAL ISPEC FOR BUFFER'/ & + ' A : ACTIVE BUFFER'/ & + ' g/G: START/FINISH RECIEVE'/ & + ' s/S: START/FINISH SEND'/ & + ' +-----+',8A15) + 9010 FORMAT ( ' |',I4,' |',8A15) +#endif +!/ +!/ End of W3GATH ----------------------------------------------------- / +!/ + END SUBROUTINE W3GATH +!/ ------------------------------------------------------------------- / + SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 13-Jun-2006 | +!/ +-----------------------------------+ +!/ +!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) +!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) +!/ Major changes to logistics. +!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) +!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) +!/ +! 1. Purpose : +! +! 'Scatter' data back to spectral storage after propagation. +! +! 2. Method : +! +! Direct copy or communication calls (MPP version). +! See also W3GATH. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! ISPEC Int. I Spectral bin considered. +! MAPSTA I.A. I Status map for spatial grid. +! FIELD R.A. I Full field to be propagated. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! STRACE Subr. W3SERVMD Subroutine tracing. +! +! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL +! Subr. mpif.h MPI persistent comm. routines (!/MPI). +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3WAVE Subr. W3WAVEMD Actual wave model routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! None. +! +! 7. Remarks : +! +! - The field is put back but not converted ! +! - MPI persistent communication calls initialize in W3MPII. +! - See W3GATH and W3MPII for additional comments on data +! buffering. +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/SHRD Switch for message passing method. +! !/MPI Id. +! +! !/S Enable subroutine tracing. +! !/MPIT MPI test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +!/ + USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF + USE W3WDATMD, ONLY: A => VA +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & + NSPLOC, NRQSG2, IRQSG2, SSTORE +#endif + USE W3ODATMD, ONLY: NDST +#ifdef W3_MPI + USE W3ODATMD, ONLY: IAPROC, NAPROC +#endif + USE CONSTANTS, ONLY : LPDLIB + USE W3PARALL, only: INIT_GET_ISEA +!/ + IMPLICIT NONE +! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) + REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2)) +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ +#ifdef W3_SHRD + INTEGER :: ISEA, IXY +#endif +#ifdef W3_MPI + INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & + STATUS(MPI_STATUS_SIZE,NSPEC), & + JSEA, IB0 +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +#ifdef W3_MPIT + CHARACTER(LEN=15) :: STR(MPIBUF), STRT +#endif +#ifdef W3_MPI + LOGICAL :: DONE +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3SCAT') +#endif +! +! 1. Shared memory version ------------------------------------------ * +! +#ifdef W3_SHRD + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(IXY) + END DO +#endif +! +#ifdef W3_SHRD + RETURN +#endif +! +! 2. Distributed memory version ( MPI ) ----------------------------- * +! 2.a Initializations +! +#ifdef W3_MPIT + DO IB0=1, MPIBUF + STR(IB0) = ' |' + END DO +#endif +! +#ifdef W3_MPIT + STRT = STR(IBFLOC) + STRT(9:9) = 'A' +#endif +! +! 2.b Convert full grid to sea grid, active points only +! +#ifdef W3_MPI + DO ISEA=1, NSEA + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) + END DO +#endif +! +! 2.c Send spectral densities to appropriate remote +! +#ifdef W3_MPI + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) + BSTAT(IBFLOC) = 2 +#endif +#ifdef W3_MPIT + STRT(12:12) = 's' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT +#endif +! +! 2.d Save locally stored results +! +#ifdef W3_MPI + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IXY = MAPSF(ISEA,3) + IF (MAPSTA(IXY) .GE. 1) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) + END DO +#endif +! +! 2.e Check if any sends have finished +! +#ifdef W3_MPI + IB0 = IBFLOC +#endif +! +#ifdef W3_MPI + DO J=1, MPIBUF + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) THEN + CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & + STATUS, IERR_MPI ) + ELSE + DONE = .TRUE. + END IF + IF ( DONE .AND. NRQSG2.GT.0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + IF ( DONE ) THEN + BSTAT(IB0) = 0 +#endif +#ifdef W3_MPIT + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT +#endif +#ifdef W3_MPI + END IF + END IF + END DO +#endif +! +! 2.f Last component, finish message passing, reset buffer control +! +#ifdef W3_MPI + IF ( ISPLOC .EQ. NSPLOC ) THEN +#endif +! +#ifdef W3_MPI + DO IB0=1, MPIBUF + IF ( BSTAT(IB0) .EQ. 2 ) THEN + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IB0) = 0 +#endif +#ifdef W3_MPIT + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT +#endif +#ifdef W3_MPI + END IF + END DO +#endif +! +#ifdef W3_MPI + ISPLOC = 0 + IBFLOC = 0 +#endif +! +#ifdef W3_MPI + END IF +#endif +! +! 2.g Test output +! +#ifdef W3_MPIT + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO +#endif +! +#ifdef W3_MPIT + WRITE (NDST,9000) STR +#endif +! +#ifdef W3_MPIT + IF ( ISPLOC .EQ. 0 ) THEN + DO IB0=1, MPIBUF + STR(IB0) = '--------------+' + END DO + WRITE (NDST,9010) STR + WRITE (NDST,*) + END IF +#endif +! +#ifdef W3_MPI + RETURN +#endif +! +! Formats +! +#ifdef W3_MPIT + 9000 FORMAT ( ' | |',8A15) + 9010 FORMAT ( ' +-----+',8A15) +#endif +!/ +!/ End of W3SCAT ----------------------------------------------------- / +!/ + END SUBROUTINE W3SCAT +!/ ------------------------------------------------------------------- / + SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) +!/ +!/ +-----------------------------------+ +!/ | WAVEWATCH III NOAA/NCEP | +!/ | H. L. Tolman | +!/ | FORTRAN 90 | +!/ | Last update : 28-Dec-2004 | +!/ +-----------------------------------+ +!/ +!/ 23-Feb-2001 : Origination. ( version 2.07 ) +!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) +!/ +! 1. Purpose : +! +! Check minimum number of active sea points at given processor to +! evaluate the need for a MPI_BARRIER call. +! +! 2. Method : +! +! Evaluate mapsta. +! +! 3. Parameters : +! +! Parameter list +! ---------------------------------------------------------------- +! MAPSTA I.A. I Status map for spatial grid. +! FLAG0 log. O Flag to identify 0 as minimum. +! ---------------------------------------------------------------- +! +! 4. Subroutines used : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! STRACE Subr. W3SERVMD Subroutine tracing. +! ---------------------------------------------------------------- +! +! 5. Called by : +! +! Name Type Module Description +! ---------------------------------------------------------------- +! W3WAVE Subr. W3WAVEMD Actual wave model routine. +! ---------------------------------------------------------------- +! +! 6. Error messages : +! +! None. +! +! 7. Remarks : +! +! 8. Structure : +! +! See source code. +! +! 9. Switches : +! +! !/S Enable subroutine tracing. +! !/T Test output. +! +! 10. Source code : +! +!/ ------------------------------------------------------------------- / +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +!/ + USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF + USE W3ODATMD, ONLY: NDST, NAPROC + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC +!/ + IMPLICIT NONE +!/ +!/ ------------------------------------------------------------------- / +!/ Parameter list +!/ + INTEGER, INTENT(IN) :: MAPSTA(NY*NX) + LOGICAL, INTENT(OUT) :: FLAG0 +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY + INTEGER :: JSEA, ISPROC +#ifdef W3_S + INTEGER, SAVE :: IENT +#endif +!/ +!/ ------------------------------------------------------------------- / +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3NMIN') +#endif +! + NMIN = NSEA +! + DO IPROC=1, NAPROC + NLOC = 0 + DO ISEA=1, NSEA + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF (ISPROC .eq. IPROC) THEN + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 + END IF + END DO +#ifdef W3_SMC + !!Li For SMC grid, local sea points are equally NSEA/NAPROC + !!Li so the NLOC is overwirte by a constant. + NLOC = NSEA/NAPROC +#endif +! +#ifdef W3_T + WRITE (NDST,9000) IPROC, NLOC +#endif + NMIN = MIN ( NMIN , NLOC ) + END DO +! + FLAG0 = NMIN .EQ. 0 +#ifdef W3_T + WRITE (NDST,9001) NMIN, FLAG0 +#endif +! + RETURN +! +! Formats +! +#ifdef W3_T + 9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) + 9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) +#endif +!/ +!/ End of W3NMIN ----------------------------------------------------- / +!/ + END SUBROUTINE W3NMIN +!/ +!/ End of module W3WAVEMD -------------------------------------------- / +!/ + END MODULE W3WAVEMD diff --git a/model/ftn/w3wavset.ftn b/model/src/w3wavset.F90 similarity index 90% rename from model/ftn/w3wavset.ftn rename to model/src/w3wavset.F90 index 1b96e9ab3..a1a87a568 100644 --- a/model/ftn/w3wavset.ftn +++ b/model/src/w3wavset.F90 @@ -45,7 +45,9 @@ MODULE W3WAVSET ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -53,7 +55,9 @@ MODULE W3WAVSET !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ IMPLICIT NONE !/ @@ -63,11 +67,15 @@ MODULE W3WAVSET !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! LOGICAL :: DO_WAVE_SETUP = .TRUE. @@ -118,7 +126,9 @@ SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowExchangeModule, only : PDLIB_exchange1Dreal use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa @@ -132,11 +142,15 @@ SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), INTENT(IN) :: VAR(npa) REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) @@ -221,7 +235,9 @@ SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowExchangeModule, only : PDLIB_exchange1Dreal use yowNodepool, only : PDLIB_IEN, PDLIB_TRIA, npa, iplg @@ -236,11 +252,15 @@ SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), INTENT(IN) :: VAR(npa) @@ -343,7 +363,9 @@ SUBROUTINE DIFFERENTIATE_XYDIR(VAR, DVDX, DVDY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowNodepool, only: npa IMPLICIT NONE @@ -354,11 +376,15 @@ SUBROUTINE DIFFERENTIATE_XYDIR(VAR, DVDX, DVDY) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), INTENT(IN) :: VAR(npa) @@ -412,7 +438,9 @@ SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE CONSTANTS, ONLY: GRAV, DWAT use yowNodepool, only: npa, iplg @@ -430,11 +458,15 @@ SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(out) :: F_X(npa), F_Y(npa), DWNX(npa) REAL(8) :: h @@ -467,28 +499,40 @@ SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) DWNX(IP)=DW(ISEA) END DO ! -!/DEBUGSTP WRITE(740+IAPROC,*) 'min/max(DEP)=', minval(DWNX), maxval(DWNX) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'min/max(DEP)=', minval(DWNX), maxval(DWNX) +#endif -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(abs(SXX))=', sum(abs(SXX_p)) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(abs(SXY))=', sum(abs(SXY_p)) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(abs(SYY))=', sum(abs(SYY_p)) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(abs(SXX))=', sum(abs(SXX_p)) + WRITE(740+IAPROC,*) 'sum(abs(SXY))=', sum(abs(SXY_p)) + WRITE(740+IAPROC,*) 'sum(abs(SYY))=', sum(abs(SYY_p)) + FLUSH(740+IAPROC) +#endif CALL DIFFERENTIATE_XYDIR(SXX_p, U_X1, U_Y1) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + FLUSH(740+IAPROC) +#endif CALL DIFFERENTIATE_XYDIR(SXY_p, U_X2, U_Y2) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(absU_XY2)=', sum(abs(U_X2)), sum(abs(U_Y2)) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY2)=', sum(abs(U_X2)), sum(abs(U_Y2)) + FLUSH(740+IAPROC) +#endif F_X = -U_X1 - U_Y2 ! CALL DIFFERENTIATE_XYDIR(SYY_p, U_X1, U_Y1) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(absU_XY1)=', sum(abs(U_X1)), sum(abs(U_Y1)) + FLUSH(740+IAPROC) +#endif F_Y = -U_Y1 - U_X2 -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(F_X)=', sum(F_X) -!/DEBUGSTP WRITE(740+IAPROC,*) 'sum(F_Y)=', sum(F_Y) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'sum(F_X)=', sum(F_X) + WRITE(740+IAPROC,*) 'sum(F_Y)=', sum(F_Y) + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) @@ -536,7 +580,9 @@ SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowElementpool, only: INE use yowNodepool, only: x, y, PDLIB_TRIA @@ -548,11 +594,15 @@ SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER, intent(in) :: IE, I1 REAL(8), intent(inout) :: UGRAD, VGRAD @@ -620,7 +670,9 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY, DWNX, ACTIVE, ACTIVE ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowElementpool, only: INE, NE use yowNodepool, only: PDLIB_NNZ, PDLIB_JA_IE, PDLIB_TRIA, npa, np @@ -633,11 +685,15 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY, DWNX, ACTIVE, ACTIVE !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: FX(npa), FY(npa), DWNX(npa) real(8), intent(out) :: ASPAR(PDLIB_NNZ) @@ -779,7 +835,9 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowExchangeModule, only : PDLIB_exchange1Dreal use yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG @@ -795,11 +853,15 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) REAL(8), intent(in) :: TheIn(npa) @@ -894,7 +956,9 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! use yowExchangeModule, only : PDLIB_exchange1Dreal USE yowNodepool, only: PDLIB_IA, PDLIB_JA, PDLIB_NNZ @@ -908,11 +972,15 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) REAL(8), intent(in) :: TheIn(npa) @@ -978,7 +1046,9 @@ SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX USE W3ADATMD, ONLY: MPI_COMM_WCMP @@ -994,11 +1064,15 @@ SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: V1(npa), V2(npa) real(8), intent(inout) :: eScal @@ -1072,7 +1146,9 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ USE W3GDATMD, ONLY: NSEAL, SOLVERTHR_STP @@ -1086,11 +1162,15 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: ASPAR(PDLIB_NNZ) real(8), intent(in) :: B(npa) @@ -1103,38 +1183,52 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A integer IP, nbIter SOLVERTHR=SOLVERTHR_STP -!/DEBUGSTP WRITE(740+IAPROC,*) 'Begin TRIG_WAVE_SETUP_SOLVE ....' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Begin TRIG_WAVE_SETUP_SOLVE ....' + FLUSH(740+IAPROC) +#endif nbIter=0 V_X=0 V_R=B CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) V_P=V_Z CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uO) -!/DEBUGSTP WRITE(740+IAPROC,*) 'uO=', uO -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'uO=', uO + FLUSH(740+IAPROC) +#endif CALL TRIG_WAVE_SETUP_SCALAR_PROD(B, B, eNorm) -!/DEBUGSTP WRITE(740+IAPROC,*) 'eNorm(B)=', eNorm -!/DEBUGSTP WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'eNorm(B)=', eNorm + WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR + FLUSH(740+IAPROC) +#endif WRITE(740+IAPROC,*) 'SOLVERTHR=', SOLVERTHR, ' eNorm(B)=', eNorm IF (eNorm .le. SOLVERTHR) THEN -!/DEBUGSTP WRITE(740+IAPROC,*) 'Leaving here, zero solution' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Leaving here, zero solution' + FLUSH(740+IAPROC) +#endif TheOut=V_X RETURN END IF DO nbIter=nbIter + 1 -!/DEBUGSTP WRITE(740+IAPROC,*) ' nbIter=', nbIter -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) ' nbIter=', nbIter + FLUSH(740+IAPROC) +#endif CALL TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, V_P, V_Y, ACTIVE, ACTIVESEC) CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_P, V_Y, h2) -!/DEBUGSTP WRITE(740+IAPROC,*) ' h2=', h2 -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) ' h2=', h2 + FLUSH(740+IAPROC) +#endif alphaV=uO/h2 -!/DEBUGSTP WRITE(740+IAPROC,*) ' alphaV=', alphaV -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) ' alphaV=', alphaV + FLUSH(740+IAPROC) +#endif ! DO IP=1,npa @@ -1143,8 +1237,10 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A END DO ! CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_R, V_R, eNorm) -!/DEBUGSTP WRITE(740+IAPROC,*) 'eNorm=', eNorm -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'eNorm=', eNorm + FLUSH(740+IAPROC) +#endif WRITE(740+IAPROC,*) 'nbIter=', nbIter, ' eNorm(res)=', eNorm FLUSH(740+IAPROC) IF (eNorm .le. SOLVERTHR) THEN @@ -1153,13 +1249,17 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A ! CALL TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, V_R, V_Z, ACTIVE, ACTIVESEC) CALL TRIG_WAVE_SETUP_SCALAR_PROD(V_Z, V_R, uN) -!/DEBUGSTP WRITE(740+IAPROC,*) ' uN=', uN -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) ' uN=', uN + FLUSH(740+IAPROC) +#endif ! beta=uN/uO uO=uN -!/DEBUGSTP WRITE(740+IAPROC,*) 'beta=', beta -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'beta=', beta + FLUSH(740+IAPROC) +#endif ! DO IP=1,npa V_P(IP)=V_Z(IP) + beta * V_P(IP) @@ -1213,7 +1313,9 @@ SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_SI USE W3GDATMD, ONLY: NX, SI @@ -1230,11 +1332,15 @@ SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(inout) :: TheVar(npa) real(8) :: SUM_SI_Var, SUM_SI, TheMean @@ -1249,8 +1355,10 @@ SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) END DO eVect(1)=SUM_SI_Var eVect(2)=SUM_SI -!/DEBUGSTP WRITE(740+IAPROC,*) 'SUM_SI_Var=', SUM_SI_Var, 'SUM_SI=', SUM_SI -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'SUM_SI_Var=', SUM_SI_Var, 'SUM_SI=', SUM_SI + FLUSH(740+IAPROC) +#endif IF (IAPROC .eq. 1) THEN DO iProc=2,NAPROC CALL MPI_RECV(rVect,2,rtype, iProc-1, 367, MPI_COMM_WCMP, istatus, ierr) @@ -1266,8 +1374,10 @@ SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) SUM_SI_Var=eVect(1) SUM_SI =eVect(2) TheMean=SUM_SI_Var/SUM_SI -!/DEBUGSTP WRITE(740+IAPROC,*) 'TheMean=', TheMean -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'TheMean=', TheMean + FLUSH(740+IAPROC) +#endif DO IP=1,npa TheVar(IP)=TheVar(IP) - TheMean END DO @@ -1318,7 +1428,9 @@ SUBROUTINE COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY : CRIT_DEP_STP USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np @@ -1331,30 +1443,40 @@ SUBROUTINE COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL*8, INTENT(in) :: DWNX(npa) INTEGER, INTENT(out) :: ACTIVE(npa) INTEGER IP, eAct -!/DEBUGSTP INTEGER nbActive -!/DEBUGSTP nbActive=0 +#ifdef W3_DEBUGSTP + INTEGER nbActive + nbActive=0 +#endif DO IP=1,NPA IF (DWNX(IP) .ge. CRIT_DEP_STP) THEN eAct=1 ELSE eAct=0 END IF -!/DEBUGSTP nbActive=nbActive + eAct +#ifdef W3_DEBUGSTP + nbActive=nbActive + eAct +#endif ACTIVE(IP)=eAct END DO -!/DEBUGSTP WRITE(740+IAPROC,*) 'min/max(DWNX)=', minval(DWNX), maxval(DWNX) -!/DEBUGSTP WRITE(740+IAPROC,*) 'CRIT_DEP_STP=', CRIT_DEP_STP -!/DEBUGSTP WRITE(740+IAPROC,*) 'nbActive=', nbActive, ' npa=', npa -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'min/max(DWNX)=', minval(DWNX), maxval(DWNX) + WRITE(740+IAPROC,*) 'CRIT_DEP_STP=', CRIT_DEP_STP + WRITE(740+IAPROC,*) 'nbActive=', nbActive, ' npa=', npa + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION @@ -1402,7 +1524,9 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, iplg, npa, np USE W3GDATMD, only : MAPFS @@ -1421,11 +1545,15 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! ! CALL W3SETG REAL(8) :: ZETA_WORK(npa), ZETA_WORK_ALL(NX) @@ -1435,9 +1563,11 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION INTEGER :: ACTIVE(npa), ACTIVESEC(npa) ! ZETA_SETUP is allocated on 1:NSEA ! ZETA_WORK is on 1:npa -!/DEBUGSTP WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC -!/DEBUGSTP WRITE(740+IAPROC,*) 'NSEAL=', NSEAL -!/DEBUGSTP WRITE(740+IAPROC,*) 'npa=', npa, ' np=', np +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, ' NTPROC=', NTPROC + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'npa=', npa, ' np=', np +#endif FLUSH(740+IAPROC) ZETA_WORK=0 DO IP=1,npa @@ -1447,30 +1577,42 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION ZETA_WORK(IP)=ZETA_SETUP(ISEA) END IF END DO -!/DEBUGSTP WRITE(740+IAPROC,*) 'Before TRIG_COMPUTE_LH_STRESS' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Before TRIG_COMPUTE_LH_STRESS' + FLUSH(740+IAPROC) +#endif CALL TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) -!/DEBUGSTP WRITE(740+IAPROC,*) 'After TRIG_COMPUTE_LH_STRESS' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After TRIG_COMPUTE_LH_STRESS' + FLUSH(740+IAPROC) +#endif CALL COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) -!/DEBUGSTP WRITE(740+IAPROC,*) 'After COMPUTE_ACTIVE_NODE' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After COMPUTE_ACTIVE_NODE' + FLUSH(740+IAPROC) +#endif CALL TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, F_X, F_Y, DWNX, ACTIVE, ACTIVESEC) -!/DEBUGSTP WRITE(740+IAPROC,*) 'Before,B,min=', minval(B), ' max=', maxval(B) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Before,B,min=', minval(B), ' max=', maxval(B) + FLUSH(740+IAPROC) +#endif ! CALL TRIG_SET_MEANVALUE_TO_ZERO(B) -!/DEBUGSTP WRITE(740+IAPROC,*) 'After,B,min=', minval(B), ' max=', maxval(B) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After,B,min=', minval(B), ' max=', maxval(B) + FLUSH(740+IAPROC) +#endif CALL TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, ZETA_WORK, ACTIVE, ACTIVESEC) CALL TRIG_SET_MEANVALUE_TO_ZERO(ZETA_WORK) -!/DEBUGSTP WRITE(740+IAPROC,*) 'After SET_MEAN min=', minval(ZETA_WORK), ' max=', maxval(ZETA_WORK) -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'After SET_MEAN min=', minval(ZETA_WORK), ' max=', maxval(ZETA_WORK) + FLUSH(740+IAPROC) +#endif DO IP=1,npa IX=iplg(IP) ZETA_WORK_ALL(IX)=ZETA_WORK(IP) @@ -1482,8 +1624,10 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION ZETA_SETUP(ISEA) = ZETA_WORK_ALL(IX) END IF END DO -!/DEBUGSTP WRITE(740+IAPROC,*) 'Now exiting TRIG_WAVE_SETUP_COMPUTATION' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Now exiting TRIG_WAVE_SETUP_COMPUTATION' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / SUBROUTINE PREPARATION_FD_SCHEME(IMOD) @@ -1531,7 +1675,9 @@ SUBROUTINE PREPARATION_FD_SCHEME(IMOD) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, GRIDS @@ -1543,11 +1689,15 @@ SUBROUTINE PREPARATION_FD_SCHEME(IMOD) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer, intent(in) :: IMOD integer IN, ISEA, nbEdge @@ -1683,7 +1833,9 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX, NNZ, IAA, JAA, NSEA use yowNodepool, only: PDLIB_IA, PDLIB_JA @@ -1695,11 +1847,15 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), intent(in) :: ASPAR(NNZ) REAL(8), intent(in) :: TheIn(NSEA) @@ -1761,7 +1917,9 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ, PDLIB_IA, PDLIB_JA, PDLIB_I_DIAG USE W3GDATMD, ONLY: NSEA @@ -1773,11 +1931,15 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! REAL(8), intent(in) :: ASPAR(PDLIB_NNZ) REAL(8), intent(in) :: TheIn(NSEA) @@ -1858,7 +2020,9 @@ SUBROUTINE FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3ADATMD, ONLY: SXX, SXY, SYY USE W3GDATMD, ONLY: NSEA, NSEAL @@ -1873,11 +2037,15 @@ SUBROUTINE FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! integer ISEA, JSEA integer ierr @@ -1969,7 +2137,9 @@ SUBROUTINE FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, FX, FY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX, NY, NSEA, NEIGH USE W3ADATMD, ONLY: SXX, SXY, SYY @@ -1981,11 +2151,15 @@ SUBROUTINE FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, FX, FY) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: SXX_t(NSEA), SXY_t(NSEA), SYY_t(NSEA) real(8), intent(out) :: FX(NSEA), FY(NSEA) @@ -2103,7 +2277,9 @@ SUBROUTINE FD_COMPUTE_DIFF(IEDGE, ISEA, UGRAD, VGRAD, dist) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: MAPSF, EDGES USE W3GDATMD, ONLY: XGRD, YGRD @@ -2115,11 +2291,15 @@ SUBROUTINE FD_COMPUTE_DIFF(IEDGE, ISEA, UGRAD, VGRAD, dist) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER, intent(in) :: IEDGE, ISEA REAL(8), intent(inout) :: UGRAD, VGRAD, dist @@ -2192,7 +2372,9 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ USE W3GDATMD, ONLY: NX, NY, NSEA, NBEDGE, EDGES @@ -2205,11 +2387,15 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: FX(NSEA), FY(NSEA) real(8), intent(out) :: ASPAR(PDLIB_NNZ) @@ -2292,7 +2478,9 @@ SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX IMPLICIT NONE @@ -2303,11 +2491,15 @@ SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: V1(NX), V2(NX) real(8), intent(inout) :: eScal @@ -2363,7 +2555,9 @@ SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ USE W3GDATMD, ONLY: NX @@ -2375,11 +2569,15 @@ SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(in) :: ASPAR(PDLIB_NNZ) real(8), intent(in) :: B(NX) @@ -2470,7 +2668,9 @@ SUBROUTINE FD_SET_MEANVALUE_TO_ZERO(TheVar) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX, SI IMPLICIT NONE @@ -2481,11 +2681,15 @@ SUBROUTINE FD_SET_MEANVALUE_TO_ZERO(TheVar) !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! real(8), intent(inout) :: TheVar(NX) real(8) :: SUM_SI_Var, SUM_SI, TheMean @@ -2547,7 +2751,9 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTATION ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE yowNodepool, only: PDLIB_NNZ USE W3GDATMD, ONLY: NX, NSEA, NSEAL @@ -2563,11 +2769,15 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! ! CALL W3SETG REAL(8) :: ZETA_WORK(NSEA) @@ -2641,7 +2851,9 @@ SUBROUTINE WAVE_SETUP_COMPUTATION ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NSEA, NSEAL USE W3GDATMD, ONLY: GTYPE, UNGTYPE @@ -2654,20 +2866,28 @@ SUBROUTINE WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / !/ Local PARAMETERs !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#ifdef W3_S + CALL STRACE (IENT, 'VA_SETUP_IOBPD') +#endif ! INTEGER ISEA, JSEA REAL*8, allocatable :: ZETA_WORK(:) -!/DEBUGSTP WRITE(740+IAPROC,*) 'NAPROC=', NAPROC -!/DEBUGSTP WRITE(740+IAPROC,*) 'NTPROC=', NTPROC -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + WRITE(740+IAPROC,*) 'NTPROC=', NTPROC + FLUSH(740+IAPROC) +#endif IF (IAPROC .le. NAPROC) THEN -!/DEBUGSTP WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' + FLUSH(740+IAPROC) +#endif IF (DO_WAVE_SETUP) THEN IF (GTYPE .EQ. UNGTYPE) THEN CALL TRIG_WAVE_SETUP_COMPUTATION @@ -2676,8 +2896,10 @@ SUBROUTINE WAVE_SETUP_COMPUTATION END IF END IF END IF -!/DEBUGSTP WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' -!/DEBUGSTP FLUSH(740+IAPROC) +#ifdef W3_DEBUGSTP + WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' + FLUSH(740+IAPROC) +#endif END SUBROUTINE !/ ------------------------------------------------------------------- / END MODULE diff --git a/model/ftn/w3wdasmd.ftn b/model/src/w3wdasmd.F90 similarity index 80% rename from model/ftn/w3wdasmd.ftn rename to model/src/w3wdasmd.F90 index 14e32135f..b2094d285 100644 --- a/model/ftn/w3wdasmd.ftn +++ b/model/src/w3wdasmd.F90 @@ -150,11 +150,15 @@ SUBROUTINE W3WDAS ( DASFLAG, RECL, NDAT, DATA0, DATA1, DATA2 ) USE W3ADATMD USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & NAPLOG, NAPOUT, NAPERR -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -169,45 +173,57 @@ SUBROUTINE W3WDAS ( DASFLAG, RECL, NDAT, DATA0, DATA1, DATA2 ) !/ Local parameters : !/ INTEGER :: J -!/T INTEGER :: MREC, MDAT, IREC, IDAT -!/S INTEGER, SAVE :: IENT = 0 -!/T REAL, ALLOCATABLE :: TDATA(:,:) +#ifdef W3_T + INTEGER :: MREC, MDAT, IREC, IDAT +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T + REAL, ALLOCATABLE :: TDATA(:,:) +#endif !/ !/ ------------------------------------------------------------------- / ! 1. Initializations and test output ! 1.a Subroutine tracing ! -!/S CALL STRACE (IENT, 'W3WDAS') +#ifdef W3_S + CALL STRACE (IENT, 'W3WDAS') +#endif ! ! 1.b Echo part of parameter list (test output only). ! -!/T WRITE (NDST,9000) NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & -!/T NAPOUT, NAPERR, TIME -!/T DO J=1, 3 -!/T IF ( DASFLAG(J) ) THEN -!/T WRITE (NDST,9001) J, DASFLAG(J), RECL(J), NDAT(J) -!/T MREC = MIN(RECL(J),6) -!/T MDAT = MIN(NDAT(J),10) -!/T IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) -!/T ALLOCATE ( TDATA(RECL(J),MDAT) ) -!/T IF ( J .EQ. 1 ) TDATA = DATA0(:,1:MDAT) -!/T IF ( J .EQ. 2 ) TDATA = DATA1(:,1:MDAT) -!/T IF ( J .EQ. 3 ) TDATA = DATA2(:,1:MDAT) -!/T DO IDAT=1, MDAT -!/T WRITE (NDST,9002) IDAT, TDATA(1:MREC,IDAT) -!/T IF ( MREC .LT. RECL(J) ) WRITE (NDST,9003) & -!/T TDATA(MREC+1:RECL(J),IDAT) -!/T END DO -!/T ELSE -!/T WRITE (NDST,9001) J, DASFLAG(J) -!/T END IF -!/T END DO -!/T IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) +#ifdef W3_T + WRITE (NDST,9000) NDSO, NDSE, NDST, SCREEN, NAPROC, IAPROC, & + NAPOUT, NAPERR, TIME + DO J=1, 3 + IF ( DASFLAG(J) ) THEN + WRITE (NDST,9001) J, DASFLAG(J), RECL(J), NDAT(J) + MREC = MIN(RECL(J),6) + MDAT = MIN(NDAT(J),10) + IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) + ALLOCATE ( TDATA(RECL(J),MDAT) ) + IF ( J .EQ. 1 ) TDATA = DATA0(:,1:MDAT) + IF ( J .EQ. 2 ) TDATA = DATA1(:,1:MDAT) + IF ( J .EQ. 3 ) TDATA = DATA2(:,1:MDAT) + DO IDAT=1, MDAT + WRITE (NDST,9002) IDAT, TDATA(1:MREC,IDAT) + IF ( MREC .LT. RECL(J) ) WRITE (NDST,9003) & + TDATA(MREC+1:RECL(J),IDAT) + END DO + ELSE + WRITE (NDST,9001) J, DASFLAG(J) + END IF + END DO + IF ( ALLOCATED(TDATA) ) DEALLOCATE (TDATA) +#endif ! ! 1.c Test grid info from W3GDATMD ! -!/T WRITE (NDST,9010) NX, NY, NSEA, NSEAL, NK, NTH, & -!/T ICLOSE, FLAGLL, SX, SY, X0, Y0 +#ifdef W3_T + WRITE (NDST,9010) NX, NY, NSEA, NSEAL, NK, NTH, & + ICLOSE, FLAGLL, SX, SY, X0, Y0 +#endif ! ! 2. Actual data assimilation routine ------------------------------- / ! @@ -233,15 +249,19 @@ SUBROUTINE W3WDAS ( DASFLAG, RECL, NDAT, DATA0, DATA1, DATA2 ) !1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WDAS :'/ & ! ' ILLIGAL GRID SIZES INPUT : ',4I8/ & ! ' GRID : ',4I8/) -!/T 9000 FORMAT ( ' TEST W3WDAS : UNIT NUMBERS : ',4I4/ & -!/T ' MPI SETTINGS : ',4I4/ & -!/T ' TIME : ',I8.8,I7.6) -!/T 9001 FORMAT ( ' DATASET INFO : ',I1,L2,2I8) -!/T 9002 FORMAT (17X,I2,6E10.3) -!/T 9003 FORMAT (19X, 6E10.3) -! -!/T 9010 FORMAT ( ' TEST W3WDAS : ARRAY DIMS. : ',6I8/ & -!/T ' GRID : ',1I2,1L2,4E11.4) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3WDAS : UNIT NUMBERS : ',4I4/ & + ' MPI SETTINGS : ',4I4/ & + ' TIME : ',I8.8,I7.6) + 9001 FORMAT ( ' DATASET INFO : ',I1,L2,2I8) + 9002 FORMAT (17X,I2,6E10.3) + 9003 FORMAT (19X, 6E10.3) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST W3WDAS : ARRAY DIMS. : ',6I8/ & + ' GRID : ',1I2,1L2,4E11.4) +#endif !/ !/ End of W3WDAS ----------------------------------------------------- / !/ diff --git a/model/ftn/w3wdatmd.ftn b/model/src/w3wdatmd.F90 similarity index 72% rename from model/ftn/w3wdatmd.ftn rename to model/src/w3wdatmd.F90 index cb97c14cb..b7029697e 100644 --- a/model/ftn/w3wdatmd.ftn +++ b/model/src/w3wdatmd.F90 @@ -123,19 +123,27 @@ MODULE W3WDATMD TYPE WDATA INTEGER :: TIME(2), TLEV(2), TICE(2), TRHO(2), & TIC1(2), TIC5(2) -!/OASIS INTEGER :: TIME00(2) -!/OASIS INTEGER :: TIMEEND(2) -!/NL5 INTEGER :: QI5TBEG(2) -!/NL5 REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) -!/NL5 COMPLEX, POINTER :: QC5INT0(:, :) +#ifdef W3_OASIS + INTEGER :: TIME00(2) + INTEGER :: TIMEEND(2) +#endif +#ifdef W3_NL5 + INTEGER :: QI5TBEG(2) + REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) + COMPLEX, POINTER :: QC5INT0(:, :) +#endif REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & UST(:), USTDIR(:), ASF(:), FPIS(:), & BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) -!/SETUP REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) -!/SETUP REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) -!/PDLIB REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) -!/PDLIB REAL, POINTER :: VAOLD(:,:) -!/PDLIB LOGICAL, POINTER :: SHAVETOT(:) +#ifdef W3_SETUP + REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) + REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) +#endif +#ifdef W3_PDLIB + REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) + REAL, POINTER :: VAOLD(:,:) + LOGICAL, POINTER :: SHAVETOT(:) +#endif !!/PDLIB REAL, POINTER :: VAOLD(:,:) LOGICAL :: DINIT, FL_ALL END TYPE WDATA @@ -149,19 +157,27 @@ MODULE W3WDATMD !/ INTEGER, POINTER :: TIME(:), TLEV(:), TICE(:), TRHO(:), & TIC1(:), TIC5(:) -!/OASIS INTEGER, POINTER :: TIME00(:) -!/OASIS INTEGER, POINTER :: TIMEEND(:) -!/NL5 INTEGER, POINTER :: QI5TBEG(:) -!/NL5 REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) -!/NL5 COMPLEX, POINTER :: QC5INT0(:, :) +#ifdef W3_OASIS + INTEGER, POINTER :: TIME00(:) + INTEGER, POINTER :: TIMEEND(:) +#endif +#ifdef W3_NL5 + INTEGER, POINTER :: QI5TBEG(:) + REAL, POINTER :: QR5TIM0(:), QR5CVK0(:, :), QR5TMIX(:) + COMPLEX, POINTER :: QC5INT0(:, :) +#endif REAL, POINTER :: VA(:,:), WLV(:), ICE(:), RHOAIR(:), & UST(:), USTDIR(:), ASF(:), FPIS(:), & BERG(:), ICEH(:), ICEF(:), ICEDMAX(:) -!/SETUP REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) -!/SETUP REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) -!/PDLIB REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) -!/PDLIB REAL, POINTER :: VAOLD(:,:) -!/PDLIB LOGICAL, POINTER :: SHAVETOT(:) +#ifdef W3_SETUP + REAL, POINTER :: ZETA_SETUP(:), FX_zs(:), FY_zs(:) + REAL, POINTER :: SXX_zs(:), SXY_zs(:), SYY_zs(:) +#endif +#ifdef W3_PDLIB + REAL, POINTER :: VSTOT(:,:), VDTOT(:,:) + REAL, POINTER :: VAOLD(:,:) + LOGICAL, POINTER :: SHAVETOT(:) +#endif !!/PDLIB REAL, POINTER :: VAOLD(:,:) LOGICAL, POINTER :: DINIT, FL_ALL !/ @@ -221,7 +237,9 @@ SUBROUTINE W3NDAT ( NDSE, NDST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NGRIDS USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -234,9 +252,13 @@ SUBROUTINE W3NDAT ( NDSE, NDST ) !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3NDAT') +#ifdef W3_S + CALL STRACE (IENT, 'W3NDAT') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -261,7 +283,9 @@ SUBROUTINE W3NDAT ( NDSE, NDST ) WDATAS(I)%FL_ALL = .FALSE. END DO ! -!/T WRITE (NDST,9000) NGRIDS +#ifdef W3_T + WRITE (NDST,9000) NGRIDS +#endif ! RETURN ! @@ -271,7 +295,9 @@ SUBROUTINE W3NDAT ( NDSE, NDST ) ' NGRIDS = ',I10/ & ' RUN W3NMOD FIRST'/) ! -!/T 9000 FORMAT (' TEST W3NDAT : SETTING UP FOR ',I4,' GRIDS') +#ifdef W3_T + 9000 FORMAT (' TEST W3NDAT : SETTING UP FOR ',I4,' GRIDS') +#endif !/ !/ End of W3NDAT ----------------------------------------------------- / !/ @@ -355,11 +381,17 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) USE W3SERVMD, ONLY: EXTCDE USE CONSTANTS, ONLY : LPDLIB, DAIR USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM -!/NL5 USE W3GDATMD, ONLY: QI5NNZ -!/PDLIB use yowNodepool, only: npa, np -!/PDLIB use yowRankModule, only : rank -!/PDLIB USE W3GDATMD, ONLY: GTYPE, UNGTYPE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_NL5 + USE W3GDATMD, ONLY: QI5NNZ +#endif +#ifdef W3_PDLIB + use yowNodepool, only: npa, np + use yowRankModule, only : rank + USE W3GDATMD, ONLY: GTYPE, UNGTYPE +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -375,12 +407,20 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) !/ INTEGER :: JGRID, NSEALM, NSEATM INTEGER :: NSEAL_DUMMY, ISEA -!/PDLIB INTEGER IRANK -!/S INTEGER, SAVE :: IENT = 0 -!/ -!/S CALL STRACE (IENT, 'W3DIMW') -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_PDLIB + INTEGER IRANK +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'W3DIMW') +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 1' + FLUSH(740+IAPROC) +#endif ! ! -------------------------------------------------------------------- / @@ -391,132 +431,206 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) ELSE FL_ALL = .TRUE. END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 2' + FLUSH(740+IAPROC) +#endif ! IF ( NGRIDS .EQ. -1 ) THEN WRITE (NDSE,1001) CALL EXTCDE (1) END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 3' + FLUSH(740+IAPROC) +#endif ! IF ( IMOD.LT.1 .OR. IMOD.GT.NWDATA ) THEN WRITE (NDSE,1002) IMOD, NWDATA CALL EXTCDE (2) END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 4' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 4' + FLUSH(740+IAPROC) +#endif ! IF ( WDATAS(IMOD)%DINIT ) THEN WRITE (NDSE,1003) CALL EXTCDE (3) END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 5' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 5' + FLUSH(740+IAPROC) +#endif ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 6' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 6' + FLUSH(740+IAPROC) +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays ! CALL SET_UP_NSEAL_NSEALM(NSEAL_DUMMY, NSEALM) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 7' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 7' + FLUSH(740+IAPROC) +#endif NSEATM = NSEALM * NAPROC -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8' + FLUSH(740+IAPROC) +#endif ! IF ( FL_ALL ) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8' + FLUSH(740+IAPROC) +#endif ALLOCATE ( WDATAS(IMOD)%VA(NSPEC,0:NSEALM), STAT=ISTAT ); WDATAS(IMOD)%VA = 0. -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.1' + FLUSH(740+IAPROC) +#endif CHECK_ALLOC_STATUS ( ISTAT ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.2' + FLUSH(740+IAPROC) +#endif !!/PDLIB ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,0:NSEALM) ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.3' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB ALLOCATE ( WDATAS(IMOD)%SHAVETOT(NSEAL), stat=istat ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.4, stat=', istat -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB ALLOCATE ( WDATAS(IMOD)%VSTOT(NSPEC,NSEAL), stat=istat ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.5, stat=', istat -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB ALLOCATE ( WDATAS(IMOD)%VDTOT(NSPEC,NSEAL), stat=istat ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.6, stat=', istat -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,NSEAL), stat=istat ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.7, stat=', istat -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB DO ISEA=1,NSEAL -!/DEBUGINIT WRITE(740+IAPROC,*) 'Setting to ZERO at ISEA=', ISEA -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB WDATAS(IMOD)%VSTOT(:,ISEA)=0 -!/PDLIB END DO -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.8' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB WDATAS(IMOD)%VDTOT=0 -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.9' -!/DEBUGINIT FLUSH(740+IAPROC) -!/PDLIB WDATAS(IMOD)%SHAVETOT=.FALSE. -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.10' -!/DEBUGINIT FLUSH(740+IAPROC) -!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEAL=', NSEAL, ' NSEALM=', NSEALM -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.3' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ALLOCATE ( WDATAS(IMOD)%SHAVETOT(NSEAL), stat=istat ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.4, stat=', istat + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ALLOCATE ( WDATAS(IMOD)%VSTOT(NSPEC,NSEAL), stat=istat ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.5, stat=', istat + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ALLOCATE ( WDATAS(IMOD)%VDTOT(NSPEC,NSEAL), stat=istat ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.6, stat=', istat + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,NSEAL), stat=istat ) +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.7, stat=', istat + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + DO ISEA=1,NSEAL +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Setting to ZERO at ISEA=', ISEA + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + WDATAS(IMOD)%VSTOT(:,ISEA)=0 + END DO +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.8' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + WDATAS(IMOD)%VDTOT=0 +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.9' + FLUSH(740+IAPROC) +#endif +#ifdef W3_PDLIB + WDATAS(IMOD)%SHAVETOT=.FALSE. +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.10' + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'NSEAL=', NSEAL, ' NSEALM=', NSEALM + FLUSH(740+IAPROC) +#endif ! ! * Four arrays for NL5 (QL) ! * AFAIK, the set up of QR5TIM0, QR5CVK0, QC5INT0 should be similar ! * to VA, though I am not really clear about how FL_ALL works. ! * -!/NL5 ALLOCATE ( WDATAS(IMOD)%QR5TIM0(0:NSEALM), & -!/NL5 WDATAS(IMOD)%QR5CVK0(NSPEC, 0:NSEALM), & -!/NL5 WDATAS(IMOD)%QC5INT0(QI5NNZ, 0:NSEALM), & -!/NL5 WDATAS(IMOD)%QR5TMIX(0:NSEALM), STAT=ISTAT) -!/NL5 CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_NL5 + ALLOCATE ( WDATAS(IMOD)%QR5TIM0(0:NSEALM), & + WDATAS(IMOD)%QR5CVK0(NSPEC, 0:NSEALM), & + WDATAS(IMOD)%QC5INT0(QI5NNZ, 0:NSEALM), & + WDATAS(IMOD)%QR5TMIX(0:NSEALM), STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! ! * Initialized NL5 arrays with zero (QL) -!/NL5 WDATAS(IMOD)%QR5TIM0 = 0.0 -!/NL5 WDATAS(IMOD)%QR5CVK0 = 0.0 -!/NL5 WDATAS(IMOD)%QC5INT0 = (0.0, 0.0) -!/NL5 WDATAS(IMOD)%QR5TMIX = 0.0 -! -!/NL5 WRITE(*, *) -!/NL5 WRITE(*, '(A, I4, I12)') '⊚ → [WW3 WDAT]: IMOD & QI5NNZ: ', IMOD, QI5NNZ -!/NL5 WRITE(*, *) +#ifdef W3_NL5 + WDATAS(IMOD)%QR5TIM0 = 0.0 + WDATAS(IMOD)%QR5CVK0 = 0.0 + WDATAS(IMOD)%QC5INT0 = (0.0, 0.0) + WDATAS(IMOD)%QR5TMIX = 0.0 +#endif +! +#ifdef W3_NL5 + WRITE(*, *) + WRITE(*, '(A, I4, I12)') '⊚ → [WW3 WDAT]: IMOD & QI5NNZ: ', IMOD, QI5NNZ + WRITE(*, *) +#endif ! IF ( NSEAL .NE. NSEALM ) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before settings to ZERO' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before settings to ZERO' + FLUSH(740+IAPROC) +#endif DO ISEA=NSEAL+1,NSEALM -!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ISEA=', ISEA + FLUSH(740+IAPROC) +#endif WDATAS(IMOD)%VA(:,ISEA) = 0. ! -!/NL5 WDATAS(IMOD)%QR5TIM0(ISEA) = 0.0 -!/NL5 WDATAS(IMOD)%QR5CVK0(:,ISEA) = 0.0 -!/NL5 WDATAS(IMOD)%QC5INT0(:,ISEA) = (0.0, 0.0) -!/NL5 WDATAS(IMOD)%QR5TMIX(ISEA) = 0.0 +#ifdef W3_NL5 + WDATAS(IMOD)%QR5TIM0(ISEA) = 0.0 + WDATAS(IMOD)%QR5CVK0(:,ISEA) = 0.0 + WDATAS(IMOD)%QC5INT0(:,ISEA) = (0.0, 0.0) + WDATAS(IMOD)%QR5TMIX(ISEA) = 0.0 +#endif END DO END IF -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 8.11' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 8.11' + FLUSH(740+IAPROC) +#endif END IF ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 9' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 9' + FLUSH(740+IAPROC) +#endif ! ICE, ICEH, ICEF must be defined from 0:NSEA ALLOCATE ( WDATAS(IMOD)%WLV(NSEA), & WDATAS(IMOD)%ICE(0:NSEA), & WDATAS(IMOD)%RHOAIR(NSEA), & -!/SETUP WDATAS(IMOD)%ZETA_SETUP(NSEA), & +#ifdef W3_SETUP + WDATAS(IMOD)%ZETA_SETUP(NSEA), & +#endif WDATAS(IMOD)%BERG(NSEA), & WDATAS(IMOD)%ICEH(0:NSEA), & WDATAS(IMOD)%ICEF(0:NSEA), & @@ -526,13 +640,17 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) WDATAS(IMOD)%ASF(NSEATM), & WDATAS(IMOD)%FPIS(NSEATM), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 10' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 10' + FLUSH(740+IAPROC) +#endif WDATAS(IMOD)%WLV (:) = 0. WDATAS(IMOD)%ICE (0:NSEA) = 0. WDATAS(IMOD)%RHOAIR(:) = DAIR -!/SETUP WDATAS(IMOD)%ZETA_SETUP(:) = 0. +#ifdef W3_SETUP + WDATAS(IMOD)%ZETA_SETUP(:) = 0. +#endif WDATAS(IMOD)%BERG (:) = 0. WDATAS(IMOD)%ICEH (0:NSEA) = GRIDS(IMOD)%IICEHINIT WDATAS(IMOD)%ICEF (0:NSEA) = 1000. @@ -542,19 +660,25 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) WDATAS(IMOD)%ASF (:) = 0. WDATAS(IMOD)%FPIS (:) = 0. WDATAS(IMOD)%DINIT = .TRUE. -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 11' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 11' + FLUSH(740+IAPROC) +#endif CALL W3SETW ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary ! IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'W3DIMW, step 12' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'W3DIMW, step 12' + FLUSH(740+IAPROC) +#endif RETURN ! ! Formats @@ -566,22 +690,30 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) ' NWDATA = ',I10/) 1003 FORMAT (/' *** ERROR W3DIMW : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST W3DIMW : MODEL ',I4,' DIM. AT ',2I5,I7) +#ifdef W3_T + 9000 FORMAT (' TEST W3DIMW : MODEL ',I4,' DIM. AT ',2I5,I7) +#endif ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL W3SETW ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update counters in grid -!/T 9001 FORMAT (' TEST W3DIMW : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST W3DIMW : POINTERS RESET') -!/T 9003 FORMAT (' TEST W3DIMW : DIMENSIONS STORED') +#ifdef W3_T + 9001 FORMAT (' TEST W3DIMW : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST W3DIMW : POINTERS RESET') + 9003 FORMAT (' TEST W3DIMW : DIMENSIONS STORED') +#endif !/ !/ End of W3DIMW ----------------------------------------------------- / !/ @@ -644,7 +776,9 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -656,9 +790,13 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'W3SETW') +#ifdef W3_S + CALL STRACE (IENT, 'W3SETW') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -673,7 +811,9 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model numbers @@ -684,9 +824,13 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) ! 3. Set pointers ! TIME => WDATAS(IMOD)%TIME -!/OASIS TIME00 => WDATAS(IMOD)%TIME00 -!/OASIS TIMEEND => WDATAS(IMOD)%TIMEEND -!/NL5 QI5TBEG => WDATAS(IMOD)%QI5TBEG +#ifdef W3_OASIS + TIME00 => WDATAS(IMOD)%TIME00 + TIMEEND => WDATAS(IMOD)%TIMEEND +#endif +#ifdef W3_NL5 + QI5TBEG => WDATAS(IMOD)%QI5TBEG +#endif TLEV => WDATAS(IMOD)%TLEV TICE => WDATAS(IMOD)%TICE TRHO => WDATAS(IMOD)%TRHO @@ -698,25 +842,31 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) IF ( DINIT ) THEN IF ( FL_ALL ) THEN VA => WDATAS(IMOD)%VA -!/NL5 QR5TIM0 => WDATAS(IMOD)%QR5TIM0 -!/NL5 QR5CVK0 => WDATAS(IMOD)%QR5CVK0 -!/NL5 QC5INT0 => WDATAS(IMOD)%QC5INT0 -!/NL5 QR5TMIX => WDATAS(IMOD)%QR5TMIX +#ifdef W3_NL5 + QR5TIM0 => WDATAS(IMOD)%QR5TIM0 + QR5CVK0 => WDATAS(IMOD)%QR5CVK0 + QC5INT0 => WDATAS(IMOD)%QC5INT0 + QR5TMIX => WDATAS(IMOD)%QR5TMIX +#endif !!/PDLIB VAOLD => WDATAS(IMOD)%VAOLD -!/PDLIB SHAVETOT => WDATAS(IMOD)%SHAVETOT -!/PDLIB VSTOT => WDATAS(IMOD)%VSTOT -!/PDLIB VDTOT => WDATAS(IMOD)%VDTOT -!/PDLIB VAOLD => WDATAS(IMOD)%VAOLD +#ifdef W3_PDLIB + SHAVETOT => WDATAS(IMOD)%SHAVETOT + VSTOT => WDATAS(IMOD)%VSTOT + VDTOT => WDATAS(IMOD)%VDTOT + VAOLD => WDATAS(IMOD)%VAOLD +#endif END IF WLV => WDATAS(IMOD)%WLV ICE => WDATAS(IMOD)%ICE RHOAIR => WDATAS(IMOD)%RHOAIR -!/SETUP ZETA_SETUP => WDATAS(IMOD)%ZETA_SETUP -!/SETUP FX_zs => WDATAS(IMOD)%FX_zs -!/SETUP FY_zs => WDATAS(IMOD)%FY_zs -!/SETUP SXX_zs => WDATAS(IMOD)%SXX_zs -!/SETUP SXY_zs => WDATAS(IMOD)%SXY_zs -!/SETUP SYY_zs => WDATAS(IMOD)%SYY_zs +#ifdef W3_SETUP + ZETA_SETUP => WDATAS(IMOD)%ZETA_SETUP + FX_zs => WDATAS(IMOD)%FX_zs + FY_zs => WDATAS(IMOD)%FY_zs + SXX_zs => WDATAS(IMOD)%SXX_zs + SXY_zs => WDATAS(IMOD)%SXY_zs + SYY_zs => WDATAS(IMOD)%SYY_zs +#endif BERG => WDATAS(IMOD)%BERG ICEH => WDATAS(IMOD)%ICEH ICEF => WDATAS(IMOD)%ICEF @@ -737,7 +887,9 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) ' IMOD = ',I10/ & ' NWDATA = ',I10/) ! -!/T 9000 FORMAT (' TEST W3SETW : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST W3SETW : MODEL ',I4,' SELECTED') +#endif !/ !/ End of W3SETW ----------------------------------------------------- / !/ diff --git a/model/ftn/wmesmfmd.ftn b/model/src/wmesmfmd.F90 similarity index 93% rename from model/ftn/wmesmfmd.ftn rename to model/src/wmesmfmd.F90 index 8e7721e18..2fbdd91d8 100644 --- a/model/ftn/wmesmfmd.ftn +++ b/model/src/wmesmfmd.F90 @@ -159,8 +159,12 @@ module WMESMFMD use W3TIMEMD use WMUPDTMD, only: WMUPD2 use W3UPDTMD, only: W3UINI -!/ST3 use W3SRC3MD, only: W3SPR3 -!/ST4 use W3SRC4MD, only: W3SPR4 +#ifdef W3_ST3 + use W3SRC3MD, only: W3SPR3 +#endif +#ifdef W3_ST4 + use W3SRC4MD, only: W3SPR4 +#endif use W3IOGOMD, only: W3OUTG use WMSCRPMD, only: get_scrip_info_structured !/ @@ -170,7 +174,9 @@ module WMESMFMD !/ !/ Include MPI definitions !/ -!/MPI include "mpif.h" +#ifdef W3_MPI + include "mpif.h" +#endif !/ !/ Specify default accessibility !/ @@ -2323,7 +2329,9 @@ subroutine GetImport ( gcomp, rc ) !/ ------------------------------------------------------------------- / !/ Parameter list !/ -!/MPI USE WMMDATMD, ONLY: IMPROC +#ifdef W3_MPI + USE WMMDATMD, ONLY: IMPROC +#endif implicit none type(ESMF_GridComp) :: gcomp integer,intent(out) :: rc @@ -2418,7 +2426,9 @@ subroutine GetImport ( gcomp, rc ) call w3seti ( imod, mdse, mdst ) call w3seto ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) -!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif jmod = inpmap(imod,j) if ( jmod.lt.0 .and. jmod.ne.-999 ) then call wmupd2( imod, j, jmod, rc ) @@ -2467,7 +2477,9 @@ subroutine GetImport ( gcomp, rc ) call w3setw ( imod, mdse, mdst ) call w3seti ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) -!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif jmod = inpmap(imod,j) if ( jmod.lt.0 .and. jmod.ne.-999 ) then call wmupd2( imod, j, jmod, rc ) @@ -2529,50 +2541,58 @@ subroutine GetImport ( gcomp, rc ) tw0 = twn wx0 = wxn wy0 = wyn -!/WRST ! The WRST switch saves the values of wind in the -!/WRST ! restart file and then uses the wind for the first -!/WRST ! time step here. This is needed when coupling with -!/WRST ! an atm model that does not have 10m wind speeds at -!/WRST ! initialization. If there is no restart, wind is zero -!/WRST wxn = WXNwrst !replace with values from restart -!/WRST wyn = WYNwrst -!/WRST wx0 = WXNwrst -!/WRST wy0 = WYNwrst -!/WRST do imod = 1,nrgrd -!/WRST call w3setg ( imod, mdse, mdst ) -!/WRST call w3setw ( imod, mdse, mdst ) -!/WRST call w3seti ( imod, mdse, mdst ) -!/WRST call wmsetm ( imod, mdse, mdst ) -!/WRST if ( mpi_comm_grd .eq. mpi_comm_null ) cycle -!/WRST INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:) -!/WRST INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) -!/WRST wxn = WXNwrst !replace with values from restart -!/WRST wyn = WYNwrst -!/WRST wx0 = WXNwrst -!/WRST wy0 = WYNwrst -!/WRST if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/WRST enddo +#ifdef W3_WRST + ! The WRST switch saves the values of wind in the + ! restart file and then uses the wind for the first + ! time step here. This is needed when coupling with + ! an atm model that does not have 10m wind speeds at + ! initialization. If there is no restart, wind is zero + wxn = WXNwrst !replace with values from restart + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst + do imod = 1,nrgrd + call w3setg ( imod, mdse, mdst ) + call w3setw ( imod, mdse, mdst ) + call w3seti ( imod, mdse, mdst ) + call wmsetm ( imod, mdse, mdst ) + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle + INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:) + INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) + wxn = WXNwrst !replace with values from restart + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst + if (ESMF_LogFoundError(rc, PASSTHRU)) return + enddo +#endif endif -!/WRST if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then -!/WRST !If the time of the field is still initial time, replace -!/WRST !with restart field -!/WRST wxn = WXNwrst !replace with values from restart -!/WRST wyn = WYNwrst -!/WRST else !twn>tw0 +#ifdef W3_WRST + if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then + !If the time of the field is still initial time, replace + !with restart field + wxn = WXNwrst !replace with values from restart + wyn = WYNwrst + else !twn>tw0 +#endif do imod = 1,nrgrd call w3setg ( imod, mdse, mdst ) call w3setw ( imod, mdse, mdst ) call w3seti ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) -!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif jmod = inpmap(imod,j) if ( jmod.lt.0 .and. jmod.ne.-999 ) then call wmupd2( imod, j, jmod, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return endif enddo -!/WRST endif !if ( twn-tw0 .le. 0 ) +#ifdef W3_WRST + endif !if ( twn-tw0 .le. 0 ) +#endif endif ! ! -------------------------------------------------------------------- / @@ -2602,7 +2622,9 @@ subroutine GetImport ( gcomp, rc ) call w3setw ( imod, mdse, mdst ) call w3seti ( imod, mdse, mdst ) call wmsetm ( imod, mdse, mdst ) -!/MPI if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#ifdef W3_MPI + if ( mpi_comm_grd .eq. mpi_comm_null ) cycle +#endif jmod = inpmap(imod,j) if ( jmod.lt.0 .and. jmod.ne.-999 ) then call wmupd2( imod, j, jmod, rc ) @@ -3710,8 +3732,12 @@ subroutine CreateExpGrid ( gcomp, rc ) ! list local native grid non-excluded points if ( natGridIsLocal ) then do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif arbIndexCount = arbIndexCount+1 if (ipass.eq.2) then ix = mapsf(isea,1) @@ -3962,8 +3988,10 @@ subroutine CreateImpMesh ( gcomp, rc ) ! !/ ------------------------------------------------------------------- / !/ -!/PDLIB use yowNodepool, only: npa, iplg, nodes_global -!/PDLIB use yowElementpool, only: ne, ielg, INE +#ifdef W3_PDLIB + use yowNodepool, only: npa, iplg, nodes_global + use yowElementpool, only: ne, ielg, INE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -4035,29 +4063,33 @@ subroutine CreateImpMesh ( gcomp, rc ) ! 2.a Create ESMF import mesh ! ! Allocate and fill the node id array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeIds(NX)) do i = 1,NX nodeIds(i)=i enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: The global id's of the nodes resident on this processor -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! Allocate global node ids, including ghost nodes (npa=np+ng) -!/PDLIB allocate(nodeIds(npa)) -!/PDLIB do i = 1,npa -!/PDLIB nodeIds(i)=iplg(i) -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,npa -!/PDLIB! write(msg,*) trim(cname)//': nodeIds(i)',i, & -!/PDLIB! ' ',nodeIds(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: The global id's of the nodes resident on this processor +! ------------------------------------------------------------------- +! Allocate global node ids, including ghost nodes (npa=np+ng) + allocate(nodeIds(npa)) + do i = 1,npa + nodeIds(i)=iplg(i) + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & +! ESMF_LOGMSG_INFO) +! do i = 1,npa +! write(msg,*) trim(cname)//': nodeIds(i)',i, & +! ' ',nodeIds(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeIds=', & ! ESMF_LOGMSG_INFO) @@ -4070,7 +4102,9 @@ subroutine CreateImpMesh ( gcomp, rc ) ! Allocate and fill node coordinate array. ! Since this is a 2D Mesh the size is 2x the ! number of nodes. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeCoords(2*NX)) do i = 1,NX do j = 1,2 @@ -4078,26 +4112,28 @@ subroutine CreateImpMesh ( gcomp, rc ) nodeCoords(pos)=XYB(i,j) enddo enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Physical coordinates of the nodes -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(nodeCoords(2*npa)) -!/PDLIB do i = 1,npa -!/PDLIB do j = 1,2 -!/PDLIB pos=2*(i-1)+j -!/PDLIB nodeCoords(pos)=XYB(iplg(i),j) -!/PDLIB enddo -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,(2*npa) -!/PDLIB! write(msg,*) trim(cname)//': nodeCoords(i)',i, & -!/PDLIB! ' ',nodeCoords(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Physical coordinates of the nodes +! ------------------------------------------------------------------- + allocate(nodeCoords(2*npa)) + do i = 1,npa + do j = 1,2 + pos=2*(i-1)+j + nodeCoords(pos)=XYB(iplg(i),j) + enddo + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & +! ESMF_LOGMSG_INFO) +! do i = 1,(2*npa) +! write(msg,*) trim(cname)//': nodeCoords(i)',i, & +! ' ',nodeCoords(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeCoords=', & ! ESMF_LOGMSG_INFO) @@ -4109,24 +4145,28 @@ subroutine CreateImpMesh ( gcomp, rc ) ! Allocate and fill the node owner array. ! Since this mesh is all on PET 0, it’s just set to all 0. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeOwners(NX)) nodeOwners=0 ! everything on PET 0 -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Processor that owns the node -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(nodeOwners(npa)) -!/PDLIB nodeOwners=nodes_global(iplg(1:npa))%domainID-1 -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,npa -!/PDLIB! write(msg,*) trim(cname)//': nodeOwners(i)',i, & -!/PDLIB! ' ',nodeOwners(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Processor that owns the node +! ------------------------------------------------------------------- + allocate(nodeOwners(npa)) + nodeOwners=nodes_global(iplg(1:npa))%domainID-1 + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & +! ESMF_LOGMSG_INFO) +! do i = 1,npa +! write(msg,*) trim(cname)//': nodeOwners(i)',i, & +! ' ',nodeOwners(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, nodeOwners=', & ! ESMF_LOGMSG_INFO) @@ -4137,28 +4177,32 @@ subroutine CreateImpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element id array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemIds(NTRI)) do i = 1,NTRI elemIds(i)=i enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: The global id's of the elements resident on this processor -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(elemIds(ne)) -!/PDLIB do i = 1,ne -!/PDLIB elemIds(i)=ielg(i) -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,ne -!/PDLIB! write(msg,*) trim(cname)//': elemIds(i)',i, & -!/PDLIB! ' ',elemIds(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: The global id's of the elements resident on this processor +! ------------------------------------------------------------------- + allocate(elemIds(ne)) + do i = 1,ne + elemIds(i)=ielg(i) + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & +! ESMF_LOGMSG_INFO) +! do i = 1,ne +! write(msg,*) trim(cname)//': elemIds(i)',i, & +! ' ',elemIds(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemIds=', & ! ESMF_LOGMSG_INFO) @@ -4169,28 +4213,32 @@ subroutine CreateImpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element topology type array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemTypes(NTRI)) do i = 1,NTRI elemTypes(i)=ESMF_MESHELEMTYPE_TRI enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(elemTypes(ne)) -!/PDLIB do i = 1,ne -!/PDLIB elemTypes(i)=ESMF_MESHELEMTYPE_TRI -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,ne -!/PDLIB! write(msg,*) trim(cname)//': elemTypes(i)',i, & -!/PDLIB! ' ',elemTypes(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) +! ------------------------------------------------------------------- + allocate(elemTypes(ne)) + do i = 1,ne + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & +! ESMF_LOGMSG_INFO) +! do i = 1,ne +! write(msg,*) trim(cname)//': elemTypes(i)',i, & +! ' ',elemTypes(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpM, elemTypes=', & ! ESMF_LOGMSG_INFO) @@ -4201,7 +4249,9 @@ subroutine CreateImpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element connection type array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemConn(3*NTRI)) do i = 1,NTRI do j = 1,3 @@ -4209,32 +4259,34 @@ subroutine CreateImpMesh ( gcomp, rc ) elemConn(pos)=TRIGP(i,j) enddo enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Connectivity table. The number of entries should -!/PDLIB! be equal to the number of nodes in the given topology. The indices -!/PDLIB! should be the local index (1 based) into the array of nodes that -!/PDLIB! was declared with MeshAddNodes. -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! > INE is local element array. it stores the local node IDs -!/PDLIB! > first index from 1 to 3. -!/PDLIB! > second index from 1 to ne. -!/PDLIB allocate(elemConn(3*ne)) -!/PDLIB do i = 1,ne -!/PDLIB do j = 1,3 -!/PDLIB pos=3*(i-1)+j -!/PDLIB elemConn(pos)=INE(j,i) -!/PDLIB enddo -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,(3*ne) -!/PDLIB! write(msg,*) trim(cname)//': elemConn(i)',i, & -!/PDLIB! ' ',elemConn(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Connectivity table. The number of entries should +! be equal to the number of nodes in the given topology. The indices +! should be the local index (1 based) into the array of nodes that +! was declared with MeshAddNodes. +! ------------------------------------------------------------------- +! > INE is local element array. it stores the local node IDs +! > first index from 1 to 3. +! > second index from 1 to ne. + allocate(elemConn(3*ne)) + do i = 1,ne + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=INE(j,i) + enddo + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & +! ESMF_LOGMSG_INFO) +! do i = 1,(3*ne) +! write(msg,*) trim(cname)//': elemConn(i)',i, & +! ' ',elemConn(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateImpMesh, elemConn=', & ! ESMF_LOGMSG_INFO) @@ -4332,8 +4384,10 @@ subroutine CreateExpMesh ( gcomp, rc ) ! !/ ------------------------------------------------------------------- / !/ -!/PDLIB use yowNodepool, only: npa, iplg, nodes_global -!/PDLIB use yowElementpool, only: ne, ielg, INE +#ifdef W3_PDLIB + use yowNodepool, only: npa, iplg, nodes_global + use yowElementpool, only: ne, ielg, INE +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -4411,29 +4465,33 @@ subroutine CreateExpMesh ( gcomp, rc ) ! 2.a Create ESMF export mesh ! ! Allocate and fill the node id array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeIds(NX)) do i = 1,NX nodeIds(i)=i enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: The global id's of the nodes resident on this processor -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! Allocate global node ids, including ghost nodes (npa=np+ng) -!/PDLIB allocate(nodeIds(npa)) -!/PDLIB do i = 1,npa -!/PDLIB nodeIds(i)=iplg(i) -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,npa -!/PDLIB! write(msg,*) trim(cname)//': nodeIds(i)',i, & -!/PDLIB! ' ',nodeIds(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: The global id's of the nodes resident on this processor +! ------------------------------------------------------------------- +! Allocate global node ids, including ghost nodes (npa=np+ng) + allocate(nodeIds(npa)) + do i = 1,npa + nodeIds(i)=iplg(i) + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & +! ESMF_LOGMSG_INFO) +! do i = 1,npa +! write(msg,*) trim(cname)//': nodeIds(i)',i, & +! ' ',nodeIds(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeIds=', & ! ESMF_LOGMSG_INFO) @@ -4446,7 +4504,9 @@ subroutine CreateExpMesh ( gcomp, rc ) ! Allocate and fill node coordinate array. ! Since this is a 2D Mesh the size is 2x the ! number of nodes. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeCoords(2*NX)) do i = 1,NX do j = 1,2 @@ -4454,26 +4514,28 @@ subroutine CreateExpMesh ( gcomp, rc ) nodeCoords(pos)=XYB(i,j) enddo enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Physical coordinates of the nodes -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(nodeCoords(2*npa)) -!/PDLIB do i = 1,npa -!/PDLIB do j = 1,2 -!/PDLIB pos=2*(i-1)+j -!/PDLIB nodeCoords(pos)=XYB(iplg(i),j) -!/PDLIB enddo -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,(2*npa) -!/PDLIB! write(msg,*) trim(cname)//': nodeCoords(i)',i, & -!/PDLIB! ' ',nodeCoords(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Physical coordinates of the nodes +! ------------------------------------------------------------------- + allocate(nodeCoords(2*npa)) + do i = 1,npa + do j = 1,2 + pos=2*(i-1)+j + nodeCoords(pos)=XYB(iplg(i),j) + enddo + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & +! ESMF_LOGMSG_INFO) +! do i = 1,(2*npa) +! write(msg,*) trim(cname)//': nodeCoords(i)',i, & +! ' ',nodeCoords(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeCoords=', & ! ESMF_LOGMSG_INFO) @@ -4484,24 +4546,28 @@ subroutine CreateExpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the node owner array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(nodeOwners(NX)) nodeOwners=0 ! TODO: For now, export everything via PET 0 -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Processor that owns the node -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(nodeOwners(npa)) -!/PDLIB nodeOwners=nodes_global(iplg(1:npa))%domainID-1 -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,npa -!/PDLIB! write(msg,*) trim(cname)//': nodeOwners(i)',i, & -!/PDLIB! ' ',nodeOwners(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Processor that owns the node +! ------------------------------------------------------------------- + allocate(nodeOwners(npa)) + nodeOwners=nodes_global(iplg(1:npa))%domainID-1 + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & +! ESMF_LOGMSG_INFO) +! do i = 1,npa +! write(msg,*) trim(cname)//': nodeOwners(i)',i, & +! ' ',nodeOwners(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, nodeOwners=', & ! ESMF_LOGMSG_INFO) @@ -4512,28 +4578,32 @@ subroutine CreateExpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element id array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemIds(NTRI)) do i = 1,NTRI elemIds(i)=i enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: The global id's of the elements resident on this processor -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(elemIds(ne)) -!/PDLIB do i = 1,ne -!/PDLIB elemIds(i)=ielg(i) -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,ne -!/PDLIB! write(msg,*) trim(cname)//': elemIds(i)',i, & -!/PDLIB! ' ',elemIds(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: The global id's of the elements resident on this processor +! ------------------------------------------------------------------- + allocate(elemIds(ne)) + do i = 1,ne + elemIds(i)=ielg(i) + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & +! ESMF_LOGMSG_INFO) +! do i = 1,ne +! write(msg,*) trim(cname)//': elemIds(i)',i, & +! ' ',elemIds(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemIds=', & ! ESMF_LOGMSG_INFO) @@ -4544,28 +4614,32 @@ subroutine CreateExpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element topology type array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemTypes(NTRI)) do i = 1,NTRI elemTypes(i)=ESMF_MESHELEMTYPE_TRI enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB allocate(elemTypes(ne)) -!/PDLIB do i = 1,ne -!/PDLIB elemTypes(i)=ESMF_MESHELEMTYPE_TRI -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,ne -!/PDLIB! write(msg,*) trim(cname)//': elemTypes(i)',i, & -!/PDLIB! ' ',elemTypes(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Topology of the given element (one of ESMF_MeshElement) +! ------------------------------------------------------------------- + allocate(elemTypes(ne)) + do i = 1,ne + elemTypes(i)=ESMF_MESHELEMTYPE_TRI + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & +! ESMF_LOGMSG_INFO) +! do i = 1,ne +! write(msg,*) trim(cname)//': elemTypes(i)',i, & +! ' ',elemTypes(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemTypes=', & ! ESMF_LOGMSG_INFO) @@ -4576,7 +4650,9 @@ subroutine CreateExpMesh ( gcomp, rc ) ! enddo ! Allocate and fill the element connection type array. -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif allocate(elemConn(3*NTRI)) do i = 1,NTRI do j = 1,3 @@ -4584,32 +4660,34 @@ subroutine CreateExpMesh ( gcomp, rc ) elemConn(pos)=TRIGP(i,j) enddo enddo -!/PDLIB else -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! ESMF Definition: Connectivity table. The number of entries should -!/PDLIB! be equal to the number of nodes in the given topology. The indices -!/PDLIB! should be the local index (1 based) into the array of nodes that -!/PDLIB! was declared with MeshAddNodes. -!/PDLIB! ------------------------------------------------------------------- -!/PDLIB! > INE is local element array. it stores the local node IDs -!/PDLIB! > first index from 1 to 3. -!/PDLIB! > second index from 1 to ne. -!/PDLIB allocate(elemConn(3*ne)) -!/PDLIB do i = 1,ne -!/PDLIB do j = 1,3 -!/PDLIB pos=3*(i-1)+j -!/PDLIB elemConn(pos)=INE(j,i) -!/PDLIB enddo -!/PDLIB enddo -!/PDLIB endif -!/PDLIB! -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do i = 1,(3*ne) -!/PDLIB! write(msg,*) trim(cname)//': elemConn(i)',i, & -!/PDLIB! ' ',elemConn(i) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else +! ------------------------------------------------------------------- +! ESMF Definition: Connectivity table. The number of entries should +! be equal to the number of nodes in the given topology. The indices +! should be the local index (1 based) into the array of nodes that +! was declared with MeshAddNodes. +! ------------------------------------------------------------------- +! > INE is local element array. it stores the local node IDs +! > first index from 1 to 3. +! > second index from 1 to ne. + allocate(elemConn(3*ne)) + do i = 1,ne + do j = 1,3 + pos=3*(i-1)+j + elemConn(pos)=INE(j,i) + enddo + enddo + endif +! +! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & +! ESMF_LOGMSG_INFO) +! do i = 1,(3*ne) +! write(msg,*) trim(cname)//': elemConn(i)',i, & +! ' ',elemConn(i) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif ! call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, elemConn=', & ! ESMF_LOGMSG_INFO) @@ -4653,7 +4731,9 @@ subroutine CreateExpMesh ( gcomp, rc ) ! natGridIsLocal = iaproc .gt. 0 .and. iaproc .le. naproc -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif ! ! 3.b Setup arbitrary sequence index list ! @@ -4666,8 +4746,12 @@ subroutine CreateExpMesh ( gcomp, rc ) ! list local native grid non-excluded points if ( natGridIsLocal ) then do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif arbIndexCount = arbIndexCount+1 if (ipass.eq.2) then ix = mapsf(isea,1) @@ -4723,7 +4807,9 @@ subroutine CreateExpMesh ( gcomp, rc ) call ESMF_FieldDestroy( eField, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB endif +#ifdef W3_PDLIB + endif +#endif call ESMF_LogWrite(trim(cname)//': In CreateExpMesh, created expMesh', & ESMF_LOGMSG_INFO) @@ -5358,8 +5444,10 @@ subroutine FieldGather(field, n1, n2, fout, rc) ! !/ ------------------------------------------------------------------- / !/ -!/PDLIB use yowNodepool, only: np, iplg -!/PDLIB use yowrankModule, only: rank +#ifdef W3_PDLIB + use yowNodepool, only: np, iplg + use yowrankModule, only: rank +#endif !/ implicit none !/ ------------------------------------------------------------------- / @@ -5378,7 +5466,9 @@ subroutine FieldGather(field, n1, n2, fout, rc) integer :: i, j, k, ir, ip, count real(ESMF_KIND_RX) :: floc(n1,n2) real(ESMF_KIND_RX) :: floc1d(n1), floc1dary(n1*n2) -!/PDLIB real(ESMF_KIND_R8), pointer :: fldptr(:) +#ifdef W3_PDLIB + real(ESMF_KIND_R8), pointer :: fldptr(:) +#endif integer, parameter :: iwt=9 real(8) :: wstime, wftime ! @@ -5414,30 +5504,36 @@ subroutine FieldGather(field, n1, n2, fout, rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_VMbroadcast( vm, bcstData=floc1d, count=count, rootPet=0, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif do k = 1, n1 fout(k,1) = floc1d(k) enddo -!/PDLIB else -!/PDLIB count = 0 -!/PDLIB do ir = 1, npet -!/PDLIB do ip = 1, rank(ir)%np -!/PDLIB count = count+1 -!/PDLIB fout(rank(ir)%iplg(ip),1) = floc1d(count) -!/PDLIB! write(msg,*) trim(cname)//': count,ir,ip =',count, & -!/PDLIB! ir,ip -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB enddo -!/PDLIB enddo -!/PDLIB endif - -!/PDLIB! call ESMF_LogWrite(trim(cname)//': In FieldGather, fout(k,1)=', & -!/PDLIB! ESMF_LOGMSG_INFO) -!/PDLIB! do k = 1, n1 -!/PDLIB! write(msg,*) trim(cname)//': fout(k,1) =',k, & -!/PDLIB! ' ',fout(k,1) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB! enddo +#ifdef W3_PDLIB + else + count = 0 + do ir = 1, npet + do ip = 1, rank(ir)%np + count = count+1 + fout(rank(ir)%iplg(ip),1) = floc1d(count) +! write(msg,*) trim(cname)//': count,ir,ip =',count, & +! ir,ip +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + enddo + enddo + endif +#endif + +#ifdef W3_PDLIB +! call ESMF_LogWrite(trim(cname)//': In FieldGather, fout(k,1)=', & +! ESMF_LOGMSG_INFO) +! do k = 1, n1 +! write(msg,*) trim(cname)//': fout(k,1) =',k, & +! ' ',fout(k,1) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) +! enddo +#endif endif @@ -6032,25 +6128,33 @@ subroutine CalcCharnk ( chkField, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif if ( firstCall ) then charn(jsea) = zero -!/ST3 llws(:) = .true. -!/ST3 ustar = zero -!/ST3 ustdr = zero -!/ST3 call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & -!/ST3 emean, fmean, fmean1, wnmean, amax, & -!/ST3 u10(isea), u10d(isea), ustar, ustdr, tauwx, & -!/ST3 tauwy, cd, z0, charn(jsea), llws, fmeanws ) -!/ST4 llws(:) = .true. -!/ST4 ustar = zero -!/ST4 ustdr = zero -!/ST4 call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & -!/ST4 emean, fmean, fmean1, wnmean, amax, & -!/ST4 u10(isea), u10d(isea), ustar, ustdr, tauwx, & -!/ST4 tauwy, cd, z0, charn(jsea), llws, fmeanws, & -!/ST4 dlwmean ) +#ifdef W3_ST3 + llws(:) = .true. + ustar = zero + ustdr = zero + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) +#endif +#ifdef W3_ST4 + llws(:) = .true. + ustar = zero + ustdr = zero + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) +#endif endif !firstCall chkn(jsea) = charn(jsea) enddo jsea_loop @@ -6161,28 +6265,36 @@ subroutine CalcRoughl ( wrlField, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN if ( firstCall ) then charn(jsea) = zero -!/ST3 llws(:) = .true. -!/ST3 ustar = zero -!/ST3 ustdr = zero -!/ST3 call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & -!/ST3 emean, fmean, fmean1, wnmean, amax, & -!/ST3 u10(isea), u10d(isea), ustar, ustdr, tauwx, & -!/ST3 tauwy, cd, z0, charn(jsea), llws, fmeanws ) -!/ST4 llws(:) = .true. -!/ST4 ustar = zero -!/ST4 ustdr = zero -!/ST4 call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & -!/ST4 emean, fmean, fmean1, wnmean, amax, & -!/ST4 u10(isea), u10d(isea), ustar, ustdr, tauwx, & -!/ST4 tauwy, cd, z0, charn(jsea), llws, fmeanws, & -!/ST4 dlwmean ) +#ifdef W3_ST3 + llws(:) = .true. + ustar = zero + ustdr = zero + call w3spr3( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws ) +#endif +#ifdef W3_ST4 + llws(:) = .true. + ustar = zero + ustdr = zero + call w3spr4( va(:,jsea), cg(1:nk,isea), wn(1:nk,isea), & + emean, fmean, fmean1, wnmean, amax, & + u10(isea), u10d(isea), ustar, ustdr, tauwx, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & + dlwmean ) +#endif endif !firstCall wrln(jsea) = charn(jsea)*ust(isea)**2/grav endif @@ -6352,8 +6464,12 @@ subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc ) sig2(1:nk) = sig(1:nk)**2 jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif if ( dw(isea).le.zero ) cycle jsea_loop depth = max(dmin,dw(isea)) #ifdef USE_W3OUTG_FOR_EXPORT @@ -6500,7 +6616,9 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) ! !/ ------------------------------------------------------------------- / !/ -!/PDLIB use yowNodepool, only: np, iplg +#ifdef W3_PDLIB + use yowNodepool, only: np, iplg +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -6545,7 +6663,9 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) staggerLoc=natStaggerLoc, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return elseif (GTYPE.eq.UNGTYPE) then -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif sxxnField = ESMF_FieldCreate( natGrid, natArraySpec1D, & staggerLoc=natStaggerLoc, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -6555,43 +6675,59 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) syynField = ESMF_FieldCreate( natGrid, natArraySpec1D, & staggerLoc=natStaggerLoc, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB endif +#ifdef W3_PDLIB + endif +#endif endif -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif call FieldFill( sxxnField, zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call FieldFill( sxynField, zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call FieldFill( syynField, zeroValue, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB endif +#ifdef W3_PDLIB + endif +#endif if ( natGridIsLocal ) then -!/PDLIB if ( LPDLIB == .FALSE. ) then -!/PDLIB! Use auxiliary native grid/mesh to populate and redistribute data +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +! Use auxiliary native grid/mesh to populate and redistribute data +#endif call ESMF_FieldGet( sxxnField, farrayPtr=sxxn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldGet( sxynField, farrayPtr=sxyn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldGet( syynField, farrayPtr=syyn, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB else -!/PDLIB! Use single domain-decomposed native mesh to populate and communicate data -!/PDLIB call ESMF_FieldGet( sxxField, farrayPtr=sxxn, rc=rc ) -!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB call ESMF_FieldGet( sxyField, farrayPtr=sxyn, rc=rc ) -!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB call ESMF_FieldGet( syyField, farrayPtr=syyn, rc=rc ) -!/PDLIB if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB endif +#ifdef W3_PDLIB + else +! Use single domain-decomposed native mesh to populate and communicate data + call ESMF_FieldGet( sxxField, farrayPtr=sxxn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( sxyField, farrayPtr=sxyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + call ESMF_FieldGet( syyField, farrayPtr=syyn, rc=rc ) + if (ESMF_LogFoundError(rc, PASSTHRU)) return + endif +#endif facd = dwat*grav -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif if ( dw(isea).le.zero ) cycle jsea_loop #ifdef USE_W3OUTG_FOR_EXPORT sxxn(jsea) = sxx(jsea) @@ -6623,21 +6759,25 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) syyn(jsea) = syys*facs #endif enddo jsea_loop -!/PDLIB else -!/PDLIB jsea_loop2: do jsea = 1,np -!/PDLIB isea = iplg(jsea) -!/PDLIB! if ( dw(isea).le.zero ) cycle jsea_loop -!/PDLIB sxxn(jsea) = sxx(jsea) -!/PDLIB sxyn(jsea) = sxy(jsea) -!/PDLIB syyn(jsea) = syy(jsea) -!/PDLIB! write(msg,*) trim(cname)//' sxxn', sxxn(jsea) -!/PDLIB! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) -!/PDLIB enddo jsea_loop2 -!/PDLIB endif +#ifdef W3_PDLIB + else + jsea_loop2: do jsea = 1,np + isea = iplg(jsea) +! if ( dw(isea).le.zero ) cycle jsea_loop + sxxn(jsea) = sxx(jsea) + sxyn(jsea) = sxy(jsea) + syyn(jsea) = syy(jsea) +! write(msg,*) trim(cname)//' sxxn', sxxn(jsea) +! call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO) + enddo jsea_loop2 + endif +#endif endif !natGridIsLocal -!/PDLIB if ( LPDLIB == .FALSE. ) then +#ifdef W3_PDLIB + if ( LPDLIB == .FALSE. ) then +#endif call ESMF_FieldRedist( sxxnField, sxxField, n2eRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldRedist( sxynField, sxyField, n2eRH, rc=rc ) @@ -6651,7 +6791,9 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldDestroy( syynField, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return -!/PDLIB endif +#ifdef W3_PDLIB + endif +#endif #ifdef TEST_WMESMFMD_RADSTR2D call ESMF_FieldWrite( sxxField, "wmesmfmd_radstr2d_sxx.nc", & @@ -6826,8 +6968,12 @@ subroutine CalcStokes3D ( a, usxField, usyField, rc ) fack(1:nk) = dden(1:nk) * sig(1:nk) jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif if ( dw(isea).le.zero ) cycle jsea_loop depth = max(dmin,dw(isea)) uzx(:) = zero @@ -7045,8 +7191,12 @@ subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & call CALC_U3STOKES ( a , 2 ) jsea_loop: do jsea = 1,nseal -!/DIST isea = iaproc + (jsea-1)*naproc -!/SHRD isea = jsea +#ifdef W3_DIST + isea = iaproc + (jsea-1)*naproc +#endif +#ifdef W3_SHRD + isea = jsea +#endif p1xn(jsea)=ussp(jsea,1) p1yn(jsea)=ussp(jsea,nk+1) diff --git a/model/ftn/wmfinlmd.ftn b/model/src/wmfinlmd.F90 similarity index 83% rename from model/ftn/wmfinlmd.ftn rename to model/src/wmfinlmd.F90 index f4052388d..10dea1dc2 100644 --- a/model/ftn/wmfinlmd.ftn +++ b/model/src/wmfinlmd.F90 @@ -118,20 +118,32 @@ SUBROUTINE WMFINL ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/MPRF/! use w3getmem ; fake use statement for make_makefile.sh -!/MPRF/! +#ifdef W3_MPRF +! use w3getmem ; fake use statement for make_makefile.sh +! +#endif USE W3TIMEMD, ONLY: TDIFF USE WMMDATMD, ONLY: MDSS, MDSO, NMPSCR, NMPLOG, IMPROC USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKDT3, CLKFIN -!/MPRF USE WMMDATMD, ONLY: MDSP -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE -!/ -!/S USE W3SERVMD, ONLY: STRACE -!/MPRF USE W3TIMEMD, ONLY: PRTIME +#ifdef W3_MPRF + USE WMMDATMD, ONLY: MDSP +#endif +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE +#endif +!/ +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPRF + USE W3TIMEMD, ONLY: PRTIME +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -139,23 +151,37 @@ SUBROUTINE WMFINL !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/MPI INTEGER :: IERR_MPI -!/MPRF REAL :: PRFT0, PRFTN -!/MPRF REAL(KIND=8) :: get_memory -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_MPRF + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / ! 1. Identification at start ! -!/S CALL STRACE (IENT, 'WMFINL') -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_S + CALL STRACE (IENT, 'WMFINL') +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif ! !/ ------------------------------------------------------------------- / ! 2. Finalization ! -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & WRITE (MDSS,920) CLKFIN @@ -171,10 +197,14 @@ SUBROUTINE WMFINL !/ ------------------------------------------------------------------- / ! 3. Identification at end ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory() +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory() +#endif ! RETURN ! @@ -186,7 +216,9 @@ SUBROUTINE WMFINL 921 FORMAT ( ' Elapsed time :',F10.2,' s') ! -!/MPRF 990 FORMAT (1X,3F12.3,' WMFINL') +#ifdef W3_MPRF + 990 FORMAT (1X,3F12.3,' WMFINL') +#endif ! 999 FORMAT (/' ========== END OF MWW3 INITIALIZATION (WMFINL) ===', & '============================'/) diff --git a/model/ftn/wmgridmd.ftn b/model/src/wmgridmd.F90 similarity index 76% rename from model/ftn/wmgridmd.ftn rename to model/src/wmgridmd.F90 index 0c89195d1..130b3d455 100644 --- a/model/ftn/wmgridmd.ftn +++ b/model/src/wmgridmd.F90 @@ -206,7 +206,9 @@ SUBROUTINE WMGLOW ( FLRBPI ) !/ ------------------------------------------------------------------- / ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD USE W3ODATMD @@ -216,7 +218,9 @@ SUBROUTINE WMGLOW ( FLRBPI ) ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -228,10 +232,16 @@ SUBROUTINE WMGLOW ( FLRBPI ) !/ INTEGER :: I, IBI, IX, IY, JS, J, & JTOT, I1, J1, I2, J2 -!/MPI INTEGER :: NXYG, IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: NXYG, IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: TSTORE(:,:) -!/MPI LOGICAL :: FLBARR +#ifdef W3_MPI + LOGICAL :: FLBARR +#endif REAL :: XA, YA REAL :: FACTOR LOGICAL :: GRIDD(NRGRD,NRGRD) ! indicates grid-to-grid @@ -253,14 +263,20 @@ SUBROUTINE WMGLOW ( FLRBPI ) REAL :: DIST_MIN, DIST_MAX, EDIST LOGICAL RESOL_CHECK ! -!/T9 CHARACTER(LEN=1), ALLOCATABLE :: TMAP(:,:) +#ifdef W3_T9 + CHARACTER(LEN=1), ALLOCATABLE :: TMAP(:,:) +#endif !/ -!/S CALL STRACE (IENT, 'WMGLOW') +#ifdef W3_S + CALL STRACE (IENT, 'WMGLOW') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test grid, Initialize and synchronize grids as needed ( !/MPI ) ! -!/MPI FLBARR = .FALSE. +#ifdef W3_MPI + FLBARR = .FALSE. +#endif ! DO I=1, NRGRD ! @@ -272,38 +288,46 @@ SUBROUTINE WMGLOW ( FLRBPI ) CALL W3SETO ( I, MDSE, MDST ) CALL W3SETG ( I, MDSE, MDST ) ! -!/MPI FLBARR = FLBARR .OR. MDATAS(I)%FBCAST -!/MPI IF ( MDATAS(I)%FBCAST .AND. & -!/MPI MDATAS(I)%MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN -!/MPI NXYG = GRIDS(I)%NX * GRIDS(I)%NY -!/MPI CALL MPI_BCAST ( GRIDS(I)%MAPSTA(1,1), NXYG, & -!/MPI MPI_INTEGER, 0, & -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRIDS(I)%MAPST2(1,1), NXYG, & -!/MPI MPI_INTEGER, 0, & -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRIDS(I)%MAPFS (1,1), NXYG, & -!/MPI MPI_INTEGER, 0, & -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI NXYG = 3*GRIDS(I)%NSEA -!/MPI CALL MPI_BCAST ( GRIDS(I)%MAPSF (1,1), NXYG, & -!/MPI MPI_INTEGER, 0, & -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRIDS(I)%CLATIS(1), NSEA, MPI_REAL, 0,& -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( SGRDS(I)%SIG(0), NK+2, MPI_REAL, 0,& -!/MPI MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) -!/MPI END IF +#ifdef W3_MPI + FLBARR = FLBARR .OR. MDATAS(I)%FBCAST + IF ( MDATAS(I)%FBCAST .AND. & + MDATAS(I)%MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + NXYG = GRIDS(I)%NX * GRIDS(I)%NY + CALL MPI_BCAST ( GRIDS(I)%MAPSTA(1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%MAPST2(1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%MAPFS (1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + NXYG = 3*GRIDS(I)%NSEA + CALL MPI_BCAST ( GRIDS(I)%MAPSF (1,1), NXYG, & + MPI_INTEGER, 0, & + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDS(I)%CLATIS(1), NSEA, MPI_REAL, 0,& + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SGRDS(I)%SIG(0), NK+2, MPI_REAL, 0,& + MDATAS(I)%MPI_COMM_BCT, IERR_MPI ) + END IF +#endif ! END DO ! -!/MPI IF (FLBARR) CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + IF (FLBARR) CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! -!/SMC !! Check GTYPE for all grids. -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) " GTYPES in WMGLOW:", & -!/SMC ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#ifdef W3_SMC + !! Check GTYPE for all grids. + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) " GTYPES in WMGLOW:", & + ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#endif ! ! -------------------------------------------------------------------- / ! 2. Process grids @@ -323,16 +347,22 @@ SUBROUTINE WMGLOW ( FLRBPI ) END IF NBI2G = 0 ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! DO I=1, NRGRD ! -!/T WRITE (MDST,9021) I, GRANK(I), OUTPTS(I)%OUT5%NBI +#ifdef W3_T + WRITE (MDST,9021) I, GRANK(I), OUTPTS(I)%OUT5%NBI +#endif ! ! 2.a Test for input boundary points ! IF ( OUTPTS(I)%OUT5%NBI .EQ. 0 ) THEN -!/T WRITE (MDST,9022) 'NO INPUT BOUNDARY POINTS, SKIPPING' +#ifdef W3_T + WRITE (MDST,9022) 'NO INPUT BOUNDARY POINTS, SKIPPING' +#endif CYCLE END IF ! @@ -340,20 +370,26 @@ SUBROUTINE WMGLOW ( FLRBPI ) ! IF ( GRANK(I) .EQ. 1 ) THEN RFILE(I) = .TRUE. -!/T WRITE (MDST,9022) 'RANK = 1, DATA FROM FILE' +#ifdef W3_T + WRITE (MDST,9022) 'RANK = 1, DATA FROM FILE' +#endif CYCLE END IF ! -!/SMC !! SMC grid only appears in same ranked group. JGLi23Mar2021 -!/SMC IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) ' WMGLOW skip SMC grid', I -!/SMC CYCLE -!/SMC END IF +#ifdef W3_SMC + !! SMC grid only appears in same ranked group. JGLi23Mar2021 + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) ' WMGLOW skip SMC grid', I + CYCLE + END IF +#endif ! ! 2.c Search for input boundary points ! -!/T WRITE (MDST,9022) 'SEARCHING FOR ACTIVE BOUNDARY POINTS' +#ifdef W3_T + WRITE (MDST,9022) 'SEARCHING FOR ACTIVE BOUNDARY POINTS' +#endif IBI = 0 ! ! ... Set up data structure for grid @@ -383,12 +419,14 @@ SUBROUTINE WMGLOW ( FLRBPI ) ! IF ( GRANK(J) .GE. GRANK(I) ) CYCLE ! -!/SMC !! SMC grid only suppots same ranked group so far. JGLi12Apr2021 -!/SMC IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) & -!/SMC ' WMGLOW skip SMC grid', J -!/SMC CYCLE -!/SMC END IF +#ifdef W3_SMC + !! SMC grid only suppots same ranked group so far. JGLi12Apr2021 + IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) THEN + IF( IMPROC.EQ.NMPERR ) WRITE(MDSE,*) & + ' WMGLOW skip SMC grid', J + CYCLE + END IF +#endif ! ! ... Check if in grid ! @@ -452,13 +490,15 @@ SUBROUTINE WMGLOW ( FLRBPI ) ! ! ... if not in grid, warning message and cycle (search next grid) IF ( .NOT.INGRID ) THEN -!/T IF ( IAPROC .EQ. NAPERR ) THEN -!/T IF ( FLAGLL ) THEN -!/T WRITE (NDSE,2000) XA, YA -!/T ELSE -!/T WRITE (NDSE,2001) XA, YA -!/T END IF -!/T END IF +#ifdef W3_T + IF ( IAPROC .EQ. NAPERR ) THEN + IF ( FLAGLL ) THEN + WRITE (NDSE,2000) XA, YA + ELSE + WRITE (NDSE,2001) XA, YA + END IF + END IF +#endif CYCLE END IF @@ -617,60 +657,76 @@ SUBROUTINE WMGLOW ( FLRBPI ) ! ! 2.g Test output ! -!/T1 WRITE (MDST,9023) -!/T1 DO J=1, NBI -!/T1 WRITE (MDST,9024) J, ISBPI(J), FACTOR*XBPI(J), & -!/T1 FACTOR*YBPI(J), IPBPI(J,:), RDBPI(J,:), TSTORE(J,:) -!/T1 END DO -! -!/T2 WRITE (MDST,9025) -!/T2 DO J=1, NBI2 -!/T2 WRITE (MDST,9026) J, NBI2S(J,:) -!/T2 END DO -! -!/T9 ALLOCATE ( TMAP(NX,NY), STAT=ISTAT ) -!/T9 CHECK_ALLOC_STATUS ( ISTAT ) -! -!/T9 DO IX=1, NX -!/T9 DO IY=1, NY -!/T9 IF ( ABS(MAPSTA(IY,IX)) .EQ. 0 ) then -!/T9 TMAP(IX,IY) = '/' -!/T9 ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) then -!/T9 TMAP(IX,IY) = '-' -!/T9 ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) then -!/T9 TMAP(IX,IY) = 'X' -!/T9 END IF -!/T9 END DO -!/T9 END DO -! -!/T9 DO J=1, NBI -!/T9 IX = MAPSF(ISBPI(J),1) -!/T9 IY = MAPSF(ISBPI(J),2) -!/T9 WRITE (TMAP(IX,IY),'(I1)') TSTORE(J,0) -!/T9 END DO -! -!/T9 DO J=1, 1+(NX-1)/130 -!/T9 WRITE (MDST,9029) I, J -!/T9 DO IY=NY, 1, -1 -!/T9 I1 = J*130-129 -!/T9 I2 = MIN ( NX , J*130 ) -!/T9 WRITE (MDST,'(1X,130A1)') TMAP(I1:I2,IY) -!/T9 END DO -!/T9 END DO -! -!/T9 DEALLOCATE ( TMAP, STAT=ISTAT ) -!/T9 CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_T1 + WRITE (MDST,9023) + DO J=1, NBI + WRITE (MDST,9024) J, ISBPI(J), FACTOR*XBPI(J), & + FACTOR*YBPI(J), IPBPI(J,:), RDBPI(J,:), TSTORE(J,:) + END DO +#endif +! +#ifdef W3_T2 + WRITE (MDST,9025) + DO J=1, NBI2 + WRITE (MDST,9026) J, NBI2S(J,:) + END DO +#endif +! +#ifdef W3_T9 + ALLOCATE ( TMAP(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif +! +#ifdef W3_T9 + DO IX=1, NX + DO IY=1, NY + IF ( ABS(MAPSTA(IY,IX)) .EQ. 0 ) then + TMAP(IX,IY) = '/' + ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 1 ) then + TMAP(IX,IY) = '-' + ELSE IF ( ABS(MAPSTA(IY,IX)) .EQ. 2 ) then + TMAP(IX,IY) = 'X' + END IF + END DO + END DO +#endif +! +#ifdef W3_T9 + DO J=1, NBI + IX = MAPSF(ISBPI(J),1) + IY = MAPSF(ISBPI(J),2) + WRITE (TMAP(IX,IY),'(I1)') TSTORE(J,0) + END DO +#endif +! +#ifdef W3_T9 + DO J=1, 1+(NX-1)/130 + WRITE (MDST,9029) I, J + DO IY=NY, 1, -1 + I1 = J*130-129 + I2 = MIN ( NX , J*130 ) + WRITE (MDST,'(1X,130A1)') TMAP(I1:I2,IY) + END DO + END DO +#endif +! +#ifdef W3_T9 + DEALLOCATE ( TMAP, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif ! DEALLOCATE ( TSTORE, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) ! END DO ! -!/T WRITE (MDST,9027) -!/T DO I=1, NRGRD -!/T WRITE (MDST,9028) OUTPTS(I)%OUT5%NBI, OUTPTS(I)%OUT5%NBI2, & -!/T RFILE(I), NBI2G(I,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9027) + DO I=1, NRGRD + WRITE (MDST,9028) OUTPTS(I)%OUT5%NBI, OUTPTS(I)%OUT5%NBI2, & + RFILE(I), NBI2G(I,:) + END DO +#endif ! ! -------------------------------------------------------------------- / ! 3. Finalyze grid dependencies in GRDLOW @@ -699,7 +755,9 @@ SUBROUTINE WMGLOW ( FLRBPI ) CHECK_ALLOC_STATUS ( ISTAT ) GRDLOW = 0 ! -!/T WRITE (MDST,9030) JTOT +#ifdef W3_T + WRITE (MDST,9030) JTOT +#endif ! ! 3.b Fill array ! @@ -843,7 +901,9 @@ SUBROUTINE WMGLOW ( FLRBPI ) END IF RESOL_CHECK=.FALSE. -!/T38 RESOL_CHECK=.TRUE. +#ifdef W3_T38 + RESOL_CHECK=.TRUE. +#endif IF (RESOL_CHECK) THEN IF ( DX_MIN_GRIDJ .LT. 0.99*DX_MIN_GRIDI .OR. & DY_MIN_GRIDJ .LT. 0.99*DY_MIN_GRIDI .OR. & @@ -866,10 +926,12 @@ SUBROUTINE WMGLOW ( FLRBPI ) GRDLOW(I,0) = JTOT END DO ! DO I=... ! -!/T WRITE (MDST,9031) -!/T DO I=1, NRGRD -!/T WRITE (MDST,9032) I, GRDLOW(I,0:GRDLOW(I,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9031) + DO I=1, NRGRD + WRITE (MDST,9032) I, GRDLOW(I,0:GRDLOW(I,0)) + END DO +#endif ! IF ( .NOT. FLAGOK ) CALL EXTCDE ( 1030 ) ! @@ -894,7 +956,9 @@ SUBROUTINE WMGLOW ( FLRBPI ) CHECK_ALLOC_STATUS ( ISTAT ) GRDHGH = 0 ! -!/T WRITE (MDST,9040) JTOT +#ifdef W3_T + WRITE (MDST,9040) JTOT +#endif ! ! 4.b Fill array ! @@ -911,10 +975,12 @@ SUBROUTINE WMGLOW ( FLRBPI ) GRDHGH(I,0) = JTOT ! save the count of higher ranked grids END DO ! -!/T WRITE (MDST,9041) -!/T DO I=1, NRGRD -!/T WRITE (MDST,9042) I, GRDHGH(I,0:GRDHGH(I,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9041) + DO I=1, NRGRD + WRITE (MDST,9042) I, GRDHGH(I,0:GRDHGH(I,0)) + END DO +#endif ! ! -------------------------------------------------------------------- / ! 5. Export file flags @@ -949,26 +1015,42 @@ SUBROUTINE WMGLOW ( FLRBPI ) ' NOT FOUND IN LOWER RANK GRID : ',2E10.3/ & ' POINT SKIPPED '/) ! -!/T 9010 FORMAT ( ' TEST WMGLOW : ALL GRIDS INITIALIZED') -! -!/T 9020 FORMAT ( ' TEST WMGLOW : STARTING LOOP OVER GRIDS') -!/T 9021 FORMAT ( ' TEST WMGLOW : I, RANK, NBI :',2I4,I6) -!/T 9022 FORMAT ( ' ',A) -!/T1 9023 FORMAT (' TEST WMGLOW : POINT DATA ') -!/T1 9024 FORMAT (I5,I8,2F6.1,4I5,4F5.2,I3,4I8) -!/T2 9025 FORMAT (' TEST WMGLOW : NBI2S ') -!/T2 9026 FORMAT (' ',2I4,2X,I8) -!/T 9027 FORMAT (' TEST WMGLOW : NBI, NBI2, RFILE, NBI2G ') -!/T 9028 FORMAT (' ',2I5,L2,' : ',20I5) -!/T9 9029 FORMAT (' TEST WMGLOW : SOURCE MAP GRID',I3,' PART',I3) -! -!/T 9030 FORMAT ( ' TEST WMGLOW : GRDLOW DIMENSIONED AT ',I2) -!/T 9031 FORMAT ( ' TEST WMGLOW : GRDLOW :') -!/T 9032 FORMAT ( ' ',2i4,' : ',20I3) -! -!/T 9040 FORMAT ( ' TEST WMGLOW : GRDHGH DIMENSIONED AT ',I2) -!/T 9041 FORMAT ( ' TEST WMGLOW : GRDHGH :') -!/T 9042 FORMAT ( ' ',2i4,' : ',20I3) +#ifdef W3_T + 9010 FORMAT ( ' TEST WMGLOW : ALL GRIDS INITIALIZED') +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMGLOW : STARTING LOOP OVER GRIDS') + 9021 FORMAT ( ' TEST WMGLOW : I, RANK, NBI :',2I4,I6) + 9022 FORMAT ( ' ',A) +#endif +#ifdef W3_T1 + 9023 FORMAT (' TEST WMGLOW : POINT DATA ') + 9024 FORMAT (I5,I8,2F6.1,4I5,4F5.2,I3,4I8) +#endif +#ifdef W3_T2 + 9025 FORMAT (' TEST WMGLOW : NBI2S ') + 9026 FORMAT (' ',2I4,2X,I8) +#endif +#ifdef W3_T + 9027 FORMAT (' TEST WMGLOW : NBI, NBI2, RFILE, NBI2G ') + 9028 FORMAT (' ',2I5,L2,' : ',20I5) +#endif +#ifdef W3_T9 + 9029 FORMAT (' TEST WMGLOW : SOURCE MAP GRID',I3,' PART',I3) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMGLOW : GRDLOW DIMENSIONED AT ',I2) + 9031 FORMAT ( ' TEST WMGLOW : GRDLOW :') + 9032 FORMAT ( ' ',2i4,' : ',20I3) +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST WMGLOW : GRDHGH DIMENSIONED AT ',I2) + 9041 FORMAT ( ' TEST WMGLOW : GRDHGH :') + 9042 FORMAT ( ' ',2i4,' : ',20I3) +#endif !/ !/ End of WMGLOW ----------------------------------------------------- / !/ @@ -1109,19 +1191,25 @@ SUBROUTINE WMGHGH USE CONSTANTS USE W3SERVMD, ONLY: EXTCDE USE W3GSRUMD, ONLY: W3DIST -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD USE W3ODATMD USE WMMDATMD USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC ! USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC_GLOB -!/SCRIP USE WMSCRPMD -!/SCRIP USE SCRIP_INTERFACE +#ifdef W3_SCRIP + USE WMSCRPMD + USE SCRIP_INTERFACE +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif ! !/ !/ ------------------------------------------------------------------- / @@ -1145,19 +1233,31 @@ SUBROUTINE WMGHGH ISRC, JSRC, ISRCL, ISRCH, JSRCL, JSRCH, NIT, & NRTOT, NROK, JF, JR, NLMAX, ISPROC, ISPRO2, & IREC, ISND, ITMP,ILOC -!/SCRIP INTEGER :: NLMAX_SCRIP - -!/DIST INTEGER :: LTAG0 -!/MPI INTEGER :: IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_SCRIP + INTEGER :: NLMAX_SCRIP +#endif + +#ifdef W3_DIST + INTEGER :: LTAG0 +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: IDSTL(:), IDSTH(:), JDSTL(:), JDSTH(:), & MAPTST(:,:), & I1(:,:), I2(:,:), I3(:), I4(:), & INFLND(:,:) INTEGER, ALLOCATABLE :: NX_BEG(:), NX_END(:) -!/MPIBDI INTEGER, ALLOCATABLE :: NX_SIZE(:), IRQ(:), MSTAT(:,:) -!/MPI INTEGER :: IM, NX_REM, TAG, NRQ +#ifdef W3_MPIBDI + INTEGER, ALLOCATABLE :: NX_SIZE(:), IRQ(:), MSTAT(:,:) +#endif +#ifdef W3_MPI + INTEGER :: IM, NX_REM, TAG, NRQ +#endif INTEGER, ALLOCATABLE :: TMPINT_OM(:,:),TMPINT(:,:) REAL, ALLOCATABLE :: TMPRL_OM(:,:) ,TMPRL(:,:) @@ -1165,7 +1265,9 @@ SUBROUTINE WMGHGH INTEGER :: NR0 , NR1 , NR2 , NRL , NLOC INTEGER :: NR0_OM, NR1_OM, NR2_OM, NRL_OM, NLOC_OM -!/DIST INTEGER, ALLOCATABLE :: LTAG(:) +#ifdef W3_DIST + INTEGER, ALLOCATABLE :: LTAG(:) +#endif REAL :: FACTOR, STX, STY, STXY, NEWVAL, & XL, XH, YL, YH, XA, YA, DXC, JD, & @@ -1190,19 +1292,23 @@ SUBROUTINE WMGHGH REAL :: DX_MAX_GDST,DY_MAX_GDST REAL :: DX_MIN_GSRC,DY_MIN_GSRC -!/SCRIP TYPE ALLWGT -!/SCRIP TYPE(WEIGHT_DATA), POINTER :: WGTDATA(:) -!/SCRIP END TYPE ALLWGT -!/SCRIP TYPE(ALLWGT), ALLOCATABLE :: ALLWGTS(:) -!/SCRIP LOGICAL :: L_MASTER = .TRUE. -!/SCRIP LOGICAL :: L_READ = .FALSE. -!/SCRIP LOGICAL :: L_WRITE = .FALSE. -!/SCRIPNC INTEGER :: IMPROC_ASSIGN -!/SCRIPNC CHARACTER(LEN=80) :: interp_file1, interp_file_test -!/SCRIPNC CHARACTER(LEN=3) :: cdst, csrc -!/SCRIPNC LOGICAL, ALLOCATABLE :: LGRDREAD(:,:) -!/SCRIPNC LOGICAL, ALLOCATABLE :: LGRDWRITE(:,:) -!/SCRIPNC INTEGER :: NGRDRANK(2) +#ifdef W3_SCRIP + TYPE ALLWGT + TYPE(WEIGHT_DATA), POINTER :: WGTDATA(:) + END TYPE ALLWGT + TYPE(ALLWGT), ALLOCATABLE :: ALLWGTS(:) + LOGICAL :: L_MASTER = .TRUE. + LOGICAL :: L_READ = .FALSE. + LOGICAL :: L_WRITE = .FALSE. +#endif +#ifdef W3_SCRIPNC + INTEGER :: IMPROC_ASSIGN + CHARACTER(LEN=80) :: interp_file1, interp_file_test + CHARACTER(LEN=3) :: cdst, csrc + LOGICAL, ALLOCATABLE :: LGRDREAD(:,:) + LOGICAL, ALLOCATABLE :: LGRDWRITE(:,:) + INTEGER :: NGRDRANK(2) +#endif LOGICAL :: LSCRIP=.FALSE. ! true if SCRIP switch is set, ! indicates that SCRIP code has @@ -1238,24 +1344,36 @@ SUBROUTINE WMGHGH INTEGER :: ITRI, IM1, IM2, IT, JT, IsFirst REAL :: DIST_MIN, DIST_MAX, eDist -!/T CHARACTER(LEN=1), ALLOCATABLE :: MAPST(:,:) +#ifdef W3_T + CHARACTER(LEN=1), ALLOCATABLE :: MAPST(:,:) +#endif !/ -!/T38 CHARACTER (LEN=10) :: CDATE_TIME(3) -!/T38 INTEGER :: DATE_TIME(8) -!/T38 INTEGER :: ELAPSED_TIME, BEG_TIME(10), END_TIME -!/T38 INTEGER :: NMYOUT=42 -!/T38 CHARACTER (LEN=14) :: CMYOUT="myout00000.lis" -!/T38 CHARACTER (LEN=5) :: CRANK - -!/T38 WRITE(CRANK, "(I5.5)") IMPROC-1 -!/T38 CMYOUT(6:10) = CRANK(1:5) -!/T38 OPEN (NMYOUT, FILE=CMYOUT, STATUS="REPLACE") -!/S CALL STRACE (IENT, 'WMGHGH') -! -!/MPI CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(1) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 WRITE(NMYOUT,*) "WMGHGH: START: 0 MSEC" +#ifdef W3_T38 + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME(10), END_TIME + INTEGER :: NMYOUT=42 + CHARACTER (LEN=14) :: CMYOUT="myout00000.lis" + CHARACTER (LEN=5) :: CRANK +#endif + +#ifdef W3_T38 + WRITE(CRANK, "(I5.5)") IMPROC-1 + CMYOUT(6:10) = CRANK(1:5) + OPEN (NMYOUT, FILE=CMYOUT, STATUS="REPLACE") +#endif +#ifdef W3_S + CALL STRACE (IENT, 'WMGHGH') +#endif +! +#ifdef W3_MPI + CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) +#endif +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(1) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + WRITE(NMYOUT,*) "WMGHGH: START: 0 MSEC" +#endif ! -------------------------------------------------------------------- / @@ -1266,29 +1384,39 @@ SUBROUTINE WMGHGH CALL EXTCDE (1000) END IF -!/MPIBDI LMPIBDI=.TRUE. -!/SCRIP IF (IMPROC .EQ. 1) THEN -!/SCRIP L_MASTER = .TRUE. -!/SCRIP L_WRITE = .TRUE. -!/SCRIP ELSE -!/SCRIP L_MASTER = .FALSE. -!/SCRIP L_WRITE = .FALSE. -!/SCRIP ENDIF -!/SCRIPNC INQUIRE(FILE="SCRIP_STOP", EXIST=L_STOP) -!/SCRIPNC IMPROC_ASSIGN = 1 +#ifdef W3_MPIBDI + LMPIBDI=.TRUE. +#endif +#ifdef W3_SCRIP + IF (IMPROC .EQ. 1) THEN + L_MASTER = .TRUE. + L_WRITE = .TRUE. + ELSE + L_MASTER = .FALSE. + L_WRITE = .FALSE. + ENDIF +#endif +#ifdef W3_SCRIPNC + INQUIRE(FILE="SCRIP_STOP", EXIST=L_STOP) + IMPROC_ASSIGN = 1 +#endif ! !KRL Allocate helper arrays to enable bottleneck loop parallelization ALLOCATE ( NX_BEG(NMPROC), NX_END(NMPROC), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/MPIBDI ALLOCATE ( NX_SIZE(NMPROC), IRQ(2*NMPROC), & -!/MPIBDI MSTAT(MPI_STATUS_SIZE,2*NMPROC), STAT=ISTAT ) -!/MPIBDI CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_MPIBDI + ALLOCATE ( NX_SIZE(NMPROC), IRQ(2*NMPROC), & + MSTAT(MPI_STATUS_SIZE,2*NMPROC), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! !!HT: !!HT: Set up and initialize storage data structures .... !!HT: -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) +#endif DO GDST=1, NRGRD DO GSRC=1, NRGRD IF ( HGSTGE(GDST,GSRC)%INIT ) THEN @@ -1319,17 +1447,25 @@ SUBROUTINE WMGHGH GDST=-999 ! unset grid GSRC=-999 ! unset grid -!/T38 CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = END_TIME - BEG_TIME(2) -!/T38 WRITE(NMYOUT,*) "WMGHGH, LOOP 1 TOOK ", ELAPSED_TIME, " MSEC" +#ifdef W3_T38 + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(2) + WRITE(NMYOUT,*) "WMGHGH, LOOP 1 TOOK ", ELAPSED_TIME, " MSEC" +#endif ! -------------------------------------------------------------------- / ! 0.a Plan future behavior by setting logical variables. -!/SCRIP LSCRIP=.TRUE. -!/SCRIPNC LSCRIPNC=.TRUE. -!/T38 T38=.TRUE. +#ifdef W3_SCRIP + LSCRIP=.TRUE. +#endif +#ifdef W3_SCRIPNC + LSCRIPNC=.TRUE. +#endif +#ifdef W3_T38 + T38=.TRUE. +#endif DO GDST=1, NRGRD IF ( GRIDS(GDST)%GTYPE .NE. RLGTYPE .AND. & @@ -1379,7 +1515,9 @@ SUBROUTINE WMGHGH !!HT: could provide data to a low-res grid. The high-res grid with data !!HT: furthest away from its own open boundary will be used. -!/SCRIPNC IF (.NOT. L_STOP) THEN ! Do not need MAPBDI if going to stop after generating mappings +#ifdef W3_SCRIPNC + IF (.NOT. L_STOP) THEN ! Do not need MAPBDI if going to stop after generating mappings +#endif IF ( .NOT. FLGBDI ) THEN ! IF ( FLAGLL ) THEN @@ -1389,17 +1527,23 @@ SUBROUTINE WMGHGH FACTOR = 1. END IF ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! ! 1.b Loop over grids ! -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) -!/T38 WRITE(NMYOUT,*) "WMGHGH, BEGINNING BOTTLENECK LOOP AT ", ELAPSED_TIME, " MSEC" +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, BEGINNING BOTTLENECK LOOP AT ", ELAPSED_TIME, " MSEC" +#endif DO GDST=1, NRGRD -!/T38 IF(IMPROC.EQ.NMPERR)WRITE(MDSE,*)'GDST = ',GDST,' OUT OF ',NRGRD +#ifdef W3_T38 + IF(IMPROC.EQ.NMPERR)WRITE(MDSE,*)'GDST = ',GDST,' OUT OF ',NRGRD +#endif CALL W3SETO ( GDST, MDSE, MDST ) CALL W3SETG ( GDST, MDSE, MDST ) @@ -1413,7 +1557,9 @@ SUBROUTINE WMGHGH ! END IF ! -!/T WRITE (MDST,9011) GDST, GRANK(GDST), NBI +#ifdef W3_T + WRITE (MDST,9011) GDST, GRANK(GDST), NBI +#endif ! ! -------------------------------------------------------------------- / ! Inconsistent RANK vs NBI (warning message) @@ -1429,7 +1575,9 @@ SUBROUTINE WMGHGH ! IF ( (NBI.EQ.0) .OR. (GRANK(GDST).EQ.1) ) THEN ! (then do nothing except test output) -!/T WRITE (MDST,9012) +#ifdef W3_T + WRITE (MDST,9012) +#endif ! -------------------------------------------------------------------- / ! 1.d NBI>0, Generate map with distances to boundary. @@ -1452,24 +1600,26 @@ SUBROUTINE WMGHGH !KRL Set up ranges for X. If not MPIBDI, just 1 to NX NX_BEG(IMPROC) = 1 NX_END(IMPROC) = NX -!/MPIBDI NX_BEG(1) = 1 -!/MPIBDI IF ( NMPROC .EQ. 1 ) THEN -!/MPIBDI NX_END(1) = NX -!/MPIBDI NX_SIZE(1) = NX -!/MPIBDI ELSE -!/MPIBDI NX_REM = MOD( NX, NMPROC ) -!/MPIBDI NX_SIZE(1) = NX / NMPROC -!/MPIBDI IF (NX_REM .GT. 0) NX_SIZE(1) = NX_SIZE(1) + 1 -!/MPIBDI NX_END(1) = NX_BEG(1) + NX_SIZE(1) - 1 -!/MPIBDI DO IM = 2, NMPROC -!/MPIBDI NX_BEG(IM) = NX_END(IM-1) + 1 -!/MPIBDI NX_SIZE(IM) = NX / NMPROC -!/MPIBDI IF (IM .LE. NX_REM) NX_SIZE(IM) = NX_SIZE(IM) + 1 -!/MPIBDI NX_END(IM) = NX_BEG(IM) + NX_SIZE(IM) - 1 -!/MPIBDI NX_SIZE(IM-1) = NX_SIZE(IM-1) * NY -!/MPIBDI END DO -!/MPIBDI NX_SIZE(NMPROC) = NX_SIZE(NMPROC) * NY -!/MPIBDI END IF +#ifdef W3_MPIBDI + NX_BEG(1) = 1 + IF ( NMPROC .EQ. 1 ) THEN + NX_END(1) = NX + NX_SIZE(1) = NX + ELSE + NX_REM = MOD( NX, NMPROC ) + NX_SIZE(1) = NX / NMPROC + IF (NX_REM .GT. 0) NX_SIZE(1) = NX_SIZE(1) + 1 + NX_END(1) = NX_BEG(1) + NX_SIZE(1) - 1 + DO IM = 2, NMPROC + NX_BEG(IM) = NX_END(IM-1) + 1 + NX_SIZE(IM) = NX / NMPROC + IF (IM .LE. NX_REM) NX_SIZE(IM) = NX_SIZE(IM) + 1 + NX_END(IM) = NX_BEG(IM) + NX_SIZE(IM) - 1 + NX_SIZE(IM-1) = NX_SIZE(IM-1) * NY + END DO + NX_SIZE(NMPROC) = NX_SIZE(NMPROC) * NY + END IF +#endif !KRL Setup complete ! ! -------------------------------------------------------------------- / @@ -1516,7 +1666,9 @@ SUBROUTINE WMGHGH DO JBND=1,NY IF ( ABS(MAPSTA(JBND,IBND)) .EQ. 2 ) THEN ! (boundary point) -!/OMPH/!$OMP PARALLEL DO PRIVATE(IDST,JDST,DD),SCHEDULE(DYNAMIC) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE(IDST,JDST,DD),SCHEDULE(DYNAMIC) +#endif DO IDST=NX_BEG(IMPROC), NX_END(IMPROC) DO JDST=1, NY IF (ABS(MAPSTA(JDST,IDST)) .EQ. 1) THEN @@ -1536,7 +1688,9 @@ SUBROUTINE WMGHGH ENDIF END DO ! DO JDST END DO ! DO IDST -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif ENDIF ! (if BND point) END DO ! DO JBND @@ -1547,28 +1701,30 @@ SUBROUTINE WMGHGH ! -------------------------------------------------------------------- / -!/MPIBDI !KRL Exchange (Note: for efficiency, post receives first) -!/MPIBDI !KRL MPI_ALLGATHERV would do this, but freezes for PGI and open_mpi -!/MPIBDI !KRL This suggests they use blocking SEND/RECV, so this is faster anyway and less implementation-dependent -!/MPIBDI NRQ = 0 -!/MPIBDI DO IM = 1, NMPROC -!/MPIBDI IF ( IM .NE. IMPROC ) THEN -!/MPIBDI NRQ = NRQ + 1 -!/MPIBDI TAG = NMPROC * IM + IMPROC -!/MPIBDI CALL MPI_IRECV ( MAPBDI(1,NX_BEG(IM)), NX_SIZE(IM), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & -!/MPIBDI IRQ(NRQ), IERR_MPI ) -!/MPIBDI END IF -!/MPIBDI END DO -!/MPIBDI DO IM = 1, NMPROC -!/MPIBDI IF ( IM .NE. IMPROC ) THEN -!/MPIBDI NRQ = NRQ + 1 -!/MPIBDI TAG = NMPROC * IMPROC + IM -!/MPIBDI CALL MPI_ISEND( MAPBDI(1,NX_BEG(IMPROC)), NX_SIZE(IMPROC), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & -!/MPIBDI IRQ(NRQ), IERR_MPI ) -!/MPIBDI END IF -!/MPIBDI END DO -!/MPIBDI CALL MPI_WAITALL( NRQ, IRQ, MPI_STATUS_IGNORE, IERR_MPI ) -!/MPIBDI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPIBDI + !KRL Exchange (Note: for efficiency, post receives first) + !KRL MPI_ALLGATHERV would do this, but freezes for PGI and open_mpi + !KRL This suggests they use blocking SEND/RECV, so this is faster anyway and less implementation-dependent + NRQ = 0 + DO IM = 1, NMPROC + IF ( IM .NE. IMPROC ) THEN + NRQ = NRQ + 1 + TAG = NMPROC * IM + IMPROC + CALL MPI_IRECV ( MAPBDI(1,NX_BEG(IM)), NX_SIZE(IM), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) + END IF + END DO + DO IM = 1, NMPROC + IF ( IM .NE. IMPROC ) THEN + NRQ = NRQ + 1 + TAG = NMPROC * IMPROC + IM + CALL MPI_ISEND( MAPBDI(1,NX_BEG(IMPROC)), NX_SIZE(IMPROC), MPI_REAL, IM - 1, TAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) + END IF + END DO + CALL MPI_WAITALL( NRQ, IRQ, MPI_STATUS_IGNORE, IERR_MPI ) + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif IF(IMPROC.EQ.NMPERR)WRITE(MDSE,'(A/)') & ' Finished generating map with distances to boundary.' @@ -1604,16 +1760,20 @@ SUBROUTINE WMGHGH !!HT: Note that SIG(1) and DTMAX are included here so that the map defines !!HT: how many time steps DTMAX it takes to reach this place. -!/T WRITE (MDST,9013) -!/T DO JDST=NY,1 , -1 -!/T WRITE (MDST,9014) NINT(MAPBDI(JDST,:)*SIG(1)/DTMAX) -!/T END DO +#ifdef W3_T + WRITE (MDST,9013) + DO JDST=NY,1 , -1 + WRITE (MDST,9014) NINT(MAPBDI(JDST,:)*SIG(1)/DTMAX) + END DO +#endif ! END IF END DO FLGBDI = .TRUE. END IF -!/SCRIPNC END IF +#ifdef W3_SCRIPNC + END IF +#endif ! ! -------------------------------------------------------------------- / ! 2. Data sources for reconcilliation @@ -1627,52 +1787,66 @@ SUBROUTINE WMGHGH I3(NRGRD), I4(NRGRD), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/DIST LTAG0 = 0 - -!/SCRIPNC ! If reading/writing SCRIP files, need to determine in advance which it is to avoid race condition: -!/SCRIPNC ! Processor writing file before other processor can check for it -!/SCRIPNC NGRDRANK = SHAPE(GRDHGH) -!/SCRIPNC ALLOCATE( LGRDREAD(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) -!/SCRIPNC CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIPNC ALLOCATE(LGRDWRITE(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) -!/SCRIPNC CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIPNC DO GDST=1, NRGRD -!/SCRIPNC DO JJ = 1, GRDHGH(GDST,0) -!/SCRIPNC IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN -!/SCRIPNC ! If no remap, then no file -!/SCRIPNC LGRDREAD(GDST,JJ) = .FALSE. -!/SCRIPNC LGRDWRITE(GDST,JJ) = .FALSE. -!/SCRIPNC ELSE -!/SCRIPNC GSRC = GRDHGH(GDST,JJ) -!/SCRIPNC INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" -!/SCRIPNC WRITE(CDST, "(I3.3)") GDST -!/SCRIPNC WRITE(CSRC, "(I3.3)") GSRC -!/SCRIPNC INTERP_FILE1(24:26) = CSRC -!/SCRIPNC INTERP_FILE1(28:30) = CDST -!/SCRIPNC INQUIRE(FILE=INTERP_FILE1, EXIST=L_READ) -!/SCRIPNC ! At this point, file either exists already (L_READ = .TRUE.) or needs to be written -!/SCRIPNC LGRDREAD(GDST,JJ) = L_READ -!/SCRIPNC LGRDWRITE(GDST,JJ) = .NOT. L_READ -!/SCRIPNC END IF -!/SCRIPNC END DO -!/SCRIPNC END DO -!/MPI IF (LSCRIPNC) CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) +#ifdef W3_DIST + LTAG0 = 0 +#endif + +#ifdef W3_SCRIPNC + ! If reading/writing SCRIP files, need to determine in advance which it is to avoid race condition: + ! Processor writing file before other processor can check for it + NGRDRANK = SHAPE(GRDHGH) + ALLOCATE( LGRDREAD(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(LGRDWRITE(NGRDRANK(1)-1, NGRDRANK(2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO GDST=1, NRGRD + DO JJ = 1, GRDHGH(GDST,0) + IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN + ! If no remap, then no file + LGRDREAD(GDST,JJ) = .FALSE. + LGRDWRITE(GDST,JJ) = .FALSE. + ELSE + GSRC = GRDHGH(GDST,JJ) + INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" + WRITE(CDST, "(I3.3)") GDST + WRITE(CSRC, "(I3.3)") GSRC + INTERP_FILE1(24:26) = CSRC + INTERP_FILE1(28:30) = CDST + INQUIRE(FILE=INTERP_FILE1, EXIST=L_READ) + ! At this point, file either exists already (L_READ = .TRUE.) or needs to be written + LGRDREAD(GDST,JJ) = L_READ + LGRDWRITE(GDST,JJ) = .NOT. L_READ + END IF + END DO + END DO +#endif +#ifdef W3_MPI + IF (LSCRIPNC) CALL MPI_BARRIER(MPI_COMM_MWAVE, IERR_MPI) +#endif LOWRANK_GRID : DO GDST=1, NRGRD -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = BEG_TIME(2) - BEG_TIME(1) -!/T38 WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " START: ", ELAPSED_TIME, " MSEC" +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(2) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(2) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " START: ", ELAPSED_TIME, " MSEC" +#endif ! Test output -!/T WRITE (MDST,9020) GDST, GRDHGH(GDST,0) -!/SCRIP IF ( IMPROC.EQ.NMPERR.AND.T38 )WRITE(MDST,*)'GDST = ',GDST,' OUT OF ',NRGRD +#ifdef W3_T + WRITE (MDST,9020) GDST, GRDHGH(GDST,0) +#endif +#ifdef W3_SCRIP + IF ( IMPROC.EQ.NMPERR.AND.T38 )WRITE(MDST,*)'GDST = ',GDST,' OUT OF ',NRGRD +#endif ! IF ( GRDHGH(GDST,0) .EQ. 0 ) THEN ! no grids of higher rank than this ! one. -!/T WRITE (MDST,9021) +#ifdef W3_T + WRITE (MDST,9021) +#endif ELSE ! processing required ! @@ -1735,21 +1909,29 @@ SUBROUTINE WMGHGH ! ALLOCATE ( WGTDATA(grid2_size), STAT=ISTAT ) ! grid2=destination grid ! CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIP NJDST=NY -!/SCRIP NIDST=NX -!/SCRIP ALLOCATE ( ALLWGTS(MAXVAL(GRDHGH)), STAT=ISTAT ) -!/SCRIP CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_SCRIP + NJDST=NY + NIDST=NX + ALLOCATE ( ALLWGTS(MAXVAL(GRDHGH)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! Next, we loop through the src grids for the dst grid that we are working on. -!/SCRIP DO JJ=1, GRDHGH(GDST,0) -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) -!/T38 WRITE(NMYOUT,*) "WMGHGH, LOOP JJ= ", JJ, " START: ", ELAPSED_TIME, " MSEC" - -!/SCRIP GSRC = GRDHGH(GDST,JJ) -!/SCRIP NISRC=GRIDS(GSRC)%NX -!/SCRIP NJSRC=GRIDS(GSRC)%NY ! only needed for diagnostics +#ifdef W3_SCRIP + DO JJ=1, GRDHGH(GDST,0) +#endif +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(3) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, LOOP JJ= ", JJ, " START: ", ELAPSED_TIME, " MSEC" +#endif + +#ifdef W3_SCRIP + GSRC = GRDHGH(GDST,JJ) + NISRC=GRIDS(GSRC)%NX + NJSRC=GRIDS(GSRC)%NY ! only needed for diagnostics +#endif ! Next, we call SCRIP for this src grid. ! Conditions for calling SCRIP are: @@ -1762,71 +1944,95 @@ SUBROUTINE WMGHGH ! processors, since it is simply based on whether the file already ! exists. -!/SCRIPNC INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" -!/SCRIPNC WRITE(CDST, "(I3.3)") GDST -!/SCRIPNC WRITE(CSRC, "(I3.3)") GSRC -!/SCRIPNC INTERP_FILE1(24:26) = CSRC -!/SCRIPNC INTERP_FILE1(28:30) = CDST -!/SCRIPNC L_READ = LGRDREAD(GDST, JJ) -!/T38 CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 BEG_TIME(4) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) -!/T38 WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER START: ", ELAPSED_TIME, " MSEC" -!/SCRIPNC IF (L_STOP) L_WRITE = (IMPROC .EQ. IMPROC_ASSIGN) - -!/SCRIPNC IF(L_STOP.AND.L_READ)THEN -!/SCRIPNC IF ( IMPROC.EQ.NMPERR ) & -!/SCRIPNC WRITE(MDSE,'(A)')'ERROR: You should either have SCRIP_STOP '// & -!/SCRIPNC 'or remapping (.nc) files. Not both. We will exit now.' -!/SCRIPNC CALL EXTCDE (505) -!/SCRIPNC ENDIF - -!/SCRIP CALLED_SCRIP=.FALSE. ! initialize - -!/SCRIPNC IF ((.NOT. L_STOP) .OR. ((.NOT. L_READ) .AND. L_WRITE)) THEN -!/SCRIP IF (L_STOP) THEN ! we are sending different grids to different processors -!/SCRIP WRITE(MDSE,'(A,2(I5),A,I5)')'Calling SCRIP for GSRC,GDST = ', & -!/SCRIP GSRC,GDST,' on processor ',IMPROC -!/SCRIP ELSEIF(IMPROC.EQ.NMPERR)THEN -!/SCRIP WRITE(MDSE,'(A,2(I5))')'Calling SCRIP interface for GSRC,GDST = ', & -!/SCRIP GSRC,GDST -!/SCRIP ENDIF -!/SCRIP CALL scrip_wrapper (GSRC, GDST, & -!/SCRIP GRIDS(GSRC)%MAPSTA,GRIDS(GSRC)%MAPST2,FLAGLL, & -!/SCRIP GRIDS(GSRC)%GRIDSHIFT,L_WRITE,L_READ,T38) -!/SCRIP CALLED_SCRIP=.TRUE. -!/SCRIPNC END IF -!/SCRIP CALL FLUSH(MDSE) -!/SCRIPNC IF (L_STOP) THEN -!/SCRIPNC IF (.NOT. L_READ) THEN -!/SCRIPNC IMPROC_ASSIGN = IMPROC_ASSIGN + 1 -!/SCRIPNC IF (IMPROC_ASSIGN .GT. NMPROC) IMPROC_ASSIGN = 1 -!/SCRIPNC IF(CALLED_SCRIP)THEN ! we called scrip_wrapper, so we need -!/SCRIPNC ! to deallocate before leaving -!/SCRIPNC DST_GRID_SIZE=NIDST*NJDST -!/SCRIPNC DO KDST=1,DST_GRID_SIZE -!/SCRIPNC DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END DO -!/SCRIPNC DEALLOCATE(WGTDATA, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC CYCLE ! cycle out of this loop : DO JJ=1, GRDHGH(GDST,0) -!/SCRIPNC END IF -!/SCRIPNC END IF -!/T38 CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = END_TIME - BEG_TIME(4) -!/T38 WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" - -!/SCRIP IF(.NOT.CALLED_SCRIP)THEN ! we should not be here, since we need -!/SCRIP ! WGTDATA(KDST)%N which is created by SCRIP -!/SCRIP IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,'(A)')'ERROR: we '// & -!/SCRIP 'should have cycled out by now. We will exit now.' -!/SCRIP CALL EXTCDE (506) -!/SCRIP ENDIF +#ifdef W3_SCRIPNC + INTERP_FILE1 = "rmp_src_to_dst_conserv_xxx_xxx.nc" + WRITE(CDST, "(I3.3)") GDST + WRITE(CSRC, "(I3.3)") GSRC + INTERP_FILE1(24:26) = CSRC + INTERP_FILE1(28:30) = CDST + L_READ = LGRDREAD(GDST, JJ) +#endif +#ifdef W3_T38 + CALL DATE_AND_TIME ( CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + BEG_TIME(4) = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = BEG_TIME(3) - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER START: ", ELAPSED_TIME, " MSEC" +#endif +#ifdef W3_SCRIPNC + IF (L_STOP) L_WRITE = (IMPROC .EQ. IMPROC_ASSIGN) +#endif + +#ifdef W3_SCRIPNC + IF(L_STOP.AND.L_READ)THEN + IF ( IMPROC.EQ.NMPERR ) & + WRITE(MDSE,'(A)')'ERROR: You should either have SCRIP_STOP '// & + 'or remapping (.nc) files. Not both. We will exit now.' + CALL EXTCDE (505) + ENDIF +#endif + +#ifdef W3_SCRIP + CALLED_SCRIP=.FALSE. ! initialize +#endif + +#ifdef W3_SCRIPNC + IF ((.NOT. L_STOP) .OR. ((.NOT. L_READ) .AND. L_WRITE)) THEN +#endif +#ifdef W3_SCRIP + IF (L_STOP) THEN ! we are sending different grids to different processors + WRITE(MDSE,'(A,2(I5),A,I5)')'Calling SCRIP for GSRC,GDST = ', & + GSRC,GDST,' on processor ',IMPROC + ELSEIF(IMPROC.EQ.NMPERR)THEN + WRITE(MDSE,'(A,2(I5))')'Calling SCRIP interface for GSRC,GDST = ', & + GSRC,GDST + ENDIF + CALL scrip_wrapper (GSRC, GDST, & + GRIDS(GSRC)%MAPSTA,GRIDS(GSRC)%MAPST2,FLAGLL, & + GRIDS(GSRC)%GRIDSHIFT,L_WRITE,L_READ,T38) + CALLED_SCRIP=.TRUE. +#endif +#ifdef W3_SCRIPNC + END IF +#endif +#ifdef W3_SCRIP + CALL FLUSH(MDSE) +#endif +#ifdef W3_SCRIPNC + IF (L_STOP) THEN + IF (.NOT. L_READ) THEN + IMPROC_ASSIGN = IMPROC_ASSIGN + 1 + IF (IMPROC_ASSIGN .GT. NMPROC) IMPROC_ASSIGN = 1 + IF(CALLED_SCRIP)THEN ! we called scrip_wrapper, so we need + ! to deallocate before leaving + DST_GRID_SIZE=NIDST*NJDST + DO KDST=1,DST_GRID_SIZE + DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE(WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + CYCLE ! cycle out of this loop : DO JJ=1, GRDHGH(GDST,0) + END IF + END IF +#endif +#ifdef W3_T38 + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(4) + WRITE(NMYOUT,*) "WMGHGH, SCRIP WRAPPER, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" +#endif + +#ifdef W3_SCRIP + IF(.NOT.CALLED_SCRIP)THEN ! we should not be here, since we need + ! WGTDATA(KDST)%N which is created by SCRIP + IF ( IMPROC.EQ.NMPERR ) WRITE(MDSE,'(A)')'ERROR: we '// & + 'should have cycled out by now. We will exit now.' + CALL EXTCDE (506) + ENDIF +#endif ! SCRIP has now created the data strucure "WGTDATA" and stored the weights ! in it. However, this is only for the present src grid. We want to store the @@ -1834,17 +2040,19 @@ SUBROUTINE WMGHGH ! "ALLWGT" to store this data. First though, we need to ALLOCATE it: ! (note: "k" is equivalent to isea, but includes *all* points) -!/SCRIP DST_GRID_SIZE=NIDST*NJDST -!/SCRIP ALLOCATE(ALLWGTS(GSRC)%WGTDATA(DST_GRID_SIZE),STAT=ISTAT) -!/SCRIP CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIP DO KDST=1,DST_GRID_SIZE -!/SCRIP ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & -!/SCRIP %W(WGTDATA(KDST)%N),STAT=ISTAT) -!/SCRIP CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIP ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & -!/SCRIP %K(WGTDATA(KDST)%N),STAT=ISTAT) -!/SCRIP CHECK_ALLOC_STATUS ( ISTAT ) -!/SCRIP END DO +#ifdef W3_SCRIP + DST_GRID_SIZE=NIDST*NJDST + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(DST_GRID_SIZE),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + DO KDST=1,DST_GRID_SIZE + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & + %W(WGTDATA(KDST)%N),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE(ALLWGTS(GSRC)%WGTDATA(KDST) & + %K(WGTDATA(KDST)%N),STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) + END DO +#endif ! Now that we have it allocated, we can just copy WGTDATA into ALLWGTS @@ -1856,107 +2064,119 @@ SUBROUTINE WMGHGH ! BEGIN long method for filling derived data type "ALLWGTS" -!/SCRIP DO KDST=1,DST_GRID_SIZE -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%N=WGTDATA(KDST)%N -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%NR0=WGTDATA(KDST)%NR0 -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%NR2=WGTDATA(KDST)%NR2 -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%NRL=WGTDATA(KDST)%NRL -!/SCRIP DO IPNT=1,WGTDATA(KDST)%N -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) & -!/SCRIP =WGTDATA(KDST)%W(IPNT) -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) & -!/SCRIP =WGTDATA(KDST)%K(IPNT) -!/SCRIP END DO -!/SCRIP END DO +#ifdef W3_SCRIP + DO KDST=1,DST_GRID_SIZE + ALLWGTS(GSRC)%WGTDATA(KDST)%N=WGTDATA(KDST)%N + ALLWGTS(GSRC)%WGTDATA(KDST)%NR0=WGTDATA(KDST)%NR0 + ALLWGTS(GSRC)%WGTDATA(KDST)%NR2=WGTDATA(KDST)%NR2 + ALLWGTS(GSRC)%WGTDATA(KDST)%NRL=WGTDATA(KDST)%NRL + DO IPNT=1,WGTDATA(KDST)%N + ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) & + =WGTDATA(KDST)%W(IPNT) + ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) & + =WGTDATA(KDST)%K(IPNT) + END DO + END DO +#endif ! END long method for filling derived data type "ALLWGTS" ! We're done with WGTDATA, so we can DEALLOCATE it. This is important, ! since it will be allocated again the next time SCRIP is called. -!/SCRIP DO KDST=1,DST_GRID_SIZE -!/SCRIP DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIP DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIP END DO -!/SCRIP DEALLOCATE(WGTDATA, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_SCRIP + DO KDST=1,DST_GRID_SIZE + DEALLOCATE(WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE(WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE(WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif ! Here's a "test output" block of code to demonstrate how the weights can ! be called up from ALLWGTS...and to verify that the data is stored properly. ! (again note that "k" is equivalent to isea, but includes *all* points) -!/SCRIP IF(T38)THEN -!/SCRIP WRITE(MDST,'(/2A)')' XDST YDST ', & -!/SCRIP ' XSRC YSRC WXWY' -!/SCRIP DO JDST=1,NJDST -!/SCRIP DO IDST=1,NIDST -!/SCRIP KDST=(JDST-1)*NIDST+IDST -!/SCRIP XDST=GRIDS(GDST)%XGRD(JDST,IDST) -!/SCRIP YDST=GRIDS(GDST)%YGRD(JDST,IDST) -!/SCRIP DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N -!/SCRIP KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) -!/SCRIP JSRC=INT((KSRC-1)/NISRC)+1 -!/SCRIP ISRC=KSRC-(JSRC-1)*NISRC -!/SCRIP XSRC=GRIDS(GSRC)%XGRD(JSRC,ISRC) -!/SCRIP YSRC=GRIDS(GSRC)%YGRD(JSRC,ISRC) -!/SCRIP WXWY=ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) -!/SCRIP WRITE(MDST,'(5(1X,F12.5))')XDST,YDST,XSRC, & -!/SCRIP YSRC,WXWY -!/SCRIP END DO -!/SCRIP END DO -!/SCRIP END DO ! DO JDST=1,NJDST -!/SCRIP ENDIF ! IF(T38)THEN - -!/T38 CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = END_TIME - BEG_TIME(3) -!/T38 WRITE(NMYOUT,*) "WMGHGH, LOOP JJ, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" - -!/SCRIP END DO ! DO JJ=1, GRDHGH(GDST,0) -!/SCRIP GSRC = -999 ! unset grid +#ifdef W3_SCRIP + IF(T38)THEN + WRITE(MDST,'(/2A)')' XDST YDST ', & + ' XSRC YSRC WXWY' + DO JDST=1,NJDST + DO IDST=1,NIDST + KDST=(JDST-1)*NIDST+IDST + XDST=GRIDS(GDST)%XGRD(JDST,IDST) + YDST=GRIDS(GDST)%YGRD(JDST,IDST) + DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + XSRC=GRIDS(GSRC)%XGRD(JSRC,ISRC) + YSRC=GRIDS(GSRC)%YGRD(JSRC,ISRC) + WXWY=ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) + WRITE(MDST,'(5(1X,F12.5))')XDST,YDST,XSRC, & + YSRC,WXWY + END DO + END DO + END DO ! DO JDST=1,NJDST + ENDIF ! IF(T38)THEN +#endif + +#ifdef W3_T38 + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(3) + WRITE(NMYOUT,*) "WMGHGH, LOOP JJ, GSRC= ", GSRC, " TOOK ", ELAPSED_TIME, " MSEC" +#endif + +#ifdef W3_SCRIP + END DO ! DO JJ=1, GRDHGH(GDST,0) + GSRC = -999 ! unset grid +#endif ! If SCRIPNC and L_STOP, then cycle LOWRANK_GRID loop and deallocate ! storage associated with dst grid. -!/SCRIPNC IF (L_STOP) THEN -!/SCRIPNC IF ( ALLOCATED(MAPTST) ) THEN -!/SCRIPNC DEALLOCATE ( MAPTST, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC IF ( ALLOCATED(INFLND) ) THEN -!/SCRIPNC DEALLOCATE ( INFLND, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC IF ( ALLOCATED(ALLWGTS) ) THEN -!/SCRIPNC DO JJ=1, GRDHGH(GDST,0) -!/SCRIPNC GSRC = GRDHGH(GDST,JJ) -!/SCRIPNC IF ( ASSOCIATED(ALLWGTS(GSRC)%WGTDATA) ) THEN -!/SCRIPNC DO KDST=1, DST_GRID_SIZE -!/SCRIPNC -!/SCRIPNC !######################################################################################### -!/SCRIPNC !menta: for some reason gfortran complains that these lines are too long. Unindenting them -!/SCRIPNC IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%W) ) THEN -!/SCRIPNC DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%K) ) THEN -!/SCRIPNC DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC !######################################################################################### -!/SCRIPNC END DO -!/SCRIPNC DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC NULLIFY ( ALLWGTS(GSRC)%WGTDATA ) -!/SCRIPNC END IF -!/SCRIPNC END DO -!/SCRIPNC DEALLOCATE ( ALLWGTS, STAT=ISTAT ) -!/SCRIPNC CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIPNC END IF -!/SCRIPNC CYCLE LOWRANK_GRID -!/SCRIPNC END IF +#ifdef W3_SCRIPNC + IF (L_STOP) THEN + IF ( ALLOCATED(MAPTST) ) THEN + DEALLOCATE ( MAPTST, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( ALLOCATED(INFLND) ) THEN + DEALLOCATE ( INFLND, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( ALLOCATED(ALLWGTS) ) THEN + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + IF ( ASSOCIATED(ALLWGTS(GSRC)%WGTDATA) ) THEN + DO KDST=1, DST_GRID_SIZE + + !######################################################################################### + !menta: for some reason gfortran complains that these lines are too long. Unindenting them + IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%W) ) THEN + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + IF ( ALLOCATED(ALLWGTS(GSRC)%WGTDATA(KDST)%K) ) THEN + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + !######################################################################################### + END DO + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + NULLIFY ( ALLWGTS(GSRC)%WGTDATA ) + END IF + END DO + DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF + CYCLE LOWRANK_GRID + END IF +#endif !################################################################ ! End new block of code: Calculate weights by calling SCRIP interface @@ -2105,8 +2325,10 @@ SUBROUTINE WMGHGH JDSTL(JJ) = MAX ( 1 , JDSTL(JJ) ) JDSTH(JJ) = MIN ( NY , JDSTH(JJ) ) ! -!/T WRITE (MDST,9022) GSRC, IDSTL(JJ),IDSTH(JJ), & -!/T JDSTL(JJ),JDSTH(JJ) +#ifdef W3_T + WRITE (MDST,9022) GSRC, IDSTL(JJ),IDSTH(JJ), & + JDSTL(JJ),JDSTH(JJ) +#endif ! END DO ! end loop through higher ranked grids GSRC = -999 ! unset grid @@ -2133,7 +2355,9 @@ SUBROUTINE WMGHGH ! Obviously, we cannot use this calculation for irregular grids. NLMAX = 0 -!/SCRIP NLMAX_SCRIP=0 +#ifdef W3_SCRIP + NLMAX_SCRIP=0 +#endif DO JJ=1, GRDHGH(GDST,0) GSRC = GRDHGH(GDST,JJ) @@ -2232,19 +2456,23 @@ SUBROUTINE WMGHGH (2+INT(DX_MAX_GDST/DX_MIN_GSRC+0.001)) * & (2+INT(DY_MAX_GDST/DY_MIN_GSRC+0.001)) ) -!/T38 WRITE(MDST,*)'ratio 1 = ',(DX_MAX_GDST/DX_MIN_GSRC), & -!/T38 DX_MAX_GDST,DX_MIN_GSRC -!/T38 WRITE(MDST,*)'ratio 2 = ',(DY_MAX_GDST/DY_MIN_GSRC), & -!/T38 DY_MAX_GDST,DY_MIN_GSRC -!/T38 WRITE(MDSE,*)'GSRC, NLMAX = ',GSRC,NLMAX - -!/SCRIP DO JDST=1, NY -!/SCRIP DO IDST=1, NX -!/SCRIP KDST=(JDST-1)*NIDST+IDST -!/SCRIP NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N -!/SCRIP NLMAX_SCRIP=MAX(NLMAX_SCRIP,NLOC) -!/SCRIP END DO -!/SCRIP END DO +#ifdef W3_T38 + WRITE(MDST,*)'ratio 1 = ',(DX_MAX_GDST/DX_MIN_GSRC), & + DX_MAX_GDST,DX_MIN_GSRC + WRITE(MDST,*)'ratio 2 = ',(DY_MAX_GDST/DY_MIN_GSRC), & + DY_MAX_GDST,DY_MIN_GSRC + WRITE(MDSE,*)'GSRC, NLMAX = ',GSRC,NLMAX +#endif + +#ifdef W3_SCRIP + DO JDST=1, NY + DO IDST=1, NX + KDST=(JDST-1)*NIDST+IDST + NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N + NLMAX_SCRIP=MAX(NLMAX_SCRIP,NLOC) + END DO + END DO +#endif END DO ! DO JJ=1, GRDHGH(GDST,0) GSRC=-999 ! unset grid @@ -2267,15 +2495,17 @@ SUBROUTINE WMGHGH ! checked against each other ! * the SCRIP version of weights (TMPRL) will be the ones used. -!/SCRIP IF ( IMPROC.EQ.NMPERR.AND.T38 ) & -!/SCRIP WRITE(MDSE,*) 'NLMAX,NLMAX_SCRIP=',NLMAX,NLMAX_SCRIP -!/SCRIP IF(DO_CHECKING)THEN -!/SCRIP NLMAX = MAX (NLMAX, NLMAX_SCRIP) -!/SCRIP ELSE -!/SCRIP NLMAX = NLMAX_SCRIP -!/SCRIP ENDIF -!/SCRIP IF ( IMPROC.EQ.NMPERR.AND.T38 ) & -!/SCRIP WRITE(MDSE,*) 'NEW NLMAX:',NLMAX +#ifdef W3_SCRIP + IF ( IMPROC.EQ.NMPERR.AND.T38 ) & + WRITE(MDSE,*) 'NLMAX,NLMAX_SCRIP=',NLMAX,NLMAX_SCRIP + IF(DO_CHECKING)THEN + NLMAX = MAX (NLMAX, NLMAX_SCRIP) + ELSE + NLMAX = NLMAX_SCRIP + ENDIF + IF ( IMPROC.EQ.NMPERR.AND.T38 ) & + WRITE(MDSE,*) 'NEW NLMAX:',NLMAX +#endif IF(NLMAX.GT.100)THEN WRITE(MDSE,'(/A,I8)') & @@ -2296,11 +2526,13 @@ SUBROUTINE WMGHGH ALLOCATE ( TMPLOG(NX*NY), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) ! -!/DIST ALLOCATE ( LTAG(NLMAX), STAT=ISTAT ) -!/DIST CHECK_ALLOC_STATUS ( ISTAT ) -!/DIST DO JJ=1, NLMAX -!/DIST LTAG(JJ) = JJ + LTAG0 -!/DIST END DO +#ifdef W3_DIST + ALLOCATE ( LTAG(NLMAX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO JJ=1, NLMAX + LTAG(JJ) = JJ + LTAG0 + END DO +#endif ! !!HT: !!HT: After the search range is set, we are actually searching in the @@ -2449,39 +2681,55 @@ SUBROUTINE WMGHGH ! Initialize -!/SCRIP BDIST(JJ) = 9.99E33 +#ifdef W3_SCRIP + BDIST(JJ) = 9.99E33 +#endif ! Notes on variables used here: ! IDST, JDST given by loop, NIDST set above, the rest we need to set here -!/SCRIP NISRC=GRIDS(GSRC)%NX -!/SCRIP KDST=(JDST-1)*NIDST+IDST - -!/SCRIP DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N -!/SCRIP KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) -!/SCRIP JSRC=INT((KSRC-1)/NISRC)+1 -!/SCRIP ISRC=KSRC-(JSRC-1)*NISRC -!/SCRIP IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN +#ifdef W3_SCRIP + NISRC=GRIDS(GSRC)%NX + KDST=(JDST-1)*NIDST+IDST +#endif + +#ifdef W3_SCRIP + DO IPNT=1,ALLWGTS(GSRC)%WGTDATA(KDST)%N + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + IF (ABS(GRIDS(GSRC)%MAPSTA(JSRC,ISRC)).EQ.1) THEN +#endif ! sea point -!/SCRIP BDIST(JJ) = MIN ( BDIST(JJ) , & -!/SCRIP MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) -!/SCRIP ELSE -!/SCRIP IF ( IMPROC.EQ.NMPERR ) & -!/SCRIP WRITE(MDSE,*) & -!/SCRIP 'we masked non-sea points. (coding error)' -!/SCRIP CALL EXTCDE ( 999 ) -!/SCRIP END IF -!/SCRIP END DO +#ifdef W3_SCRIP + BDIST(JJ) = MIN ( BDIST(JJ) , & + MDATAS(GSRC)%MAPBDI(JSRC,ISRC) ) + ELSE + IF ( IMPROC.EQ.NMPERR ) & + WRITE(MDSE,*) & + 'we masked non-sea points. (coding error)' + CALL EXTCDE ( 999 ) + END IF + END DO +#endif ! Pull NR0, etc. from storage... -!/SCRIP NR0 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR0 +#ifdef W3_SCRIP + NR0 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR0 +#endif ! counter of MAPSTA=0 (indicates excluded point) -!/SCRIP NRL = ALLWGTS(GSRC)%WGTDATA(KDST)%NRL +#ifdef W3_SCRIP + NRL = ALLWGTS(GSRC)%WGTDATA(KDST)%NRL +#endif ! counter of MAPSTA=0 (indicates excluded point) ! and MAPST2=0 (indicates land) -!/SCRIP NR1 = ALLWGTS(GSRC)%WGTDATA(KDST)%N +#ifdef W3_SCRIP + NR1 = ALLWGTS(GSRC)%WGTDATA(KDST)%N +#endif ! counter of |MAPSTA|=1 (indicates sea point) -!/SCRIP NR2 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR2 +#ifdef W3_SCRIP + NR2 = ALLWGTS(GSRC)%WGTDATA(KDST)%NR2 +#endif ! counter of |MAPSTA|=2 (indicates boundary point) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2491,7 +2739,9 @@ SUBROUTINE WMGHGH ! Compare results IF(DO_CHECKING)THEN ! then it is OK to compare with the values that we got using the old method -!/T38 WRITE(MDST,*)'STARTING TEST 1' +#ifdef W3_T38 + WRITE(MDST,*)'STARTING TEST 1' +#endif IF(NR0_OM.NE.NR0)THEN IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & ' *** ERROR WMGHGH: NR0_OM,NR0 = ',NR0_OM,NR0 @@ -2520,7 +2770,9 @@ SUBROUTINE WMGHGH BDIST_OM(JJ),BDIST(JJ) CALL EXTCDE ( 999 ) ENDIF -!/T38 WRITE(MDST,*)'PASSED TEST 1' +#ifdef W3_T38 + WRITE(MDST,*)'PASSED TEST 1' +#endif END IF ! (if DO_CHECKING) ! Notes: We are done with the counting. If we didn't use SCRIP to get NR0, @@ -2644,7 +2896,9 @@ SUBROUTINE WMGHGH END IF END DO GSRC=JF -!/T38 WRITE(MDST,'(A,2(I8),A,I8)')'For grid point IDST,JDST = ',IDST,JDST,', we selected GSRC = ',GSRC +#ifdef W3_T38 + WRITE(MDST,'(A,2(I8),A,I8)')'For grid point IDST,JDST = ',IDST,JDST,', we selected GSRC = ',GSRC +#endif !!HT: Data for grid point IDST,JDST in the low-res grid will be taken from !!HT: high-res grid GSRC. @@ -2738,36 +2992,42 @@ SUBROUTINE WMGHGH ! Notes: Weights have already been computed by SCRIP. ! We just need to transfer them to TMPINT and TMPRL -!/SCRIP KDST=(JDST-1)*NIDST+IDST -!/SCRIP NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N -!/SCRIP TMPINT(NRTOT,0) = NLOC -!/SCRIP NISRC=GRIDS(GSRC)%NX +#ifdef W3_SCRIP + KDST=(JDST-1)*NIDST+IDST + NLOC=ALLWGTS(GSRC)%WGTDATA(KDST)%N + TMPINT(NRTOT,0) = NLOC + NISRC=GRIDS(GSRC)%NX +#endif ! Test output -!/SCRIP IF ( IMPROC.EQ.NMPERR.AND.T38 ) THEN -!/SCRIP WRITE(MDST,*)'GSRC,KDST,NLOC = ',GSRC,KDST,NLOC -!/SCRIP ENDIF +#ifdef W3_SCRIP + IF ( IMPROC.EQ.NMPERR.AND.T38 ) THEN + WRITE(MDST,*)'GSRC,KDST,NLOC = ',GSRC,KDST,NLOC + ENDIF +#endif ! Notes: check here that we are sufficiently dimensioned. -!/SCRIP IF ( NLOC .GT. NLMAX ) THEN -!/SCRIP IF ( IMPROC.EQ.NMPERR ) THEN -!/SCRIP WRITE (MDSE,'(/2A,4(1x,I8))') & -!/SCRIP ' *** ERROR WMGHGH: ', & -!/SCRIP ' IDST,JDST,NLOC,NLMAX = ', & -!/SCRIP IDST,JDST,NLOC,NLMAX -!/SCRIP WRITE(MDSE,1021) -!/SCRIP ENDIF -!/SCRIP CALL EXTCDE(1021) -!/SCRIP END IF -!/SCRIP DO IPNT=1,NLOC -!/SCRIP KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) -!/SCRIP JSRC=INT((KSRC-1)/NISRC)+1 -!/SCRIP ISRC=KSRC-(JSRC-1)*NISRC -!/SCRIP TMPINT(NRTOT,IPNT) = GRIDS(GSRC)%MAPFS(JSRC,ISRC) -!/SCRIP TMPRL(NRTOT,IPNT)= & -!/SCRIP ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) ! WX*WY / WTOT -!/SCRIP END DO ! DO IPNT=1,NLOC +#ifdef W3_SCRIP + IF ( NLOC .GT. NLMAX ) THEN + IF ( IMPROC.EQ.NMPERR ) THEN + WRITE (MDSE,'(/2A,4(1x,I8))') & + ' *** ERROR WMGHGH: ', & + ' IDST,JDST,NLOC,NLMAX = ', & + IDST,JDST,NLOC,NLMAX + WRITE(MDSE,1021) + ENDIF + CALL EXTCDE(1021) + END IF + DO IPNT=1,NLOC + KSRC=ALLWGTS(GSRC)%WGTDATA(KDST)%K(IPNT) + JSRC=INT((KSRC-1)/NISRC)+1 + ISRC=KSRC-(JSRC-1)*NISRC + TMPINT(NRTOT,IPNT) = GRIDS(GSRC)%MAPFS(JSRC,ISRC) + TMPRL(NRTOT,IPNT)= & + ALLWGTS(GSRC)%WGTDATA(KDST)%W(IPNT) ! WX*WY / WTOT + END DO ! DO IPNT=1,NLOC +#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !...End block of code for "computing" weights using new method @@ -2779,7 +3039,9 @@ SUBROUTINE WMGHGH IF (DO_CHECKING)THEN ! compare with the values that we got using the old method -!/T38 WRITE(MDST,*)'STARTING TEST 2' +#ifdef W3_T38 + WRITE(MDST,*)'STARTING TEST 2' +#endif if (NLOC.NE.NLOC_OM) THEN IF ( IMPROC.EQ.NMPERR )WRITE (MDSE,'(/1A,2(I8))') & ' *** ERROR WMGHGH: NLOC,NLOC_OM = ',NLOC,NLOC_OM @@ -2812,7 +3074,9 @@ SUBROUTINE WMGHGH IF(ISTOP.EQ.1)THEN CALL EXTCDE ( 999 ) END IF -!/T38 WRITE(MDST,*)'PASSED TEST 2' +#ifdef W3_T38 + WRITE(MDST,*)'PASSED TEST 2' +#endif END IF ! (if both grids are regular grids) @@ -2825,7 +3089,9 @@ SUBROUTINE WMGHGH END DO LOWRANK_I ! DO IDST=1, NX END DO LOWRANK_J ! DO JDST=1, NY -!/T38 WRITE(MDST,*)'WMGHGH Section 2.b.6 completed.' +#ifdef W3_T38 + WRITE(MDST,*)'WMGHGH Section 2.b.6 completed.' +#endif ! Notes: We are done with the counting. If we didn't use SCRIP to get ! TMPINT, TMPRL, then we need to set them using the _OM variables. @@ -2835,7 +3101,9 @@ SUBROUTINE WMGHGH TMPRL=TMPRL_OM END IF -!/T WRITE (MDST,9023) GDST, NRTOT +#ifdef W3_T + WRITE (MDST,9023) GDST, NRTOT +#endif ! ! 2.c Set up masks based on stencil width of scheme and inferred land ! 2.c.1 Inferred land @@ -2885,10 +3153,18 @@ SUBROUTINE WMGHGH STMASK(:,0) = STMASK(:,NX) STMASK(:,NX+1) = STMASK(:,1) -!/PR0 NIT = 0 -!/PR1 NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 -!/UQ NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 -!/UNO NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#ifdef W3_PR0 + NIT = 0 +#endif +#ifdef W3_PR1 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 +#endif +#ifdef W3_UQ + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif +#ifdef W3_UNO + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif IDSTLA=2 IDSTHA=NX-1 @@ -2956,8 +3232,10 @@ SUBROUTINE WMGHGH ! 2.d Set up mapping for staging data ! 2.d.1 Set counters / required array sizes ! -!/SHRD ISPROC = 1 -!/SHRD ISPRO2 = 1 +#ifdef W3_SHRD + ISPROC = 1 + ISPRO2 = 1 +#endif I1 = 0 I2 = 0 I3 = 0 @@ -2969,7 +3247,9 @@ SUBROUTINE WMGHGH HGSTGE(GDST,JJ)%NTOT = HGSTGE(GDST,JJ)%NTOT + 1 ISEA = TMPINT(ILOC,-2) CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/DIST ISPROC = ISPROC + CROOT - 1 +#ifdef W3_DIST + ISPROC = ISPROC + CROOT - 1 +#endif ! I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 IF ( TMPLOG(ILOC) ) I2(JJ,ISPROC) = I2(JJ,ISPROC) + 1 @@ -3009,17 +3289,21 @@ SUBROUTINE WMGHGH HGSTGE(GDST,GSRC)%NSMX, & HGSTGE(GDST,GSRC)%NREC), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/T3 HGSTGE(GDST,GSRC)%LJSEA = -1 -!/T3 HGSTGE(GDST,GSRC)%NRAVG = -1 -!/T3 HGSTGE(GDST,GSRC)%IMPSRC = -1 -!/T3 HGSTGE(GDST,GSRC)%ITAG = -1 -!/T3 HGSTGE(GDST,GSRC)%WGTH = -1. +#ifdef W3_T3 + HGSTGE(GDST,GSRC)%LJSEA = -1 + HGSTGE(GDST,GSRC)%NRAVG = -1 + HGSTGE(GDST,GSRC)%IMPSRC = -1 + HGSTGE(GDST,GSRC)%ITAG = -1 + HGSTGE(GDST,GSRC)%WGTH = -1. +#endif END IF IF ( HGSTGE(GDST,GSRC)%NSND .GT. 0 ) THEN ALLOCATE ( HGSTGE(GDST,GSRC)%ISEND (HGSTGE(GDST,GSRC)%NSND,5), & STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/T4 HGSTGE(GDST,GSRC)%ISEND = -1 +#ifdef W3_T4 + HGSTGE(GDST,GSRC)%ISEND = -1 +#endif END IF HGSTGE(GDST,GSRC)%INIT = .TRUE. END DO @@ -3038,8 +3322,10 @@ SUBROUTINE WMGHGH JJ = TMPINT(ILOC,-1) NR0 = TMPINT(ILOC, 0) CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/DIST ISPROC = ISPROC + CROOT - 1 -!/DIST FLGREC = ISPROC .EQ. IMPROC +#ifdef W3_DIST + ISPROC = ISPROC + CROOT - 1 + FLGREC = ISPROC .EQ. IMPROC +#endif ! IF ( TMPLOG(ILOC) ) THEN I1(JJ,ISPROC) = I1(JJ,ISPROC) + 1 @@ -3053,7 +3339,9 @@ SUBROUTINE WMGHGH HGSTGE(GDST,JJ)%LJSEA(IREC) = JSEA HGSTGE(GDST,JJ)%NRAVG(IREC) = NR0 HGSTGE(GDST,JJ)%WGTH(IREC,:NR0) = TMPRL(ILOC,1:NR0) -!/DIST HGSTGE(GDST,JJ)%ITAG(IREC,:NR0) = LTAG(:NR0) +#ifdef W3_DIST + HGSTGE(GDST,JJ)%ITAG(IREC,:NR0) = LTAG(:NR0) +#endif END IF DO IJ=1, NR0 @@ -3071,104 +3359,128 @@ SUBROUTINE WMGHGH ISND = I4(JJ) END IF HGSTGE(GDST,JJ)%ISEND(ISND,1) = JSEA -!/DIST HGSTGE(GDST,JJ)%ISEND(ISND,2) = ISPROC +#ifdef W3_DIST + HGSTGE(GDST,JJ)%ISEND(ISND,2) = ISPROC +#endif HGSTGE(GDST,JJ)%ISEND(ISND,3) = IREC HGSTGE(GDST,JJ)%ISEND(ISND,4) = IJ -!/DIST HGSTGE(GDST,JJ)%ISEND(ISND,5) = LTAG(IJ) +#ifdef W3_DIST + HGSTGE(GDST,JJ)%ISEND(ISND,5) = LTAG(IJ) +#endif END IF END DO ! -!/DIST LTAG = LTAG + NR0 -!/DIST LTAG0 = LTAG0 + NR0 +#ifdef W3_DIST + LTAG = LTAG + NR0 + LTAG0 = LTAG0 + NR0 +#endif ! END DO ! ! 2.e Adjust FLAGST using MAPTST ! -!/T ALLOCATE ( MAPST(NY,NX), STAT=ISTAT ) -!/T CHECK_ALLOC_STATUS ( ISTAT ) -!/T MAPST = '-' +#ifdef W3_T + ALLOCATE ( MAPST(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + MAPST = '-' +#endif ! DO ISEA=1, NSEA IDST = MAPSF(ISEA,1) JDST = MAPSF(ISEA,2) IF ( MAPTST(JDST,IDST) .GT. 0 ) FLAGST(ISEA) = .NOT. FLGHG1 -!/T IF ( FLAGST(ISEA) ) THEN -!/T MAPST(JDST,IDST) = 'O' -!/T ELSE -!/T MAPST(JDST,IDST) = 'X' -!/T END IF +#ifdef W3_T + IF ( FLAGST(ISEA) ) THEN + MAPST(JDST,IDST) = 'O' + ELSE + MAPST(JDST,IDST) = 'X' + END IF +#endif END DO ! ! 2.f Test output map ! -!/T WRITE (MDST,9025) 'MAPTST' -!/T DO JDST=NY,1 , -1 -!/T WRITE (MDST,9026) MAPTST(JDST,:) + 88*INFLND(JDST,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9025) 'MAPTST' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPTST(JDST,:) + 88*INFLND(JDST,:) + END DO +#endif ! -!/T WRITE (MDST,9025) 'MAPSTA' -!/T DO JDST=NY,1 , -1 -!/T WRITE (MDST,9026) MAPSTA(JDST,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9025) 'MAPSTA' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPSTA(JDST,:) + END DO +#endif ! -!/T WRITE (MDST,9025) 'MAPST2' -!/T DO JDST=NY,1 , -1 -!/T WRITE (MDST,9026) MAPST2(JDST,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9025) 'MAPST2' + DO JDST=NY,1 , -1 + WRITE (MDST,9026) MAPST2(JDST,:) + END DO +#endif ! -!/T WRITE (MDST,9025) 'FLAGST' -!/T DO JDST=NY,1 , -1 -!/T WRITE (MDST,9027) MAPST(JDST,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9025) 'FLAGST' + DO JDST=NY,1 , -1 + WRITE (MDST,9027) MAPST(JDST,:) + END DO +#endif ! DEALLOCATE ( MAPTST, INFLND, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) -!/T DEALLOCATE ( MAPST, STAT=ISTAT ) -!/T CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_T + DEALLOCATE ( MAPST, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif ! ! 2.g Test output receiving ! -!/T3 DO GSRC=1, NRGRD -!/T3 NR0 = HGSTGE(GDST,GSRC)%NREC -!/T3 IF ( NR0 .EQ. 0 ) THEN -!/T3 WRITE (MDST,9030) GSRC -!/T3 ELSE -!/T3 WRITE (MDST,9031) GSRC, NR0 -!/T3 DO IREC=1, NR0 -!/T3 JSEA = HGSTGE(GDST,GSRC)%LJSEA(IREC) -!/T3 NRTOT = HGSTGE(GDST,GSRC)%NRAVG(IREC) -!/T3 IF ( NRTOT .LE. 15 ) THEN -!/T3 WRITE (MDST,9032) JSEA, NRTOT, & -!/T3 HGSTGE(GDST,GSRC)%WGTH(IREC,:NRTOT) -!/T3 ELSE -!/T3 WRITE (MDST,9032) JSEA, NRTOT, & -!/T3 HGSTGE(GDST,GSRC)%WGTH(IREC,1:15) -!/T3 WRITE (MDST,9033) & -!/T3 HGSTGE(GDST,GSRC)%WGTH(IREC,16:NRTOT) -!/T3 END IF -!/T3 WRITE (MDST,9034) & -!/T3 HGSTGE(GDST,GSRC)%IMPSRC(IREC,1:NRTOT) -!/T3 WRITE (MDST,9034) & -!/T3 HGSTGE(GDST,GSRC)%ITAG(IREC,1:NRTOT) -!/T3 END DO -!/T3 END IF -!/T3 END DO +#ifdef W3_T3 + DO GSRC=1, NRGRD + NR0 = HGSTGE(GDST,GSRC)%NREC + IF ( NR0 .EQ. 0 ) THEN + WRITE (MDST,9030) GSRC + ELSE + WRITE (MDST,9031) GSRC, NR0 + DO IREC=1, NR0 + JSEA = HGSTGE(GDST,GSRC)%LJSEA(IREC) + NRTOT = HGSTGE(GDST,GSRC)%NRAVG(IREC) + IF ( NRTOT .LE. 15 ) THEN + WRITE (MDST,9032) JSEA, NRTOT, & + HGSTGE(GDST,GSRC)%WGTH(IREC,:NRTOT) + ELSE + WRITE (MDST,9032) JSEA, NRTOT, & + HGSTGE(GDST,GSRC)%WGTH(IREC,1:15) + WRITE (MDST,9033) & + HGSTGE(GDST,GSRC)%WGTH(IREC,16:NRTOT) + END IF + WRITE (MDST,9034) & + HGSTGE(GDST,GSRC)%IMPSRC(IREC,1:NRTOT) + WRITE (MDST,9034) & + HGSTGE(GDST,GSRC)%ITAG(IREC,1:NRTOT) + END DO + END IF + END DO +#endif ! ! 2.h Test output sending ! -!/T4 DO GSRC=1, NRGRD -!/T4 NR0 = HGSTGE(GDST,GSRC)%NSND -!/T4 IF ( NR0 .EQ. 0 ) THEN -!/T4 WRITE (MDST,9040) GSRC -!/T4 ELSE -!/T4 WRITE (MDST,9041) GSRC, NR0 -!/T4 DO ISND=1, NR0 -!/T4 WRITE (MDST,9042) HGSTGE(GDST,GSRC)%ISEND(ISND,:) -!/T4 END DO -!/T4 END IF -!/T4 END DO +#ifdef W3_T4 + DO GSRC=1, NRGRD + NR0 = HGSTGE(GDST,GSRC)%NSND + IF ( NR0 .EQ. 0 ) THEN + WRITE (MDST,9040) GSRC + ELSE + WRITE (MDST,9041) GSRC, NR0 + DO ISND=1, NR0 + WRITE (MDST,9042) HGSTGE(GDST,GSRC)%ISEND(ISND,:) + END DO + END IF + END DO +#endif ! ! 2.i Final clean up ! @@ -3181,39 +3493,47 @@ SUBROUTINE WMGHGH CHECK_DEALLOC_STATUS ( ISTAT ) END IF -!/DIST DEALLOCATE ( LTAG, STAT=ISTAT ) -!/DIST CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_DIST + DEALLOCATE ( LTAG, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif ! ! Notes: We are done with this dst (low rank) grid, so we deallocate ALLWGTS . ! This is important because ALLWGTS will be allocated again for the next ! dst grid. -!/SCRIP DO JJ=1, GRDHGH(GDST,0) -!/SCRIP GSRC = GRDHGH(GDST,JJ) -!/SCRIP DO KDST=1,DST_GRID_SIZE -!/SCRIP DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIP DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIP END DO -!/SCRIP DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) -!/SCRIP END DO -!/SCRIP DEALLOCATE ( ALLWGTS, STAT=ISTAT ) -!/SCRIP CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_SCRIP + DO JJ=1, GRDHGH(GDST,0) + GSRC = GRDHGH(GDST,JJ) + DO KDST=1,DST_GRID_SIZE + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%W, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA(KDST)%K, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE ( ALLWGTS(GSRC)%WGTDATA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END DO + DEALLOCATE ( ALLWGTS, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif END IF ! IF ( GRDHGH(GDST,0) ... -!/T38 CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = END_TIME - BEG_TIME(2) -!/T38 WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " TOOK ", ELAPSED_TIME, " MSEC" +#ifdef W3_T38 + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(2) + WRITE(NMYOUT,*) "WMGHGH, LOOP LOWRANK_GRID, GDST= ", GDST, " TOOK ", ELAPSED_TIME, " MSEC" +#endif END DO LOWRANK_GRID ! If SCRIPNC and L_STOP, then we are done IF ( LSCRIPNC .AND. L_STOP ) THEN ! WW3 processes wait here till all have finished -!/MPI CALL MPI_BARRIER( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! This is not a true error, so exit code is zero WRITE( MDSE, '(A,I4.4,A)' ) 'IMPROC=',IMPROC, & ': STOP_SCRIP option invoked: '// & @@ -3223,48 +3543,64 @@ SUBROUTINE WMGHGH DEALLOCATE ( I1, I2, I3, I4, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) -!/MPIBDI DEALLOCATE ( NX_SIZE, IRQ, MSTAT, STAT=ISTAT ) -!/MPIBDI CHECK_DEALLOC_STATUS ( ISTAT ) +#ifdef W3_MPIBDI + DEALLOCATE ( NX_SIZE, IRQ, MSTAT, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif DEALLOCATE ( NX_BEG, NX_END, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) ! ! 2.j Test output counters ! -!/T WRITE (MDST,9028) 'NTOT' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NTOT -!/T END DO -! -!/T WRITE (MDST,9028) 'NREC' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NREC -!/T END DO -! -!/T WRITE (MDST,9028) 'NRC1' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NRC1 -!/T END DO -! -!/T WRITE (MDST,9028) 'NSND' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NSND -!/T END DO -! -!/T WRITE (MDST,9028) 'NSN1' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NSN1 -!/T END DO -! -!/T WRITE (MDST,9028) 'NSMX' -!/T DO JJ=1, NRGRD -!/T WRITE (MDST,9029) HGSTGE(JJ,:)%NSMX -!/T END DO -! -!/T38 CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) -!/T38 ELAPSED_TIME = END_TIME - BEG_TIME(1) -!/T38 WRITE(NMYOUT,*) "WMGHGH, ALL TOOK ", ELAPSED_TIME, " MSEC" +#ifdef W3_T + WRITE (MDST,9028) 'NTOT' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NTOT + END DO +#endif +! +#ifdef W3_T + WRITE (MDST,9028) 'NREC' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NREC + END DO +#endif +! +#ifdef W3_T + WRITE (MDST,9028) 'NRC1' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NRC1 + END DO +#endif +! +#ifdef W3_T + WRITE (MDST,9028) 'NSND' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSND + END DO +#endif +! +#ifdef W3_T + WRITE (MDST,9028) 'NSN1' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSN1 + END DO +#endif +! +#ifdef W3_T + WRITE (MDST,9028) 'NSMX' + DO JJ=1, NRGRD + WRITE (MDST,9029) HGSTGE(JJ,:)%NSMX + END DO +#endif +! +#ifdef W3_T38 + CALL DATE_AND_TIME (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + END_TIME = ((DATE_TIME(5)*60 + DATE_TIME(6))*60 + DATE_TIME(7))*1000 + DATE_TIME(8) + ELAPSED_TIME = END_TIME - BEG_TIME(1) + WRITE(NMYOUT,*) "WMGHGH, ALL TOOK ", ELAPSED_TIME, " MSEC" +#endif RETURN ! @@ -3274,37 +3610,49 @@ SUBROUTINE WMGHGH ' GRDHGH NOT YET ALLOCATED, CALL WMGLOW FIRST'/) 1020 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & ' TMPINT AND TMPRL TOO SMALL (w/out SCRIP)'/) -!/SCRIP 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & -!/SCRIP ' TMPINT AND TMPRL TOO SMALL (w/SCRIP) '/) -! -!/T 9010 FORMAT ( ' TEST WMGHGH : INITIALIZE BOUNDARY DISTANCE MAPS') -!/T 9011 FORMAT ( ' GRID = ',I3,' RANK = ',I3, & -!/T ' NBI = ',I6) -!/T 9012 FORMAT ( ' *** MAP NOT NEEDED ***') -!/T 9013 FORMAT ( ' TEST WMGHGH : FINAL MAP ') -!/T 9014 FORMAT (2x,65I2) +#ifdef W3_SCRIP + 1021 FORMAT (/' *** WAVEWATCH III ERROR IN WMGHGH : *** '/ & + ' TMPINT AND TMPRL TOO SMALL (w/SCRIP) '/) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMGHGH : INITIALIZE BOUNDARY DISTANCE MAPS') + 9011 FORMAT ( ' GRID = ',I3,' RANK = ',I3, & + ' NBI = ',I6) + 9012 FORMAT ( ' *** MAP NOT NEEDED ***') + 9013 FORMAT ( ' TEST WMGHGH : FINAL MAP ') + 9014 FORMAT (2x,65I2) +#endif !/ -!/T 9020 FORMAT ( ' TEST WMGHGH : GRID',I3,' HAS',I3,' DATA SOURCES') -!/T 9021 FORMAT ( ' NO PROCESSING REQUIRED') -!/T 9022 FORMAT ( ' TEST WMGHGH : GRID',I3,' COVERS ',4I8) -!/T 9023 FORMAT ( ' TEST WMGHGH : GRID',I3, & -!/T ', NR OF POINTS TO PROCESS:',I5) -!/T 9025 FORMAT ( ' TEST WMGHGH : FINAL ',A) -!/T 9026 FORMAT (2X,65I2) -!/T 9027 FORMAT (2X,65A2) -! -!/T 9028 FORMAT ( ' TEST WMGHGH : COUNTERS ',A) -!/T 9029 FORMAT (2x,20I6) -! -!/T3 9030 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO RECEIVE') -!/T3 9031 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', RECEIVING ',I6) -!/T3 9032 FORMAT ( 2X,I10,I6,15F6.2) -!/T3 9033 FORMAT ( 18X,15F6.2) -!/T3 9034 FORMAT ( 18X,15I6) -! -!/T4 9040 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO SEND') -!/T4 9041 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', SENDING ',I6) -!/T4 9042 FORMAT ( 12X,I10,4I6) +#ifdef W3_T + 9020 FORMAT ( ' TEST WMGHGH : GRID',I3,' HAS',I3,' DATA SOURCES') + 9021 FORMAT ( ' NO PROCESSING REQUIRED') + 9022 FORMAT ( ' TEST WMGHGH : GRID',I3,' COVERS ',4I8) + 9023 FORMAT ( ' TEST WMGHGH : GRID',I3, & + ', NR OF POINTS TO PROCESS:',I5) + 9025 FORMAT ( ' TEST WMGHGH : FINAL ',A) + 9026 FORMAT (2X,65I2) + 9027 FORMAT (2X,65A2) +#endif +! +#ifdef W3_T + 9028 FORMAT ( ' TEST WMGHGH : COUNTERS ',A) + 9029 FORMAT (2x,20I6) +#endif +! +#ifdef W3_T3 + 9030 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO RECEIVE') + 9031 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', RECEIVING ',I6) + 9032 FORMAT ( 2X,I10,I6,15F6.2) + 9033 FORMAT ( 18X,15F6.2) + 9034 FORMAT ( 18X,15I6) +#endif +! +#ifdef W3_T4 + 9040 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', NO DATA TO SEND') + 9041 FORMAT ( ' TEST WMGHG : FROM GRID',I3,', SENDING ',I6) + 9042 FORMAT ( 12X,I10,4I6) +#endif !/ !/ End of WMGHGH ----------------------------------------------------- / !/ @@ -3404,7 +3752,9 @@ SUBROUTINE WMGEQL ! USE W3SERVMD, ONLY: EXTCDE ! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -3420,8 +3770,12 @@ SUBROUTINE WMGEQL NR, NT, NA, NTL, JJ, NIT, NG, NOUT, & ISEA, JSEA, ISPROC, ITAG, TGRP, & EXTRA, IP, NP -!/T7 INTEGER :: IA -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_T7 + INTEGER :: IA +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: MAP3D(:,:,:), NREC(:), NSND(:), & NTPP(:), MAPOUT(:,:) REAL :: FACTOR, XSL, XSH, YSL, YSH, XA, YA, & @@ -3434,8 +3788,10 @@ SUBROUTINE WMGEQL LOGICAL :: CHANGE, XEXPND, YEXPND LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:), & MASKA(:,:), MASKI(:,:) -!/T5 CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) -!/T5 CHARACTER(LEN=18) :: DSTR +#ifdef W3_T5 + CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) + CHARACTER(LEN=18) :: DSTR +#endif ! TYPE STORE INTEGER :: NTOT, NFIN @@ -3448,7 +3804,9 @@ SUBROUTINE WMGEQL ! TYPE(STORE), ALLOCATABLE :: STORES(:,:) !/ -!/S CALL STRACE (IENT, 'WMGEQL') +#ifdef W3_S + CALL STRACE (IENT, 'WMGEQL') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -3478,34 +3836,46 @@ SUBROUTINE WMGEQL END IF ITAG = 0 ! -!/SMC !! Check GTYPE for all grids. -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " WMGEQL GTYPE:", & -!/SMC ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#ifdef W3_SMC + !! Check GTYPE for all grids. + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " WMGEQL GTYPE:", & + ( GRIDS(I)%GTYPE, I=1, NRGRD ) +#endif ! ! -------------------------------------------------------------------- / ! 1. Grid point relations and temp data storage ! 1.a Outer loop over all grids ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! DO I=1, NRGRD -!/T WRITE (MDST,9011) I, GRANK(I) +#ifdef W3_T + WRITE (MDST,9011) I, GRANK(I) +#endif ! ! 1.b Find grids with same rank ! NR = 0 ! -!/SMC !! SMC grids use WMSMCEQL for equal ranked grids. JGLi23Mar2021 -!/SMC IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) CYCLE +#ifdef W3_SMC + !! SMC grids use WMSMCEQL for equal ranked grids. JGLi23Mar2021 + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) CYCLE +#endif ! DO J=1, NRGRD IF ( GRANK(I).NE.GRANK(J) .OR. I.EQ.J ) CYCLE ! -!/SMC IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) CYCLE +#ifdef W3_SMC + IF( GRIDS(J)%GTYPE .EQ. SMCTYPE ) CYCLE +#endif ! -!/T WRITE (MDST,9012) J +#ifdef W3_T + WRITE (MDST,9012) J +#endif SHRANK(I,J) = .TRUE. NR = NR + 1 END DO @@ -3516,7 +3886,9 @@ SUBROUTINE WMGEQL !..notes: we will reach this point even if there are no equal rank grids -!/T IF ( NR .EQ. 0 ) WRITE (MDST,9013) 'NO GRIDS WITH SAME RANK' +#ifdef W3_T + IF ( NR .EQ. 0 ) WRITE (MDST,9013) 'NO GRIDS WITH SAME RANK' +#endif IF ( NR .EQ. 0 ) CYCLE !..notes: we will not reach this point if are no equal rank grids. that makes it a good place to check against grid type @@ -3667,7 +4039,9 @@ SUBROUTINE WMGEQL ! NT = NT + 1 NA = 0 -!/SHRD ISPROC = 1 +#ifdef W3_SHRD + ISPROC = 1 +#endif STORES(I,J)%IX(NT) = IX STORES(I,J)%IY(NT) = IY ! @@ -3680,7 +4054,9 @@ SUBROUTINE WMGEQL ISEA = GRIDS(J)%MAPFS(JY,JX) IF ( ISEA .EQ. 0 ) THEN JSEA = 0 -!/MPI ISPROC = 1 +#ifdef W3_MPI + ISPROC = 1 +#endif ELSE CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) END IF @@ -3722,7 +4098,9 @@ SUBROUTINE WMGEQL ! 2. Generate open edge distance maps ! 2.a Base map based on MAPSTA only, time step not included. ! -!/T WRITE (MDST,9020) I +#ifdef W3_T + WRITE (MDST,9020) I +#endif ! ALLOCATE ( MDATAS(I)%MAPODI(NY,NX), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) @@ -3759,8 +4137,10 @@ SUBROUTINE WMGEQL .NOT.STORES(I,J)%FLA(JJ) .AND. & STORES(I,J)%NAV(JJ).GT.0 ) THEN MAPODI(IY,IX) = 0. -!/O13 IF ( IMPROC.EQ.NMPERR ) & -!/O13 WRITE (MDSE,1020) I, IX, 1 +#ifdef W3_O13 + IF ( IMPROC.EQ.NMPERR ) & + WRITE (MDSE,1020) I, IX, 1 +#endif END IF ELSE MASKA(IY,IX) = STORES(I,J)%FLA(JJ) @@ -3785,7 +4165,9 @@ SUBROUTINE WMGEQL MAPODI(IY ,IX-1) .GE. 0. .OR. & MAPODI(IY ,IX+1) .GE. 0. ) ) THEN MASKI(IY,IX) = .TRUE. -!/O12 IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) I, IX, IY +#ifdef W3_O12 + IF ( IMPROC.EQ.NMPERR ) WRITE (MDSE,1020) I, IX, IY +#endif END IF END DO END DO @@ -3801,10 +4183,18 @@ SUBROUTINE WMGEQL ! ! 2.d Mask out influenced edge ! -!/PR0 NIT = 0 -!/PR1 NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 -!/UQ NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 -!/UNO NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#ifdef W3_PR0 + NIT = 0 +#endif +#ifdef W3_PR1 + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 +#endif +#ifdef W3_UQ + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif +#ifdef W3_UNO + NIT = ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif ! IF ( ICLOSE.NE.ICLOSE_NONE ) THEN IXL = 1 @@ -3976,15 +4366,17 @@ SUBROUTINE WMGEQL ! ! 2.g Test output ! -!/T NP = 1 + (NX-1)/65 -!/T DO IP=1, NP -!/T IXL = 1 + (IP-1)*65 -!/T IXH = MIN( NX, IP*65 ) -!/T WRITE (MDST,9024) IXL, IXH -!/T DO IY=NY,1 , -1 -!/T WRITE (MDST,9025) NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) -!/T END DO -!/T END DO +#ifdef W3_T + NP = 1 + (NX-1)/65 + DO IP=1, NP + IXL = 1 + (IP-1)*65 + IXH = MIN( NX, IP*65 ) + WRITE (MDST,9024) IXL, IXH + DO IY=NY,1 , -1 + WRITE (MDST,9025) NINT(MAPODI(IY,IXL:IXH)*SIG(1)/DTMAX) + END DO + END DO +#endif ! ! ... End of loop in 1.a ! @@ -3999,7 +4391,9 @@ SUBROUTINE WMGEQL ! DO I=1, NRGRD IF ( .NOT. DOGRID(I) ) CYCLE -!/T WRITE (MDST,9030) I +#ifdef W3_T + WRITE (MDST,9030) I +#endif ! CALL W3SETG ( I, MDSE, MDST ) CALL W3SETO ( I, MDSE, MDST ) @@ -4016,7 +4410,9 @@ SUBROUTINE WMGEQL ! DO J=1, NRGRD IF ( .NOT. SHRANK(I,J) ) CYCLE -!/T WRITE (MDST,9031) J +#ifdef W3_T + WRITE (MDST,9031) J +#endif MAPODI => MDATAS(J)%MAPODI ! DO JJ=1, STORES(I,J)%NTOT @@ -4026,9 +4422,13 @@ SUBROUTINE WMGEQL MAP3D(IY,IX,-2) = MAPFS(IY,IX) IF ( MAP3D(IY,IX,-2) .NE. 0 ) THEN MAP3D(IY,IX,-3) = 1 + (MAP3D(IY,IX,-2)-1)/NAPROC -!/SHRD MAP3D(IY,IX,-4) = 1 -!/MPI MAP3D(IY,IX,-4) = MAP3D(IY,IX,-2) - & -!/MPI (MAP3D(IY,IX,-3)-1)*NAPROC + CROOT - 1 +#ifdef W3_SHRD + MAP3D(IY,IX,-4) = 1 +#endif +#ifdef W3_MPI + MAP3D(IY,IX,-4) = MAP3D(IY,IX,-2) - & + (MAP3D(IY,IX,-3)-1)*NAPROC + CROOT - 1 +#endif END IF IF ( WGT3D(IY,IX,0).GE.0. .AND. MAPSTA(IY,IX).NE.0. .AND. & STORES(I,J)%NAV(JJ).GT.0 ) THEN @@ -4044,7 +4444,9 @@ SUBROUTINE WMGEQL END DO ! STORES(I,J)%NFIN = SUM(MAP3D(:,:,J)) -!/T WRITE (MDST,9032) STORES(I,J)%NFIN, STORES(I,J)%NTOT +#ifdef W3_T + WRITE (MDST,9032) STORES(I,J)%NFIN, STORES(I,J)%NTOT +#endif ! END DO ! @@ -4130,13 +4532,15 @@ SUBROUTINE WMGEQL ! ! 3.d Test and error output ! -!/T WRITE (MDST,9033) NTL, NG, NOUT -!/T WRITE (MDST,9034) NREC -!/T WRITE (MDST,9035) NSND -!/T WRITE (MDST,9036) -!/T DO IY=NY,1 , -1 -!/T WRITE (MDST,9037) MAP3D(IY,:,-1) -!/T END DO +#ifdef W3_T + WRITE (MDST,9033) NTL, NG, NOUT + WRITE (MDST,9034) NREC + WRITE (MDST,9035) NSND + WRITE (MDST,9036) + DO IY=NY,1 , -1 + WRITE (MDST,9037) MAP3D(IY,:,-1) + END DO +#endif ! IF ( NOUT .GT. 0 ) THEN IF ( IMPROC.EQ.NMPERR ) THEN @@ -4178,38 +4582,40 @@ SUBROUTINE WMGEQL DEALLOCATE ( MAPOUT, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) ! -!/T7 WRITE (MDST,9330) I -!/T7 DO J=1, NRGRD -!/T7 IF ( .NOT. SHRANK(I,J) ) THEN -!/T7 IF ( I .NE. J ) WRITE (MDST,9331) J -!/T7 CYCLE -!/T7 END IF -!/T7 WRITE (MDST,9332) J, STORES(I,J)%NFIN, I, J -!/T7 IF ( STORES(I,J)%NFIN .EQ. 0 ) CYCLE -!/T7 NTL = 0 -!/T7 DO JJ=1, STORES(I,J)%NTOT -!/T7 IX = STORES(I,J)%IX(JJ) -!/T7 IY = STORES(I,J)%IY(JJ) -!/T7 IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE -!/T7 NTL = NTL + 1 -!/T7 NA = STORES(I,J)%NAV(JJ) -!/T7 WRITE (MDST,9333) NTL, IX, IY, MAP3D(IY,IX,-2), & -!/T7 MAP3D(IY,IX,-3), MAP3D(IY,IX,-4), & -!/T7 WGT3D(IY,IX,0), WGT3D(IY,IX,J), NA, & -!/T7 STORES(I,J)%ISS(JJ,1), & -!/T7 STORES(I,J)%JSS(JJ,1), & -!/T7 STORES(I,J)%IPS(JJ,1), & -!/T7 STORES(I,J)%AWG(JJ,1), & -!/T7 STORES(I,J)%ITG(JJ,1) -!/T7 DO IA=2, NA -!/T7 WRITE (MDST,9334) STORES(I,J)%ISS(JJ,IA), & -!/T7 STORES(I,J)%JSS(JJ,IA), & -!/T7 STORES(I,J)%IPS(JJ,IA), & -!/T7 STORES(I,J)%AWG(JJ,IA), & -!/T7 STORES(I,J)%ITG(JJ,IA) -!/T7 END DO -!/T7 END DO -!/T7 END DO +#ifdef W3_T7 + WRITE (MDST,9330) I + DO J=1, NRGRD + IF ( .NOT. SHRANK(I,J) ) THEN + IF ( I .NE. J ) WRITE (MDST,9331) J + CYCLE + END IF + WRITE (MDST,9332) J, STORES(I,J)%NFIN, I, J + IF ( STORES(I,J)%NFIN .EQ. 0 ) CYCLE + NTL = 0 + DO JJ=1, STORES(I,J)%NTOT + IX = STORES(I,J)%IX(JJ) + IY = STORES(I,J)%IY(JJ) + IF ( MAP3D(IY,IX,J) .EQ. 0 ) CYCLE + NTL = NTL + 1 + NA = STORES(I,J)%NAV(JJ) + WRITE (MDST,9333) NTL, IX, IY, MAP3D(IY,IX,-2), & + MAP3D(IY,IX,-3), MAP3D(IY,IX,-4), & + WGT3D(IY,IX,0), WGT3D(IY,IX,J), NA, & + STORES(I,J)%ISS(JJ,1), & + STORES(I,J)%JSS(JJ,1), & + STORES(I,J)%IPS(JJ,1), & + STORES(I,J)%AWG(JJ,1), & + STORES(I,J)%ITG(JJ,1) + DO IA=2, NA + WRITE (MDST,9334) STORES(I,J)%ISS(JJ,IA), & + STORES(I,J)%JSS(JJ,IA), & + STORES(I,J)%IPS(JJ,IA), & + STORES(I,J)%AWG(JJ,IA), & + STORES(I,J)%ITG(JJ,IA) + END DO + END DO + END DO +#endif ! ! -------------------------------------------------------------------- / ! 4. Save data base as needed in EQSTGE @@ -4222,7 +4628,9 @@ SUBROUTINE WMGEQL EQSTGE(I,I)%WGHT, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) EQSTGE(I,I)%NREC = 0 -!/T WRITE (MDST,9040) I, I +#ifdef W3_T + WRITE (MDST,9040) I, I +#endif END IF ! IF ( NREC(I) .GT. 0 ) THEN @@ -4231,7 +4639,9 @@ SUBROUTINE WMGEQL EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) EQSTGE(I,I)%NREC = NREC(I) -!/T WRITE (MDST,9041) I, I, NREC(I) +#ifdef W3_T + WRITE (MDST,9041) I, I, NREC(I) +#endif END IF ! ! 4.a.1 Local counters, arrays weights etc. (grid 'J' receive) @@ -4248,7 +4658,9 @@ SUBROUTINE WMGEQL CHECK_DEALLOC_STATUS ( ISTAT ) EQSTGE(I,J)%NREC = 0 EQSTGE(I,J)%NAVMAX = 1 -!/T WRITE (MDST,9042) I, J +#ifdef W3_T + WRITE (MDST,9042) I, J +#endif END IF ! IF ( NREC(J) .GT. 0 ) THEN @@ -4264,7 +4676,9 @@ SUBROUTINE WMGEQL EQSTGE(I,J)%RTG(NREC(J),NA), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) EQSTGE(I,J)%NREC = NREC(J) -!/T WRITE (MDST,9043) I, J, NREC(J), NA +#ifdef W3_T + WRITE (MDST,9043) I, J, NREC(J), NA +#endif END IF ! IF ( EQSTGE(I,J)%NSND .NE. 0 ) THEN @@ -4273,7 +4687,9 @@ SUBROUTINE WMGEQL EQSTGE(I,J)%SIP , EQSTGE(I,J)%STG, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) EQSTGE(I,J)%NSND = 0 -!/T WRITE (MDST,9044) I, J +#ifdef W3_T + WRITE (MDST,9044) I, J +#endif END IF ! IF ( NSND(J) .GT. 0 ) THEN @@ -4285,7 +4701,9 @@ SUBROUTINE WMGEQL EQSTGE(I,J)%STG(NSND(J)), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) EQSTGE(I,J)%NSND = NSND(J) -!/T WRITE (MDST,9045) I, J, NSND(J) +#ifdef W3_T + WRITE (MDST,9045) I, J, NSND(J) +#endif END IF ! END DO @@ -4363,73 +4781,81 @@ SUBROUTINE WMGEQL ! ! 4.c Detailed test output ! -!/T5 DSTR = ' ' -! -!/T5 IF ( EQSTGE(I,I)%NREC .EQ. 0 ) THEN -!/T5 WRITE (MDST,9140) I -!/T5 ELSE -!/T5 WRITE (MDST,9141) I -!/T5 NA = 0 -!/T5 DO J=1, NRGRD -!/T5 IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE -!/T5 NA = NA + 1 -!/T5 NSND(NA) = J -!/T5 END DO -!/T5 WRITE (MDST,9142) NSND(1:NA) -!/T5 WRITE (MDST,9143) -!/T5 ALLOCATE ( TSTR(NA), STAT=ISTAT ) -!/T5 CHECK_ALLOC_STATUS ( ISTAT ) -!/T5 DO JJ=1, EQSTGE(I,I)%NREC -!/T5 DO NG=1, NA -!/T5 J = NSND(NG) -!/T5 TSTR(NG) = DSTR -!/T5 DO NTL=1, EQSTGE(I,J)%NREC -!/T5 IF ( EQSTGE(I,I)%ISEA(JJ) .EQ. & -!/T5 EQSTGE(I,J)%ISEA(NTL) ) THEN -!/T5 WRITE (TSTR(NG),9144) NTL, & -!/T5 EQSTGE(I,J)%WGHT(NTL), & -!/T5 EQSTGE(I,J)%NAVG(NTL) -!/T5 EXIT -!/T5 END IF -!/T5 END DO -!/T5 END DO -!/T5 WRITE (MDST,9145) JJ, EQSTGE(I,I)%ISEA(JJ), & -!/T5 EQSTGE(I,I)%JSEA(JJ), & -!/T5 EQSTGE(I,I)%WGHT(JJ), & -!/T5 TSTR -!/T5 END DO -!/T5 DEALLOCATE ( TSTR, STAT=ISTAT ) -!/T5 CHECK_DEALLOC_STATUS ( ISTAT ) -!/T5 END IF -! -!/T5 DO J=1, NRGRD -!/T5 IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE -!/T5 WRITE (MDST,9146) J -!/T5 DO JJ=1, EQSTGE(I,J)%NREC -!/T5 WRITE (MDST,9147) JJ, EQSTGE(I,J)%NAVG(JJ), & -!/T5 ( EQSTGE(I,J)%WAVG(JJ,NA), & -!/T5 EQSTGE(I,J)%RIP (JJ,NA), & -!/T5 EQSTGE(I,J)%RTG (JJ,NA), & -!/T5 NA=1, EQSTGE(I,J)%NAVG(JJ) ) -!/T5 END DO -!/T5 END DO -! -!/T6 DO J=1, NRGRD -!/T6 IF ( I .EQ. J ) CYCLE -!/T6 IF ( EQSTGE(I,J)%NSND .EQ. 0 ) THEN -!/T6 WRITE (MDST,9240) J -!/T6 ELSE -!/T6 WRITE (MDST,9241) J -!/T6 DO JJ=1, EQSTGE(I,J)%NSND -!/T6 WRITE (MDST,9242) JJ, EQSTGE(I,J)%SIS(JJ), & -!/T6 EQSTGE(I,J)%SJS(JJ), & -!/T6 EQSTGE(I,J)%SI1(JJ), & -!/T6 EQSTGE(I,J)%SI2(JJ), & -!/T6 EQSTGE(I,J)%SIP(JJ), & -!/T6 EQSTGE(I,J)%STG(JJ) -!/T6 END DO -!/T6 END IF -!/T6 END DO +#ifdef W3_T5 + DSTR = ' ' +#endif +! +#ifdef W3_T5 + IF ( EQSTGE(I,I)%NREC .EQ. 0 ) THEN + WRITE (MDST,9140) I + ELSE + WRITE (MDST,9141) I + NA = 0 + DO J=1, NRGRD + IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE + NA = NA + 1 + NSND(NA) = J + END DO + WRITE (MDST,9142) NSND(1:NA) + WRITE (MDST,9143) + ALLOCATE ( TSTR(NA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + DO JJ=1, EQSTGE(I,I)%NREC + DO NG=1, NA + J = NSND(NG) + TSTR(NG) = DSTR + DO NTL=1, EQSTGE(I,J)%NREC + IF ( EQSTGE(I,I)%ISEA(JJ) .EQ. & + EQSTGE(I,J)%ISEA(NTL) ) THEN + WRITE (TSTR(NG),9144) NTL, & + EQSTGE(I,J)%WGHT(NTL), & + EQSTGE(I,J)%NAVG(NTL) + EXIT + END IF + END DO + END DO + WRITE (MDST,9145) JJ, EQSTGE(I,I)%ISEA(JJ), & + EQSTGE(I,I)%JSEA(JJ), & + EQSTGE(I,I)%WGHT(JJ), & + TSTR + END DO + DEALLOCATE ( TSTR, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) + END IF +#endif +! +#ifdef W3_T5 + DO J=1, NRGRD + IF ( I.EQ.J .OR. EQSTGE(I,J)%NREC.EQ.0 ) CYCLE + WRITE (MDST,9146) J + DO JJ=1, EQSTGE(I,J)%NREC + WRITE (MDST,9147) JJ, EQSTGE(I,J)%NAVG(JJ), & + ( EQSTGE(I,J)%WAVG(JJ,NA), & + EQSTGE(I,J)%RIP (JJ,NA), & + EQSTGE(I,J)%RTG (JJ,NA), & + NA=1, EQSTGE(I,J)%NAVG(JJ) ) + END DO + END DO +#endif +! +#ifdef W3_T6 + DO J=1, NRGRD + IF ( I .EQ. J ) CYCLE + IF ( EQSTGE(I,J)%NSND .EQ. 0 ) THEN + WRITE (MDST,9240) J + ELSE + WRITE (MDST,9241) J + DO JJ=1, EQSTGE(I,J)%NSND + WRITE (MDST,9242) JJ, EQSTGE(I,J)%SIS(JJ), & + EQSTGE(I,J)%SJS(JJ), & + EQSTGE(I,J)%SI1(JJ), & + EQSTGE(I,J)%SI2(JJ), & + EQSTGE(I,J)%SIP(JJ), & + EQSTGE(I,J)%STG(JJ) + END DO + END IF + END DO +#endif ! ! ... End of loop started in 3.a ! @@ -4455,7 +4881,9 @@ SUBROUTINE WMGEQL CHECK_ALLOC_STATUS ( ISTAT ) GRDEQL = 0 ! -!/T WRITE (MDST,9050) NA +#ifdef W3_T + WRITE (MDST,9050) NA +#endif ! ! 5.b Fill array ! @@ -4469,10 +4897,12 @@ SUBROUTINE WMGEQL END DO END DO ! -!/T WRITE (MDST,9051) -!/T DO I=1, NRGRD -!/T WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9051) + DO I=1, NRGRD + WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) + END DO +#endif ! ! 5.c Resolution test ! @@ -4570,65 +5000,81 @@ SUBROUTINE WMGEQL ' GRID',I4,' IN GROUP',I4/ & ' GRID',I4,' IN GROUP',I4/) ! -!/T 9010 FORMAT ( ' TEST WMGEQL : STARTING LOOP OVER GRIDS') -!/T 9011 FORMAT ( ' TEST WMGEQL : I, RANK :',2I4) -!/T 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') -!/T 9013 FORMAT ( ' ',A) -! -!/T 9020 FORMAT ( ' TEST WMGEQL : GENERATING DISTANCE MAP GRID ',I3) -!/T 9024 FORMAT ( ' TEST WMGEQL : FINAL MAP FOR X RANGE ',2I6) -!/T 9025 FORMAT (2X,65I2) -! -!/T 9030 FORMAT ( ' TEST WMGEQL : DEPENDENCE INFORMATION GRID ',I3) -!/T 9031 FORMAT ( ' CHECKING GRID ',I3) -!/T 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) -!/T 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) -!/T 9034 FORMAT ( ' LOCAL PER GRID :',15I6) -!/T 9035 FORMAT ( ' SENDING PER GRID :',15I6) -!/T 9036 FORMAT ( ' TEST WMGEQL : NUMBER OF CONTRIBUTING GRIDS MAP') -!/T 9037 FORMAT (2X,65I2) -! -!/T 9040 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') -!/T 9041 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) -!/T 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') -!/T 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) -!/T 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') -!/T 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) -! -!/T 9050 FORMAT ( ' TEST WMGEQL : GRDEQL DIMENSIONED AT ',I2) -!/T 9051 FORMAT ( ' TEST WMGEQL : GRDEQL :') -!/T 9052 FORMAT ( ' ',2i4,' : ',20I3) -! -!/T5 9140 FORMAT ( ' TEST WMGEQL : NO RECEIVING DATA FOR GRID ',I3, & -!/T5 ' <=====================================') -!/T5 9141 FORMAT ( ' TEST WMGEQL : RECEIVING DATA GRID ',I3, & -!/T5 ' <=====================================') -!/T5 9142 FORMAT ( ' RECEIVING FROM GRID(S) ',10I3) -!/T5 9143 FORMAT (16X,'COUNT, ISEA, JSEA, WEIGHT / ', & -!/T5 'COUNT WEIGHT NR PER GRID') -!/T5 9144 FORMAT (I6,F6.2,I6) -!/T5 9145 FORMAT (12X,3I6,F6.2,10(' - ',A)) -!/T5 9146 FORMAT ( ' TEST WMGEQL : RECEIVING DATA AVG. GRID ',I3) -!/T5 9147 FORMAT (12X,I6,I2,4(F8.2,I4,I6)) -! -!/T6 9240 FORMAT ( ' TEST WMGEQL : NO SENDING DATA FOR GRID ',I3, & -!/T6 ' <=====================================') -!/T6 9241 FORMAT ( ' TEST WMGEQL : SENDING DATA GRID ',I3, & -!/T6 ' <====================================='/ & -!/T6 11X,'COUNT, ISEA, JSEA, ARRAY IND., PROC, TAG') -!/T6 9242 FORMAT ( ' ',4I8,I4,2I8) -! -!/T7 9330 FORMAT ( ' TEST WMGEQL : FULL SOURCE INFO GRID ',I3, & -!/T7 ' <=====================================') -!/T7 9331 FORMAT ( ' GRID ',I3,' IS NOT OF SAME RANK') -!/T7 9332 FORMAT ( ' GRID ',I3,' CONTRIBUTES TO',I6, & -!/T7 ' GRID POINTS'/ & -!/T7 18X,'<---------- GRID',I6,' ---------->', & -!/T7 4X,'<----------- GRID',I6,' ----------->'/ & -!/T7 18X,'NR IX IY ISEA JSEA IP WGTH', & -!/T7 2X,' WGTH NA ISEA JSEA IP WGTH TAG' ) -!/T7 9333 FORMAT (15X,3I5,2I6,I4,F6.2,2X,F6.2,I4,2I6,I4,F6.2,I6) -!/T7 9334 FORMAT (64X,2I6,I4,F6.2,I6) +#ifdef W3_T + 9010 FORMAT ( ' TEST WMGEQL : STARTING LOOP OVER GRIDS') + 9011 FORMAT ( ' TEST WMGEQL : I, RANK :',2I4) + 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') + 9013 FORMAT ( ' ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMGEQL : GENERATING DISTANCE MAP GRID ',I3) + 9024 FORMAT ( ' TEST WMGEQL : FINAL MAP FOR X RANGE ',2I6) + 9025 FORMAT (2X,65I2) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMGEQL : DEPENDENCE INFORMATION GRID ',I3) + 9031 FORMAT ( ' CHECKING GRID ',I3) + 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) + 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) + 9034 FORMAT ( ' LOCAL PER GRID :',15I6) + 9035 FORMAT ( ' SENDING PER GRID :',15I6) + 9036 FORMAT ( ' TEST WMGEQL : NUMBER OF CONTRIBUTING GRIDS MAP') + 9037 FORMAT (2X,65I2) +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') + 9041 FORMAT ( ' TEST WMGEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) + 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') + 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) + 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') + 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) +#endif +! +#ifdef W3_T + 9050 FORMAT ( ' TEST WMGEQL : GRDEQL DIMENSIONED AT ',I2) + 9051 FORMAT ( ' TEST WMGEQL : GRDEQL :') + 9052 FORMAT ( ' ',2i4,' : ',20I3) +#endif +! +#ifdef W3_T5 + 9140 FORMAT ( ' TEST WMGEQL : NO RECEIVING DATA FOR GRID ',I3, & + ' <=====================================') + 9141 FORMAT ( ' TEST WMGEQL : RECEIVING DATA GRID ',I3, & + ' <=====================================') + 9142 FORMAT ( ' RECEIVING FROM GRID(S) ',10I3) + 9143 FORMAT (16X,'COUNT, ISEA, JSEA, WEIGHT / ', & + 'COUNT WEIGHT NR PER GRID') + 9144 FORMAT (I6,F6.2,I6) + 9145 FORMAT (12X,3I6,F6.2,10(' - ',A)) + 9146 FORMAT ( ' TEST WMGEQL : RECEIVING DATA AVG. GRID ',I3) + 9147 FORMAT (12X,I6,I2,4(F8.2,I4,I6)) +#endif +! +#ifdef W3_T6 + 9240 FORMAT ( ' TEST WMGEQL : NO SENDING DATA FOR GRID ',I3, & + ' <=====================================') + 9241 FORMAT ( ' TEST WMGEQL : SENDING DATA GRID ',I3, & + ' <====================================='/ & + 11X,'COUNT, ISEA, JSEA, ARRAY IND., PROC, TAG') + 9242 FORMAT ( ' ',4I8,I4,2I8) +#endif +! +#ifdef W3_T7 + 9330 FORMAT ( ' TEST WMGEQL : FULL SOURCE INFO GRID ',I3, & + ' <=====================================') + 9331 FORMAT ( ' GRID ',I3,' IS NOT OF SAME RANK') + 9332 FORMAT ( ' GRID ',I3,' CONTRIBUTES TO',I6, & + ' GRID POINTS'/ & + 18X,'<---------- GRID',I6,' ---------->', & + 4X,'<----------- GRID',I6,' ----------->'/ & + 18X,'NR IX IY ISEA JSEA IP WGTH', & + 2X,' WGTH NA ISEA JSEA IP WGTH TAG' ) + 9333 FORMAT (15X,3I5,2I6,I4,F6.2,2X,F6.2,I4,2I6,I4,F6.2,I6) + 9334 FORMAT (64X,2I6,I4,F6.2,I6) +#endif !/ !/ End of WMGEQL ----------------------------------------------------- / !/ @@ -4693,7 +5139,9 @@ SUBROUTINE WMRSPC !/ ------------------------------------------------------------------- / ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD USE W3ODATMD, ONLY: UNIPTS @@ -4708,9 +5156,13 @@ SUBROUTINE WMRSPC !/ Local parameters !/ INTEGER :: I, J, LOW -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMRSPC') +#ifdef W3_S + CALL STRACE (IENT, 'WMRSPC') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -4743,17 +5195,21 @@ SUBROUTINE WMRSPC ! -------------------------------------------------------------------- / ! 2. Test output ! -!/T WRITE (MDST,9000) -!/T DO I=LOW, NRGRD -!/T WRITE (MDST,9001) I, RESPEC(I,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9000) + DO I=LOW, NRGRD + WRITE (MDST,9001) I, RESPEC(I,:) + END DO +#endif ! RETURN ! ! Formats ! -!/T 9000 FORMAT ( 'TEST WMRSPC : MAP RESPEC FILLED ') -!/T 9001 FORMAT ( ' ',I4,' : ',20L2) +#ifdef W3_T + 9000 FORMAT ( 'TEST WMRSPC : MAP RESPEC FILLED ') + 9001 FORMAT ( ' ',I4,' : ',20L2) +#endif !/ !/ End of WMRSPC ----------------------------------------------------- / !/ @@ -4835,13 +5291,19 @@ SUBROUTINE WMSMCEQL USE WMMDATMD ! USE W3SERVMD, ONLY: EXTCDE -!/SMC USE W3PSMCMD, ONLY: W3SMCGMP, W3SMCELL +#ifdef W3_SMC + USE W3PSMCMD, ONLY: W3SMCGMP, W3SMCELL +#endif -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -4854,17 +5316,23 @@ SUBROUTINE WMSMCEQL ISEA, JSEA, IPRC, ITAG, TGRP, NPMX, & IP, NP, ICROOT, JCROOT, IEER -!/MPI INTEGER, Dimension(MPI_STATUS_SIZE):: MPIState +#ifdef W3_MPI + INTEGER, Dimension(MPI_STATUS_SIZE):: MPIState +#endif -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: NREC(:), NSND(:), NTPP(:), & IBPTS(:), JBPTS(:), IPBPT(:) REAL, PARAMETER :: ODIMAX = 25. REAL, ALLOCATABLE :: XLon(:), YLat(:) LOGICAL :: CHANGE LOGICAL, ALLOCATABLE :: SHRANK(:,:), DOGRID(:) -!/T5 CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) -!/T5 CHARACTER(LEN=18) :: DSTR +#ifdef W3_T5 + CHARACTER(LEN=18), ALLOCATABLE :: TSTR(:) + CHARACTER(LEN=18) :: DSTR +#endif ! TYPE STORE INTEGER :: NTOT, NFIN @@ -4876,7 +5344,9 @@ SUBROUTINE WMSMCEQL ! TYPE(STORE), ALLOCATABLE :: STORES(:,:) !/ -!/S CALL STRACE (IENT, 'WMSMCEQL ') +#ifdef W3_S + CALL STRACE (IENT, 'WMSMCEQL ') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -4902,11 +5372,15 @@ SUBROUTINE WMSMCEQL ! 1. Grid point relations and temp data storage ! 1.a Outer loop over all grids ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! DO I=1, NRGRD -!/T WRITE (MDST,9011) I, GRANK(I) +#ifdef W3_T + WRITE (MDST,9011) I, GRANK(I) +#endif ! ! 1.b Find sub grids with same rank ! @@ -4925,8 +5399,12 @@ SUBROUTINE WMSMCEQL CALL W3SETG( I, MDSE, MDST ) ! ! Find local root PE and NAPROC for I grid. -!/SHRD ICROOT = 1 -!/MPI ICROOT = MDATAS(I)%CROOT +#ifdef W3_SHRD + ICROOT = 1 +#endif +#ifdef W3_MPI + ICROOT = MDATAS(I)%CROOT +#endif NP = OUTPTS(I)%NAPROC ! ! 1.c Fetch Grid I boundary points. @@ -4935,22 +5413,46 @@ SUBROUTINE WMSMCEQL IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN ! 1.c.1 Regular grid I boundary points are stored in NBI. NT = OUTPTS(I)%OUT5%NBI -!/MPI IF( IMPROC .EQ. ICROOT ) THEN +#ifdef W3_MPI + IF( IMPROC .EQ. ICROOT ) THEN +#endif WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT -!/MPI ENDIF +#ifdef W3_MPI + ENDIF +#endif ! ! 1.c.2 SMC grid I boundary cell ids are saved in NBSMC. -!/SMC ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN -!/MPI/!/SMC IF( IMPROC .EQ. ICROOT ) THEN -!/SMC NT = GRIDS(I)%NBSMC -!/SMC WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT -!/MPI/!/SMC ENDIF +#ifdef W3_SMC + ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN +#endif +#ifdef W3_MPI +#ifdef W3_SMC + IF( IMPROC .EQ. ICROOT ) THEN +#endif +#endif +#ifdef W3_SMC + NT = GRIDS(I)%NBSMC + WRITE(MDSE,*) "ICROOT, NT are", ICROOT, NT +#endif +#ifdef W3_MPI +#ifdef W3_SMC + ENDIF +#endif +#endif -!/MPI/!/SMC CALL MPI_BCAST( NT, 1, MPI_INTEGER, & -!/MPI/!/SMC ICROOT-1, MPI_COMM_MWAVE, IEER) +#ifdef W3_MPI +#ifdef W3_SMC + CALL MPI_BCAST( NT, 1, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) +#endif +#endif ! Need to wait for all PEs get these values. -!/MPI/!/SMC CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#ifdef W3_MPI +#ifdef W3_SMC + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#endif +#endif ! ENDIF !! GTYPE .EQ. RLGTYPE ! @@ -4962,7 +5464,9 @@ SUBROUTINE WMSMCEQL CHECK_ALLOC_STATUS ( ISTAT ) ! Use saved I-grid boundary cell list. -!/MPI IF( IMPROC .EQ. ICROOT ) THEN +#ifdef W3_MPI + IF( IMPROC .EQ. ICROOT ) THEN +#endif IF( GRIDS(I)%GTYPE .EQ. RLGTYPE ) THEN !! Loop over regular grid mesh to find boundary points. IXY = 0 @@ -4979,35 +5483,45 @@ SUBROUTINE WMSMCEQL ENDIF ENDDO ! -!/SMC ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN -!/SMC -!/SMC IBPTS = GRIDS(I)%ISMCBP(1:NT) -!/SMC CALL W3SMCELL( I, NT, IBPTS, XLon, YLat ) -!/SMC DO IX = 1, NT +#ifdef W3_SMC + ELSEIF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) THEN + + IBPTS = GRIDS(I)%ISMCBP(1:NT) + CALL W3SMCELL( I, NT, IBPTS, XLon, YLat ) + DO IX = 1, NT +#endif ! Global processor IPBPT and local JSEA, for ISEA spectrum in I grid. -!/SMC ISEA = IBPTS(IX) -!/SMC JSEA = 1 + (ISEA - 1)/NP -!/SMC IPBPT(IX) = ICROOT - 1 + ISEA - (JSEA - 1)*NP -!/SMC JBPTS(IX) = JSEA -!/SMC ENDDO +#ifdef W3_SMC + ISEA = IBPTS(IX) + JSEA = 1 + (ISEA - 1)/NP + IPBPT(IX) = ICROOT - 1 + ISEA - (JSEA - 1)*NP + JBPTS(IX) = JSEA + ENDDO +#endif ! ENDIF !! RLGTYPE -!/MPI ENDIF !! ICROOT +#ifdef W3_MPI + ENDIF !! ICROOT +#endif ! ! All have to wait for ICROOT finishes conversion of cell ids to XLon-YLat -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#endif ! ! Then broadcast IBPTS, IPBPT, XLon, and YLat to all PEs -!/MPI CALL MPI_BCAST( IBPTS(1), NT, MPI_INTEGER, & -!/MPI ICROOT-1, MPI_COMM_MWAVE, IEER) -!/MPI CALL MPI_BCAST( JBPTS(1), NT, MPI_INTEGER, & -!/MPI ICROOT-1, MPI_COMM_MWAVE, IEER) -!/MPI CALL MPI_BCAST( IPBPT(1), NT, MPI_INTEGER, & -!/MPI ICROOT-1, MPI_COMM_MWAVE, IEER) -!/MPI CALL MPI_BCAST( XLon(1), NT, MPI_REAL, & -!/MPI ICROOT-1, MPI_COMM_MWAVE, IEER) -!/MPI CALL MPI_BCAST( YLat(1), NT, MPI_REAL, & -!/MPI ICROOT-1, MPI_COMM_MWAVE, IEER) +#ifdef W3_MPI + CALL MPI_BCAST( IBPTS(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( JBPTS(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( IPBPT(1), NT, MPI_INTEGER, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( XLon(1), NT, MPI_REAL, & + ICROOT-1, MPI_COMM_MWAVE, IEER) + CALL MPI_BCAST( YLat(1), NT, MPI_REAL, & + ICROOT-1, MPI_COMM_MWAVE, IEER) +#endif ! 1.d Loop over J grids, select same rank ! @@ -5018,8 +5532,12 @@ SUBROUTINE WMSMCEQL IF( GRIDS(J)%GTYPE .NE. SMCTYPE ) CYCLE ! ! Find local root PE and NAPROC for J grid. -!/SHRD JCROOT = 1 -!/MPI JCROOT = MDATAS(J)%CROOT +#ifdef W3_SHRD + JCROOT = 1 +#endif +#ifdef W3_MPI + JCROOT = MDATAS(J)%CROOT +#endif NPJ = OUTPTS(J)%NAPROC ! ! Find out whether any I-grid boundary points matched in J-Grid. @@ -5042,20 +5560,40 @@ SUBROUTINE WMSMCEQL STORES(I,J)%FLA = .FALSE. ! ! Work out which I-grid bounary points are matched in J-grid on JCROOT. -!/MPI/!/SMC IF( IMPROC .EQ. JCROOT ) THEN -!/SMC CALL W3SMCGMP( J, NT, XLon, YLat, STORES(I,J)%MSDBP ) -!/MPI/!/SMC ENDIF +#ifdef W3_MPI +#ifdef W3_SMC + IF( IMPROC .EQ. JCROOT ) THEN +#endif +#endif +#ifdef W3_SMC + CALL W3SMCGMP( J, NT, XLon, YLat, STORES(I,J)%MSDBP ) +#endif +#ifdef W3_MPI +#ifdef W3_SMC + ENDIF +#endif +#endif ! ! Then broadcast the results to all PEs -!/MPI/!/SMC CALL MPI_BCAST( STORES(I,J)%MSDBP(1), NT, MPI_INTEGER, & -!/MPI/!/SMC JCROOT-1, MPI_COMM_MWAVE, IEER) +#ifdef W3_MPI +#ifdef W3_SMC + CALL MPI_BCAST( STORES(I,J)%MSDBP(1), NT, MPI_INTEGER, & + JCROOT-1, MPI_COMM_MWAVE, IEER) +#endif +#endif ! ! Need to wait for all PEs get these values. -!/MPI/!/SMC CALL MPI_BARRIER( MPI_COMM_MWAVE, IEER) -! -!/SMC STORES(I,J)%ICVBP = IBPTS -!/SMC STORES(I,J)%JCVBP = JBPTS -!/SMC STORES(I,J)%IPCVB = IPBPT +#ifdef W3_MPI +#ifdef W3_SMC + CALL MPI_BARRIER( MPI_COMM_MWAVE, IEER) +#endif +#endif +! +#ifdef W3_SMC + STORES(I,J)%ICVBP = IBPTS + STORES(I,J)%JCVBP = JBPTS + STORES(I,J)%IPCVB = IPBPT +#endif ! ! Check which I-grid boundary points matched inside J-Grid NTL= 0 @@ -5083,8 +5621,14 @@ SUBROUTINE WMSMCEQL STORES(I,J)%NTOT = NT STORES(I,J)%NFIN = NTL ! -!/MPI/!/SMC IF( IMPROC .EQ. NMPERR ) & -!/SMC WRITE(MDSE,1060) I, NT, J, NTL +#ifdef W3_MPI +#ifdef W3_SMC + IF( IMPROC .EQ. NMPERR ) & +#endif +#endif +#ifdef W3_SMC + WRITE(MDSE,1060) I, NT, J, NTL +#endif ! ! ... End of loops J in 1.c END DO @@ -5107,7 +5651,9 @@ SUBROUTINE WMSMCEQL ! DO I=1, NRGRD IF ( .NOT. DOGRID(I) ) CYCLE -!/T WRITE (MDST,9030) I +#ifdef W3_T + WRITE (MDST,9030) I +#endif ! CALL W3SETG ( I, MDSE, MDST ) CALL W3SETO ( I, MDSE, MDST ) @@ -5117,8 +5663,12 @@ SUBROUTINE WMSMCEQL NSND = 0 ! ! Find local root PE and maximum PE for I grid. -!/SHRD ICROOT = 1 -!/MPI ICROOT = MDATAS(I)%CROOT +#ifdef W3_SHRD + ICROOT = 1 +#endif +#ifdef W3_MPI + ICROOT = MDATAS(I)%CROOT +#endif NPMX = OUTPTS(I)%NAPROC + ICROOT - 1 ! ! 3.b Filling NREC and NSND for grid I @@ -5163,7 +5713,9 @@ SUBROUTINE WMSMCEQL EQSTGE(I,I)%WGHT, STAT=ISTAT ) CHECK_DEALLOC_STATUS ( ISTAT ) EQSTGE(I,I)%NREC = 0 -!/T WRITE (MDST,9040) I, I +#ifdef W3_T + WRITE (MDST,9040) I, I +#endif END IF ! IF( NREC(I) .GT. 0 ) THEN @@ -5172,7 +5724,9 @@ SUBROUTINE WMSMCEQL EQSTGE(I,I)%WGHT(NREC(I)), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) EQSTGE(I,I)%NREC = NREC(I) -!/T WRITE (MDST,9041) I, I, NREC(I) +#ifdef W3_T + WRITE (MDST,9041) I, I, NREC(I) +#endif END IF ! !! Initial NTOT for grid I before summing over other grids. JGLi18Jan2021 @@ -5318,7 +5872,9 @@ SUBROUTINE WMSMCEQL CHECK_ALLOC_STATUS( ISTAT ) GRDEQL = 0 ! -!/T WRITE (MDST,9050) NA +#ifdef W3_T + WRITE (MDST,9050) NA +#endif ! ! 5.b Fill array ! @@ -5332,10 +5888,12 @@ SUBROUTINE WMSMCEQL END DO END DO ! -!/T WRITE (MDST,9051) -!/T DO I=1, NRGRD -!/T WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9051) + DO I=1, NRGRD + WRITE (MDST,9052) I, GRDEQL(I,0:GRDEQL(I,0)) + END DO +#endif ! ! 5.d Group number test ! @@ -5354,7 +5912,11 @@ SUBROUTINE WMSMCEQL END DO ! ! Wait all PEs finishing EQSTGE setup before clean up. JGLi20Jan2021 -!/MPI/!/SMC CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#ifdef W3_MPI +#ifdef W3_SMC + CALL MPI_BARRIER (MPI_COMM_MWAVE,IEER) +#endif +#endif ! -------------------------------------------------------------------- / ! 6. Final clean up ! @@ -5374,8 +5936,14 @@ SUBROUTINE WMSMCEQL DEALLOCATE( SHRANK, STORES, NREC, NSND, NTPP, STAT=ISTAT ) CHECK_DEALLOC_STATUS( ISTAT ) ! -!/MPI/!/SMC IF( IMPROC .EQ. NMPERR ) & -!/SMC WRITE(MDSE,*) " *** WMSMCEQL completed from PE ", IMPROC +#ifdef W3_MPI +#ifdef W3_SMC + IF( IMPROC .EQ. NMPERR ) & +#endif +#endif +#ifdef W3_SMC + WRITE(MDSE,*) " *** WMSMCEQL completed from PE ", IMPROC +#endif RETURN ! @@ -5405,34 +5973,44 @@ SUBROUTINE WMSMCEQL 1060 FORMAT (' Grid NBPI from',2I6,' found in',2I6) ! -!/T 9010 FORMAT ( ' TEST WMSMCEQL : STARTING LOOP OVER GRIDS') -!/T 9011 FORMAT ( ' TEST WMSMCEQL : I, RANK :',2I4) -!/T 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') -!/T 9013 FORMAT ( ' ',A) -! -!/T 9020 FORMAT ( ' TEST WMSMCEQL : GENERATING DISTANCE MAP GRID ',I3) -!/T 9024 FORMAT ( ' TEST WMSMCEQL : FINAL MAP FOR X RANGE ',2I6) -!/T 9025 FORMAT (2X,65I2) -! -!/T 9030 FORMAT ( ' TEST WMSMCEQL : DEPENDENCE INFORMATION GRID ',I3) -!/T 9031 FORMAT ( ' CHECKING GRID ',I3) -!/T 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) -!/T 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) -!/T 9034 FORMAT ( ' LOCAL PER GRID :',15I6) -!/T 9035 FORMAT ( ' SENDING PER GRID :',15I6) -!/T 9036 FORMAT ( ' TEST WMSMCEQL : NUMBER OF CONTRIBUTING GRIDS MAP') -!/T 9037 FORMAT (2X,65I2) -! -!/T 9040 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') -!/T 9041 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) -!/T 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') -!/T 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) -!/T 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') -!/T 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) -! -!/T 9050 FORMAT ( ' TEST WMSMCEQL : GRDEQL DIMENSIONED AT ',I2) -!/T 9051 FORMAT ( ' TEST WMSMCEQL : GRDEQL :') -!/T 9052 FORMAT ( ' ',2i4,' : ',20I3) +#ifdef W3_T + 9010 FORMAT ( ' TEST WMSMCEQL : STARTING LOOP OVER GRIDS') + 9011 FORMAT ( ' TEST WMSMCEQL : I, RANK :',2I4) + 9012 FORMAT ( ' GRID ',I3,' HAS SAME RANK') + 9013 FORMAT ( ' ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMSMCEQL : GENERATING DISTANCE MAP GRID ',I3) + 9024 FORMAT ( ' TEST WMSMCEQL : FINAL MAP FOR X RANGE ',2I6) + 9025 FORMAT (2X,65I2) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMSMCEQL : DEPENDENCE INFORMATION GRID ',I3) + 9031 FORMAT ( ' CHECKING GRID ',I3) + 9032 FORMAT ( ' POINTS USED/AVAIL :',2I6) + 9033 FORMAT ( ' TOTAL/GRIDS/OUT :',3I6) + 9034 FORMAT ( ' LOCAL PER GRID :',15I6) + 9035 FORMAT ( ' SENDING PER GRID :',15I6) + 9036 FORMAT ( ' TEST WMSMCEQL : NUMBER OF CONTRIBUTING GRIDS MAP') + 9037 FORMAT (2X,65I2) +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' CLEAR STORAGE') + 9041 FORMAT ( ' TEST WMSMCEQL : GRID ',I2,'-',I2,' STORAGE SIZE',I6) + 9042 FORMAT ( ' RECV ',I2,'-',I2,' CLEAR STORAGE') + 9043 FORMAT ( ' RECV ',I2,'-',I2,' STORAGE SIZE',2I6) + 9044 FORMAT ( ' SEND ',I2,'-',I2,' CLEAR STORAGE') + 9045 FORMAT ( ' SEND ',I2,'-',I2,' STORAGE SIZE',I6) +#endif +! +#ifdef W3_T + 9050 FORMAT ( ' TEST WMSMCEQL : GRDEQL DIMENSIONED AT ',I2) + 9051 FORMAT ( ' TEST WMSMCEQL : GRDEQL :') + 9052 FORMAT ( ' ',2i4,' : ',20I3) +#endif ! !/ !/ End of WMSMCEQL -------------------------------------------------- / diff --git a/model/ftn/wminiomd.ftn b/model/src/wminiomd.F90 similarity index 52% rename from model/ftn/wminiomd.ftn rename to model/src/wminiomd.F90 index 9d606af22..da27749d5 100644 --- a/model/ftn/wminiomd.ftn +++ b/model/src/wminiomd.F90 @@ -166,11 +166,15 @@ SUBROUTINE WMIOBS ( IMOD ) USE W3CSPCMD, ONLY: W3CSPC USE W3SERVMD, ONLY: EXTCDE USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -181,19 +185,29 @@ SUBROUTINE WMIOBS ( IMOD ) !/ Local parameters !/ INTEGER :: J, I, IOFF, ISEA, JSEA, IS -!/DIST INTEGER :: ISPROC -!/MPI INTEGER :: IP, IT0, ITAG, IERR_MPI -!/MPI INTEGER, POINTER :: NRQ, IRQ(:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_DIST + INTEGER :: ISPROC +#endif +#ifdef W3_MPI + INTEGER :: IP, IT0, ITAG, IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, POINTER :: SBPI(:,:), TSTORE(:,:) !/ -!/S CALL STRACE (IENT, 'WMIOBS') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOBS') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD -!/T WRITE (MDST,9001) NBI2G(:,IMOD) +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) NBI2G(:,IMOD) +#endif ! IF ( SUM(NBI2G(:,IMOD)) .EQ. 0 ) RETURN ! @@ -217,75 +231,101 @@ SUBROUTINE WMIOBS ( IMOD ) IOFF = SUM(NBI2G(J,1:IMOD-1)) END IF ! -!/T WRITE (MDST,9010) NBI2G(J,IMOD),IMOD,J,IOFF+1,RESPEC(J,IMOD) +#ifdef W3_T + WRITE (MDST,9010) NBI2G(J,IMOD),IMOD,J,IOFF+1,RESPEC(J,IMOD) +#endif ! ! -------------------------------------------------------------------- / ! 2. Allocate arrays ! -!/SHRD IF ( BPSTGE(J,IMOD)%INIT ) THEN -!/SHRD IF ( SIZE(BPSTGE(J,IMOD)%SBPI(:,1)) .NE. NSPEC .OR. & -!/SHRD SIZE(BPSTGE(J,IMOD)%SBPI(1,:)) & -!/SHRD .NE. NBI2G(J,IMOD) ) THEN -!/SHRD DEALLOCATE ( BPSTGE(J,IMOD)%SBPI ) -!/SHRD BPSTGE(J,IMOD)%INIT = .FALSE. -!/SHRD END IF -!/SHRD END IF -! -!/SHRD IF ( .NOT. BPSTGE(J,IMOD)%INIT ) THEN -!/SHRD NSPEC => SGRDS(J)%NSPEC -!/SHRD ALLOCATE ( BPSTGE(J,IMOD)%SBPI(NSPEC,NBI2G(J,IMOD)) ) -!/SHRD NSPEC => SGRDS(IMOD)%NSPEC -!/SHRD BPSTGE(J,IMOD)%INIT = .TRUE. -!/SHRD END IF -! -!/SHRD IF ( RESPEC(J,IMOD) ) THEN -!/SHRD ALLOCATE ( TSTORE(NSPEC,NBI2G(J,IMOD)) ) -!/SHRD SBPI => TSTORE -!/SHRD ELSE -!/SHRD SBPI => BPSTGE(J,IMOD)%SBPI -!/SHRD END IF -! -!/MPI NAPROC => OUTPTS(J)%NAPROC -!/MPI ALLOCATE ( IRQ(NBI2G(J,IMOD)*NAPROC+NAPROC) ) -!/MPI ALLOCATE ( BPSTGE(J,IMOD)%TSTORE(NSPEC,NBI2G(J,IMOD)) ) -!/MPI NAPROC => OUTPTS(IMOD)%NAPROC -! -!/MPI NRQ => BPSTGE(J,IMOD)%NRQBPS -!/MPI SBPI => BPSTGE(J,IMOD)%TSTORE -! -!/MPI NRQ = 0 -!/MPI IRQ = 0 +#ifdef W3_SHRD + IF ( BPSTGE(J,IMOD)%INIT ) THEN + IF ( SIZE(BPSTGE(J,IMOD)%SBPI(:,1)) .NE. NSPEC .OR. & + SIZE(BPSTGE(J,IMOD)%SBPI(1,:)) & + .NE. NBI2G(J,IMOD) ) THEN + DEALLOCATE ( BPSTGE(J,IMOD)%SBPI ) + BPSTGE(J,IMOD)%INIT = .FALSE. + END IF + END IF +#endif +! +#ifdef W3_SHRD + IF ( .NOT. BPSTGE(J,IMOD)%INIT ) THEN + NSPEC => SGRDS(J)%NSPEC + ALLOCATE ( BPSTGE(J,IMOD)%SBPI(NSPEC,NBI2G(J,IMOD)) ) + NSPEC => SGRDS(IMOD)%NSPEC + BPSTGE(J,IMOD)%INIT = .TRUE. + END IF +#endif +! +#ifdef W3_SHRD + IF ( RESPEC(J,IMOD) ) THEN + ALLOCATE ( TSTORE(NSPEC,NBI2G(J,IMOD)) ) + SBPI => TSTORE + ELSE + SBPI => BPSTGE(J,IMOD)%SBPI + END IF +#endif +! +#ifdef W3_MPI + NAPROC => OUTPTS(J)%NAPROC + ALLOCATE ( IRQ(NBI2G(J,IMOD)*NAPROC+NAPROC) ) + ALLOCATE ( BPSTGE(J,IMOD)%TSTORE(NSPEC,NBI2G(J,IMOD)) ) + NAPROC => OUTPTS(IMOD)%NAPROC +#endif +! +#ifdef W3_MPI + NRQ => BPSTGE(J,IMOD)%NRQBPS + SBPI => BPSTGE(J,IMOD)%TSTORE +#endif +! +#ifdef W3_MPI + NRQ = 0 + IRQ = 0 +#endif ! ! -------------------------------------------------------------------- / ! 3. Set the time ! Note that with MPI the send needs to be posted to the local ! processor too to make time management possible. ! -!/T WRITE (MDST,9030) TIME -!/MPIT WRITE (MDST,9080) -! -!/SHRD BPSTGE(J,IMOD)%VTIME = TIME -! -!/MPI IF ( IAPROC .EQ. 1 ) THEN -!/MPI BPSTGE(J,IMOD)%STIME = TIME -!/MPI ITAG = MTAG0 + IMOD + (J-1)*NRGRD -!/MPI IF ( ITAG .GT. MTAG1 ) THEN -!/MPI WRITE (MDSE,1001) -!/MPI CALL EXTCDE (1001) -!/MPI END IF -!/MPI DO IP=1, NMPROC -!/MPI IF ( ALLPRC(IP,J) .NE. 0 .AND. & -!/MPI ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_ISEND ( BPSTGE(J,IMOD)%STIME, 2, & -!/MPI MPI_INTEGER, IP-1, ITAG, & -!/MPI MPI_COMM_MWAVE, IRQ(NRQ), & -!/MPI IERR_MPI ) -!/MPIT WRITE (MDST,9081) NRQ, IP, ITAG-MTAG0, & -!/MPIT IRQ(NRQ), IERR_MPI -!/MPI END IF -!/MPI END DO -!/MPI END IF +#ifdef W3_T + WRITE (MDST,9030) TIME +#endif +#ifdef W3_MPIT + WRITE (MDST,9080) +#endif +! +#ifdef W3_SHRD + BPSTGE(J,IMOD)%VTIME = TIME +#endif +! +#ifdef W3_MPI + IF ( IAPROC .EQ. 1 ) THEN + BPSTGE(J,IMOD)%STIME = TIME + ITAG = MTAG0 + IMOD + (J-1)*NRGRD + IF ( ITAG .GT. MTAG1 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF + DO IP=1, NMPROC + IF ( ALLPRC(IP,J) .NE. 0 .AND. & + ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( BPSTGE(J,IMOD)%STIME, 2, & + MPI_INTEGER, IP-1, ITAG, & + MPI_COMM_MWAVE, IRQ(NRQ), & + IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9081) NRQ, IP, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + END IF + END DO + END IF +#endif ! ! -------------------------------------------------------------------- / ! 4. Stage the spectral data @@ -293,58 +333,78 @@ SUBROUTINE WMIOBS ( IMOD ) DO I=1, NBI2G(J,IMOD) ! ISEA = NBI2S(IOFF+I,2) -!/SHRD JSEA = ISEA -!/DIST CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/DIST IF ( ISPROC .NE. IAPROC ) CYCLE -!/MPI IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:J-1,:)) + & -!/MPI SUM(NBI2G(J,1:IMOD-1)) +#ifdef W3_SHRD + JSEA = ISEA +#endif +#ifdef W3_DIST + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF ( ISPROC .NE. IAPROC ) CYCLE +#endif +#ifdef W3_MPI + IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:J-1,:)) + & + SUM(NBI2G(J,1:IMOD-1)) +#endif ! DO IS=1, NSPEC SBPI(IS,I) = VA(IS,JSEA) * SIG2(IS) / CG(1+(IS-1)/NTH,ISEA) END DO ! -!/MPI DO IP=1, NMPROC -!/MPI IF ( ALLPRC(IP,J) .NE. 0 .AND. & -!/MPI ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI ITAG = IT0 + I -!/MPI IF ( ITAG .GT. MTAG1 ) THEN -!/MPI WRITE (MDSE,1001) -!/MPI CALL EXTCDE (1001) -!/MPI END IF -!/MPI CALL MPI_ISEND ( SBPI(1,I), NSPEC, MPI_REAL, & -!/MPI IP-1, ITAG, MPI_COMM_MWAVE, & -!/MPI IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG0, & -!/MPIT IRQ(NRQ), IERR_MPI -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + DO IP=1, NMPROC + IF ( ALLPRC(IP,J) .NE. 0 .AND. & + ALLPRC(IP,J) .LE. OUTPTS(J)%NAPROC ) THEN + NRQ = NRQ + 1 + ITAG = IT0 + I + IF ( ITAG .GT. MTAG1 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF + CALL MPI_ISEND ( SBPI(1,I), NSPEC, MPI_REAL, & + IP-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + END IF + END DO +#endif ! END DO ! -!/MPIT WRITE (MDST,9083) -!/MPIT WRITE (MDST,9084) NRQ +#ifdef W3_MPIT + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ +#endif ! -!/MPI IF ( NRQ .GT. 0 ) THEN -!/MPI ALLOCATE ( BPSTGE(J,IMOD)%IRQBPS(NRQ) ) -!/MPI BPSTGE(J,IMOD)%IRQBPS = IRQ(:NRQ) -!/MPI ELSE -!/MPI DEALLOCATE ( BPSTGE(J,IMOD)%TSTORE ) -!/MPI END IF +#ifdef W3_MPI + IF ( NRQ .GT. 0 ) THEN + ALLOCATE ( BPSTGE(J,IMOD)%IRQBPS(NRQ) ) + BPSTGE(J,IMOD)%IRQBPS = IRQ(:NRQ) + ELSE + DEALLOCATE ( BPSTGE(J,IMOD)%TSTORE ) + END IF +#endif ! -!/MPI DEALLOCATE ( IRQ ) +#ifdef W3_MPI + DEALLOCATE ( IRQ ) +#endif ! ! -------------------------------------------------------------------- / ! 5. Convert spectra ( !/SHRD only ) ! -!/SHRD IF ( RESPEC(J,IMOD) ) THEN -!/SHRD SBPI => BPSTGE(J,IMOD)%SBPI -!/SHRD CALL W3CSPC ( TSTORE, NK, NTH, XFR, FR1, TH(1), & -!/SHRD SBPI, SGRDS(J)%NK, SGRDS(J)%NTH, SGRDS(J)%XFR, & -!/SHRD SGRDS(J)%FR1, SGRDS(J)%TH(1), NBI2G(J,IMOD), & -!/SHRD MDST, MDSE, SGRDS(J)%FACHFE ) -!/SHRD DEALLOCATE ( TSTORE ) -!/SHRD END IF +#ifdef W3_SHRD + IF ( RESPEC(J,IMOD) ) THEN + SBPI => BPSTGE(J,IMOD)%SBPI + CALL W3CSPC ( TSTORE, NK, NTH, XFR, FR1, TH(1), & + SBPI, SGRDS(J)%NK, SGRDS(J)%NTH, SGRDS(J)%XFR, & + SGRDS(J)%FR1, SGRDS(J)%TH(1), NBI2G(J,IMOD), & + MDST, MDSE, SGRDS(J)%FACHFE ) + DEALLOCATE ( TSTORE ) + END IF +#endif ! ! ... End of loop over grids ! @@ -354,27 +414,37 @@ SUBROUTINE WMIOBS ( IMOD ) ! ! Formats ! -!/MPI 1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', & -!/MPI ' UPPER BOUND (MTAG1) ***') -!/T 9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',I3) -!/T 9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ & -!/T ' ',25I4) -! -!/T 9010 FORMAT ( ' TEST WMIOBS : STAGING',I4,' SPECTRA FROM GRID ', & -!/T I3,' TO GRID ',I3/ & -!/T ' STARTING WITH SPECTRUM ',I4, & -!/T ', RESPEC =',L2) -! -!/T 9030 FORMAT ( ' TEST WMIOBS : TIME :',I10.8,I7.6) -! -!/MPIT 9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9081 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') -!/MPIT 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9083 FORMAT ( ' +------+------+------+------+--------------+') -!/MPIT 9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',I10/) +#ifdef W3_MPI + 1001 FORMAT (/' *** ERROR WMIOBS : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG1) ***') +#endif +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOBS : STAGING DATA FROM GRID ',I3) + 9001 FORMAT ( ' TEST WMIOBS : NR. OF SPECTRA PER GRID : '/ & + ' ',25I4) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOBS : STAGING',I4,' SPECTRA FROM GRID ', & + I3,' TO GRID ',I3/ & + ' STARTING WITH SPECTRUM ',I4, & + ', RESPEC =',L2) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMIOBS : TIME :',I10.8,I7.6) +#endif +! +#ifdef W3_MPIT + 9080 FORMAT (/' MPIT WMIOBS: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9081 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') + 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9083 FORMAT ( ' +------+------+------+------+--------------+') + 9084 FORMAT ( ' MPIT WMIOBS: NRQBPT:',I10/) +#endif !/ !/ End of WMIOBS ----------------------------------------------------- / !/ @@ -479,11 +549,15 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) USE W3IOBCMD, ONLY: W3IOBC USE W3SERVMD, ONLY: EXTCDE ! USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC_GLOB -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -495,30 +569,48 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) !/ Local parameters !/ INTEGER :: J, I, IOFF, TTEST(2), ITEST -!/MPI INTEGER :: IERR_MPI, IT0, ITAG, IFROM, & -!/MPI ISEA, JSEA, ISPROC -!/MPIT INTEGER :: ICOUNT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI, IT0, ITAG, IFROM, & + ISEA, JSEA, ISPROC +#endif +#ifdef W3_MPIT + INTEGER :: ICOUNT +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, POINTER :: VTIME(:) -!/MPI INTEGER, POINTER :: NRQ, IRQ(:) -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif REAL :: DTTST, DT1, DT2, W1, W2 REAL, POINTER :: SBPI(:,:) -!/MPI REAL, ALLOCATABLE :: TSTORE(:,:) -!/MPI LOGICAL :: FLAGOK -!/MPIT LOGICAL :: FLAG -!/ -!/S CALL STRACE (IENT, 'WMIOBG') -!/DEBUGIOBC WRITE(740+IAPROC,*) 'Begin of W3IOBG' -!/DEBUGIOBC FLUSH(740+IAPROC) +#ifdef W3_MPI + REAL, ALLOCATABLE :: TSTORE(:,:) + LOGICAL :: FLAGOK +#endif +#ifdef W3_MPIT + LOGICAL :: FLAG +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'WMIOBG') +#endif +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'Begin of W3IOBG' + FLUSH(740+IAPROC) +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD -!/T WRITE (MDST,9001) NBI2G(IMOD,:) +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) NBI2G(IMOD,:) +#endif ! IF ( PRESENT(DONE) ) DONE = .FALSE. ! @@ -526,13 +618,17 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) ! IF ( IAPROC .GT. NAPROC ) THEN IF ( PRESENT(DONE) ) DONE = .TRUE. -!/T WRITE (MDST,9002) +#ifdef W3_T + WRITE (MDST,9002) +#endif RETURN END IF ! IF ( SUM(NBI2G(IMOD,:)) .EQ. 0 ) THEN IF ( PRESENT(DONE) ) DONE = .TRUE. -!/T WRITE (MDST,9003) +#ifdef W3_T + WRITE (MDST,9003) +#endif RETURN END IF ! @@ -543,7 +639,9 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) IF ( TBPIN(1) .NE. -1 ) THEN IF ( DSEC21(TIME,TBPIN) .GT. 0. ) THEN IF ( PRESENT(DONE) ) DONE = .TRUE. -!/T WRITE (MDST,9004) +#ifdef W3_T + WRITE (MDST,9004) +#endif RETURN END IF END IF @@ -551,233 +649,357 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) ! -------------------------------------------------------------------- / ! 1. Testing / gathering data in staging arrays ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / ! -!/SHRD DO J=1, NRGRD +#ifdef W3_SHRD + DO J=1, NRGRD +#endif ! -!/SHRD IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE -!/SHRD VTIME => BPSTGE(IMOD,J)%VTIME +#ifdef W3_SHRD + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE + VTIME => BPSTGE(IMOD,J)%VTIME +#endif ! -!/SHRD IF ( VTIME(1) .EQ. -1 ) THEN -!/SHRD IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1001) -!/SHRD CALL EXTCDE ( 1001 ) -!/SHRD END IF +#ifdef W3_SHRD + IF ( VTIME(1) .EQ. -1 ) THEN + IF ( NMPROC .EQ. NMPERR ) WRITE (MDSE,1001) + CALL EXTCDE ( 1001 ) + END IF +#endif ! -!/SHRD DTTST = DSEC21 ( TIME, VTIME ) -!/SHRD IF ( DTTST.LE.0. .AND. TBPIN(1).NE.-1 ) RETURN +#ifdef W3_SHRD + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST.LE.0. .AND. TBPIN(1).NE.-1 ) RETURN +#endif ! -!/SHRD END DO +#ifdef W3_SHRD + END DO +#endif ! ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / ! -!/MPIT WRITE (MDST,9011) NBISTA(IMOD) +#ifdef W3_MPIT + WRITE (MDST,9011) NBISTA(IMOD) +#endif ! ! 1.b.1 NBISTA = 0 ! Check if staging arrays are initialized. ! Post the proper receives. ! -!/MPI IF ( NBISTA(IMOD) .EQ. 0 ) THEN +#ifdef W3_MPI + IF ( NBISTA(IMOD) .EQ. 0 ) THEN +#endif ! -!/MPI NRQ => MDATAS(IMOD)%NRQBPG -!/MPI NRQ = NRGRD + SUM(NBI2G(IMOD,:)) -!/MPI ALLOCATE ( MDATAS(IMOD)%IRQBPG(NRQ) ) -!/MPI IRQ => MDATAS(IMOD)%IRQBPG -!/MPI IRQ = 0 -!/MPI NRQ = 0 +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQBPG + NRQ = NRGRD + SUM(NBI2G(IMOD,:)) + ALLOCATE ( MDATAS(IMOD)%IRQBPG(NRQ) ) + IRQ => MDATAS(IMOD)%IRQBPG + IRQ = 0 + NRQ = 0 +#endif ! -!/MPI DO J=1, NRGRD -!/MPI IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE +#ifdef W3_MPI + DO J=1, NRGRD + IF ( NBI2G(IMOD,J) .EQ. 0 ) CYCLE +#endif ! ! ..... Staging arrays ! -!/MPI IF ( BPSTGE(IMOD,J)%INIT ) THEN -!/MPI IF ( RESPEC(IMOD,J) ) THEN -!/MPI DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) -!/MPI BPSTGE(IMOD,J)%INIT = .FALSE. -!/MPIT WRITE (MDST,9012) J, 'RESET' -!/MPI ELSE -!/MPI IF ( SIZE(BPSTGE(IMOD,J)%SBPI(:,1)) .NE. & -!/MPI SGRDS(J)%NSPEC .OR. & -!/MPI SIZE(BPSTGE(IMOD,J)%SBPI(1,:)) .NE. & -!/MPI NBI2G(IMOD,J) ) THEN -!/MPI IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) -!/MPI CALL EXTCDE (1003) -!/MPI END IF -!/MPIT WRITE (MDST,9012) J, 'TESTED' -!/MPI END IF -!/MPI END IF -! -!/MPI IF ( .NOT. BPSTGE(IMOD,J)%INIT ) THEN -!/MPI NSPEC => SGRDS(J)%NSPEC -!/MPI ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) -!/MPI NSPEC => SGRDS(IMOD)%NSPEC -!/MPI BPSTGE(IMOD,J)%INIT = .TRUE. -!/MPIT WRITE (MDST,9012) J, 'INITIALIZED' -!/MPI END IF +#ifdef W3_MPI + IF ( BPSTGE(IMOD,J)%INIT ) THEN + IF ( RESPEC(IMOD,J) ) THEN + DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) + BPSTGE(IMOD,J)%INIT = .FALSE. +#endif +#ifdef W3_MPIT + WRITE (MDST,9012) J, 'RESET' +#endif +#ifdef W3_MPI + ELSE + IF ( SIZE(BPSTGE(IMOD,J)%SBPI(:,1)) .NE. & + SGRDS(J)%NSPEC .OR. & + SIZE(BPSTGE(IMOD,J)%SBPI(1,:)) .NE. & + NBI2G(IMOD,J) ) THEN + IF ( IMPROC .EQ. NMPERR ) WRITE (MDSE,1003) + CALL EXTCDE (1003) + END IF +#endif +#ifdef W3_MPIT + WRITE (MDST,9012) J, 'TESTED' +#endif +#ifdef W3_MPI + END IF + END IF +#endif +! +#ifdef W3_MPI + IF ( .NOT. BPSTGE(IMOD,J)%INIT ) THEN + NSPEC => SGRDS(J)%NSPEC + ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) + NSPEC => SGRDS(IMOD)%NSPEC + BPSTGE(IMOD,J)%INIT = .TRUE. +#endif +#ifdef W3_MPIT + WRITE (MDST,9012) J, 'INITIALIZED' +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... Check valid time to determine staging. ! -!/MPI VTIME => BPSTGE(IMOD,J)%VTIME -!/MPI IF ( VTIME(1) .EQ. -1 ) THEN -!/MPI DTTST = 0. -!/MPI ELSE -!/MPI DTTST = DSEC21 ( TIME, VTIME ) -!/MPI END IF -!/MPIT WRITE (MDST,9013) VTIME, DTTST +#ifdef W3_MPI + VTIME => BPSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 0. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF +#endif +#ifdef W3_MPIT + WRITE (MDST,9013) VTIME, DTTST +#endif ! ! ..... Post receives for data gather ! -!/MPI IF ( DTTST .LE. 0. ) THEN -!/MPIT WRITE (MDST,9014) J +#ifdef W3_MPI + IF ( DTTST .LE. 0. ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9014) J +#endif ! ! ..... Time ! -!/MPI ITAG = MTAG0 + J + (IMOD-1)*NRGRD -!/MPI IFROM = MDATAS(J)%CROOT - 1 -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_IRECV ( BPSTGE(IMOD,J)%VTIME, 2, & -!/MPI MPI_INTEGER, IFROM, ITAG, & -!/MPI MPI_COMM_MWAVE, IRQ(NRQ), & -!/MPI IERR_MPI ) -!/MPIT WRITE (MDST,9015) NRQ, IFROM+1, ITAG-MTAG0, & -!/MPIT IRQ(NRQ), IERR_MPI +#ifdef W3_MPI + ITAG = MTAG0 + J + (IMOD-1)*NRGRD + IFROM = MDATAS(J)%CROOT - 1 + NRQ = NRQ + 1 + CALL MPI_IRECV ( BPSTGE(IMOD,J)%VTIME, 2, & + MPI_INTEGER, IFROM, ITAG, & + MPI_COMM_MWAVE, IRQ(NRQ), & + IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9015) NRQ, IFROM+1, ITAG-MTAG0, & + IRQ(NRQ), IERR_MPI +#endif ! ! ..... Spectra ! -!/MPI IF ( J .EQ. 1 ) THEN -!/MPI IOFF = 0 -!/MPI ELSE -!/MPI IOFF = SUM(NBI2G(IMOD,1:J-1)) -!/MPI END IF -! -!/MPI IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:IMOD-1,:)) & -!/MPI + SUM(NBI2G(IMOD,1:J-1)) -! -!/MPI SBPI => BPSTGE(IMOD,J)%SBPI -! -!/MPI NAPROC => OUTPTS(J)%NAPROC -!/MPI NSPEC => SGRDS(J)%NSPEC -!/MPI DO I=1, NBI2G(IMOD,J) -!/MPI ISEA = NBI2S(IOFF+I,2) -!/MPI CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) -!/MPI NRQ = NRQ + 1 -!/MPI ITAG = IT0 + I -!/MPI CALL MPI_IRECV ( SBPI(1,I), NSPEC, & -!/MPI MPI_REAL, ISPROC-1, & -!/MPI ITAG, MPI_COMM_MWAVE, & -!/MPI IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9016) NRQ, JSEA, ISPROC, & -!/MPIT ITAG-MTAG0, IRQ(NRQ), IERR_MPI -!/MPI END DO -!/MPI NSPEC => SGRDS(IMOD)%NSPEC -!/MPI NAPROC => OUTPTS(IMOD)%NAPROC +#ifdef W3_MPI + IF ( J .EQ. 1 ) THEN + IOFF = 0 + ELSE + IOFF = SUM(NBI2G(IMOD,1:J-1)) + END IF +#endif +! +#ifdef W3_MPI + IT0 = MTAG0 + NRGRD**2 + SUM(NBI2G(1:IMOD-1,:)) & + + SUM(NBI2G(IMOD,1:J-1)) +#endif +! +#ifdef W3_MPI + SBPI => BPSTGE(IMOD,J)%SBPI +#endif +! +#ifdef W3_MPI + NAPROC => OUTPTS(J)%NAPROC + NSPEC => SGRDS(J)%NSPEC + DO I=1, NBI2G(IMOD,J) + ISEA = NBI2S(IOFF+I,2) + CALL INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) + NRQ = NRQ + 1 + ITAG = IT0 + I + CALL MPI_IRECV ( SBPI(1,I), NSPEC, & + MPI_REAL, ISPROC-1, & + ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9016) NRQ, JSEA, ISPROC, & + ITAG-MTAG0, IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + END DO + NSPEC => SGRDS(IMOD)%NSPEC + NAPROC => OUTPTS(IMOD)%NAPROC +#endif ! ! ..... End IF for posting receives 1.b.1 ! -!/MPIT WRITE (MDST,9017) -!/MPI END IF +#ifdef W3_MPIT + WRITE (MDST,9017) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End grid loop J in 1.b.1 ! -!/MPI END DO -!/MPIT WRITE (MDST,9018) NRQ +#ifdef W3_MPI + END DO +#endif +#ifdef W3_MPIT + WRITE (MDST,9018) NRQ +#endif ! ! ..... Reset status ! NOTE: if NBI.EQ.0 all times are already OK, skip to section 2 ! -!/MPI IF ( NBI .GT. 0 ) THEN -!/MPI NBISTA(IMOD) = 1 -!/MPIT WRITE (MDST,9011) NBISTA(IMOD) -!/MPI END IF +#ifdef W3_MPI + IF ( NBI .GT. 0 ) THEN + NBISTA(IMOD) = 1 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) NBISTA(IMOD) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End IF in 1.b.1 ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! 1.b.2 NBISTA = 1 ! Wait for communication to finish. ! If DONE defined, check if done, otherwise wait. ! -!/MPI IF ( NBISTA(IMOD) .EQ. 1 ) THEN +#ifdef W3_MPI + IF ( NBISTA(IMOD) .EQ. 1 ) THEN +#endif ! -!/MPI NRQ => MDATAS(IMOD)%NRQBPG -!/MPI IRQ => MDATAS(IMOD)%IRQBPG -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQBPG + IRQ => MDATAS(IMOD)%IRQBPG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#endif ! ! ..... Test communication if DONE is present, wait otherwise ! -!/MPI IF ( PRESENT(DONE) ) THEN -! -!/MPI CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & -!/MPI IERR_MPI ) -! -!/MPIT ICOUNT = 0 -!/MPIT DO I=1, NRQ -!/MPIT CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & -!/MPIT IERR_MPI ) -!/MPIT FLAGOK = FLAGOK .AND. FLAG -!/MPIT IF ( FLAG ) ICOUNT = ICOUNT + 1 -!/MPIT END DO -!/MPIT WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) -! -!/MPI ELSE -! -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI FLAGOK = .TRUE. -! -!/MPI END IF +#ifdef W3_MPI + IF ( PRESENT(DONE) ) THEN +#endif +! +#ifdef W3_MPI + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) +#endif +! +#ifdef W3_MPIT + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) +#endif +! +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPI + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. +#endif +! +#ifdef W3_MPI + END IF +#endif ! -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + DEALLOCATE ( STATUS ) +#endif ! ! ..... Go on based on FLAGOK ! -!/MPI IF ( FLAGOK ) THEN -!/MPI DEALLOCATE ( MDATAS(IMOD)%IRQBPG ) -!/MPI NRQ = 0 -!/MPI ELSE -!/MPI RETURN -!/MPI END IF -! -!/MPI NBISTA(IMOD) = 2 -!/MPIT WRITE (MDST,9011) NBISTA(IMOD) +#ifdef W3_MPI + IF ( FLAGOK ) THEN + DEALLOCATE ( MDATAS(IMOD)%IRQBPG ) + NRQ = 0 + ELSE + RETURN + END IF +#endif +! +#ifdef W3_MPI + NBISTA(IMOD) = 2 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) NBISTA(IMOD) +#endif ! ! 1.b.3 Convert spectra if needed ! -!/MPI DO J=1, NRGRD -! -!/MPI IF ( RESPEC(IMOD,J) .AND. NBI2G(IMOD,J).NE.0 ) THEN -! -!/MPIT WRITE (MDST,9100) J -!/MPI NSPEC => SGRDS(J)%NSPEC -!/MPI ALLOCATE ( TSTORE(NSPEC,NBI2G(IMOD,J))) -!/MPI NSPEC => SGRDS(IMOD)%NSPEC -!/MPI TSTORE = BPSTGE(IMOD,J)%SBPI -!/MPI DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) -!/MPI ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) -! -!/MPI SBPI => BPSTGE(IMOD,J)%SBPI -!/MPI CALL W3CSPC ( TSTORE, SGRDS(J)%NK, SGRDS(J)%NTH, & -!/MPI SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & -!/MPI SBPI, NK, NTH, XFR, FR1, TH(1), & -!/MPI NBI2G(IMOD,J), MDST, MDSE, SGRDS(IMOD)%FACHFE) -! -!/MPI DEALLOCATE ( TSTORE ) -! -!/MPI END IF +#ifdef W3_MPI + DO J=1, NRGRD +#endif +! +#ifdef W3_MPI + IF ( RESPEC(IMOD,J) .AND. NBI2G(IMOD,J).NE.0 ) THEN +#endif +! +#ifdef W3_MPIT + WRITE (MDST,9100) J +#endif +#ifdef W3_MPI + NSPEC => SGRDS(J)%NSPEC + ALLOCATE ( TSTORE(NSPEC,NBI2G(IMOD,J))) + NSPEC => SGRDS(IMOD)%NSPEC + TSTORE = BPSTGE(IMOD,J)%SBPI + DEALLOCATE ( BPSTGE(IMOD,J)%SBPI ) + ALLOCATE (BPSTGE(IMOD,J)%SBPI(NSPEC,NBI2G(IMOD,J))) +#endif +! +#ifdef W3_MPI + SBPI => BPSTGE(IMOD,J)%SBPI + CALL W3CSPC ( TSTORE, SGRDS(J)%NK, SGRDS(J)%NTH, & + SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & + SBPI, NK, NTH, XFR, FR1, TH(1), & + NBI2G(IMOD,J), MDST, MDSE, SGRDS(IMOD)%FACHFE) +#endif +! +#ifdef W3_MPI + DEALLOCATE ( TSTORE ) +#endif +! +#ifdef W3_MPI + END IF +#endif ! -!/MPI END DO +#ifdef W3_MPI + END DO +#endif ! -!/MPI NBISTA(IMOD) = 0 -!/MPIT WRITE (MDST,9011) NBISTA(IMOD) +#ifdef W3_MPI + NBISTA(IMOD) = 0 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) NBISTA(IMOD) +#endif ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! -------------------------------------------------------------------- / ! 2. Update arrays ABPI0/N and data times ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! ! 2.a Determine next valid time ! @@ -793,7 +1015,9 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) END IF END DO ! -!/T WRITE (MDST,9021) TTEST +#ifdef W3_T + WRITE (MDST,9021) TTEST +#endif ! ! 2.b Shift data ! @@ -832,7 +1056,9 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) W2 = DT2 / DT1 W1 = 1. - W2 END IF -!/T WRITE (MDST,9022) NBI2G(IMOD,J), J, IOFF+1, W1, W2 +#ifdef W3_T + WRITE (MDST,9022) NBI2G(IMOD,J), J, IOFF+1, W1, W2 +#endif ! ABPIN(:,IOFF+1:IOFF+NBI2G(IMOD,J)) = & W1 * ABPI0(:,IOFF+1:IOFF+NBI2G(IMOD,J)) + & @@ -848,14 +1074,18 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) ! 3. Dump data to file if requested ! IF ( IAPROC.EQ.NAPBPT .AND. BCDUMP(IMOD) ) THEN -!/T WRITE (MDST,9030) +#ifdef W3_T + WRITE (MDST,9030) +#endif CALL W3IOBC ( 'DUMP', NDS(9), TBPIN, TBPIN, ITEST, IMOD ) END IF ! ! -------------------------------------------------------------------- / ! 4. Update arrays BBPI0/N ! -!/T WRITE (MDST,9040) +#ifdef W3_T + WRITE (MDST,9040) +#endif ! CALL W3UBPT ! @@ -863,51 +1093,69 @@ SUBROUTINE WMIOBG ( IMOD, DONE ) ! 5. Successful update ! IF ( PRESENT(DONE) ) DONE = .TRUE. -!/DEBUGIOBC WRITE(740+IAPROC,*) 'End of W3IOBG' -!/DEBUGIOBC FLUSH(740+IAPROC) +#ifdef W3_DEBUGIOBC + WRITE(740+IAPROC,*) 'End of W3IOBG' + FLUSH(740+IAPROC) +#endif ! RETURN ! ! Formats ! -!/SHRD 1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ & -!/SHRD ' CALL WMIOBS FIRST '/) +#ifdef W3_SHRD + 1001 FORMAT (/' *** ERROR WMIOBG : NO DATA IN STAGING ARRAY ***'/ & + ' CALL WMIOBS FIRST '/) +#endif 1002 FORMAT (/' *** ERROR WMIOBG : INITIAL DATA NOT AT INITAL ', & 'MODEL TIME ***'/) -!/MPI 1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', & -!/MPI ' ARRAY ***') -! -!/T 9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',I3) -!/T 9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ & -!/T ' ',25I4) -!/T 9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR') -!/T 9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED') -!/T 9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE') -! -!/T 9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY') -!/MPIT 9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',I2) -!/MPIT 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) -!/MPIT 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) -!/MPIT 9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',I4/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | FROM | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9015 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') -!/MPIT 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9017 FORMAT ( ' +------+------+------+------+--------------+'/) -!/MPIT 9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',I10/) -!/MPIT 9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',F6.1,'%') -!/MPIT 9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',I3) -! -!/T 9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES') -!/T 9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',I9.8,I7.6) -!/T 9022 FORMAT ( ' TEST WMIOBG : GETTING',I4,' SPECTRA FROM GRID ', & -!/T I3,' STORING AT ',I3/ & -!/T ' WEIGHTS : ',2F6.3) -! -!/T 9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE') -! -!/T 9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N') +#ifdef W3_MPI + 1003 FORMAT (/' *** ERROR WMIOBG : UNEXPECTED SIZE OF STAGING', & + ' ARRAY ***') +#endif +! +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOBG : GATHERING DATA FOR GRID ',I3) + 9001 FORMAT ( ' TEST WMIOBG : NR. OF SPECTRA PER SOURCE GRID : '/ & + ' ',25I4) + 9002 FORMAT ( ' TEST WMIOBG : NO DATA NEEDED ON PROCESSOR') + 9003 FORMAT ( ' TEST WMIOBG : NO DATA TO BE GATHERED') + 9004 FORMAT ( ' TEST WMIOBG : DATA UP TO DATE') +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOBG : TEST DATA AVAILABILITY') +#endif +#ifdef W3_MPIT + 9011 FORMAT ( ' MPIT WMIOBG : NBISTA =',I2) + 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) + 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) + 9014 FORMAT (/' MPIT WMIOBG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9015 FORMAT ( ' |',I5,' | TIME |',2(I5,' |'),I9,I4,' |') + 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9017 FORMAT ( ' +------+------+------+------+--------------+'/) + 9018 FORMAT ( ' MPIT WMIOBG : NRQHGH:',I10/) + 9019 FORMAT ( ' MPIT WMIOBG : RECEIVES FINISHED :',F6.1,'%') + 9100 FORMAT ( ' MPIT WMIOBG : CONVERTING SPECTRA FROM GRID',I3) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMIOBG : FILLING ABPI0/N AND TIMES') + 9021 FORMAT ( ' TEST WMIOBG : NEXT VALID TIME FOR ABPIN:',I9.8,I7.6) + 9022 FORMAT ( ' TEST WMIOBG : GETTING',I4,' SPECTRA FROM GRID ', & + I3,' STORING AT ',I3/ & + ' WEIGHTS : ',2F6.3) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMIOBG : DUMP DATA TO FILE') +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST WMIOBG : FILLING BBPI0/N') +#endif !/ !/ End of WMIOBG ----------------------------------------------------- / !/ @@ -984,11 +1232,15 @@ SUBROUTINE WMIOBF ( IMOD ) ! USE WMMDATMD ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -999,43 +1251,61 @@ SUBROUTINE WMIOBF ( IMOD ) !/ Local parameters !/ INTEGER :: J -!/MPI INTEGER :: IERR_MPI -!/MPI INTEGER, POINTER :: NRQ, IRQ(:) -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) -!/S INTEGER, SAVE :: IENT = 0 -!/ -!/S CALL STRACE (IENT, 'WMIOBF') +#ifdef W3_MPI + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'WMIOBF') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 1. Loop over grids ! DO J=1, NRGRD ! -!/MPI NRQ => BPSTGE(J,IMOD)%NRQBPS +#ifdef W3_MPI + NRQ => BPSTGE(J,IMOD)%NRQBPS +#endif ! ! 1.a Nothing to finalize ! -!/MPI IF ( NRQ .EQ. 0 ) CYCLE -!/MPI IRQ => BPSTGE(J,IMOD)%IRQBPS +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => BPSTGE(J,IMOD)%IRQBPS +#endif ! ! 1.b Wait for communication to end ! -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif ! ! 1.c Reset arrays and counter ! -!/MPI NRQ = 0 -!/MPI DEALLOCATE ( BPSTGE(J,IMOD)%IRQBPS , & -!/MPI BPSTGE(J,IMOD)%TSTORE ) +#ifdef W3_MPI + NRQ = 0 + DEALLOCATE ( BPSTGE(J,IMOD)%IRQBPS , & + BPSTGE(J,IMOD)%TSTORE ) +#endif ! -!/T WRITE (MDST,9010) J +#ifdef W3_T + WRITE (MDST,9010) J +#endif ! END DO ! @@ -1043,8 +1313,10 @@ SUBROUTINE WMIOBF ( IMOD ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',I3) -!/T 9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',I3) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOBF : FINALIZE STAGING DATA FROM GRID ',I3) + 9010 FORMAT ( ' TEST WMIOBF : FINISHED WITH TARGET ',I3) +#endif !/ !/ End of WMIOBF ----------------------------------------------------- / !/ @@ -1129,13 +1401,17 @@ SUBROUTINE WMIOHS ( IMOD ) USE WMMDATMD ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD, ONLY: DSEC21 USE W3PARALL, ONLY: INIT_GET_ISEA ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1146,26 +1422,44 @@ SUBROUTINE WMIOHS ( IMOD ) !/ Local parameters !/ INTEGER :: J, NR, I, JSEA, ISEA, IS -!/MPI INTEGER :: ITAG, IP, IT0, IERR_MPI +#ifdef W3_MPI + INTEGER :: ITAG, IP, IT0, IERR_MPI +#endif INTEGER :: I1, I2 -!/S INTEGER, SAVE :: IENT = 0 -!/MPI INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) +#endif REAL :: DTOUTP -!/SHRD REAL, POINTER :: SHGH(:,:,:) -!/MPI REAL, POINTER :: SHGH(:,:) +#ifdef W3_SHRD + REAL, POINTER :: SHGH(:,:,:) +#endif +#ifdef W3_MPI + REAL, POINTER :: SHGH(:,:) +#endif !/ -!/S CALL STRACE (IENT, 'WMIOHS') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOHS') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD, FLGHG1 +#ifdef W3_T + WRITE (MDST,9000) IMOD, FLGHG1 +#endif ! IF ( .NOT. FLGHG1 ) THEN -!/T WRITE (MDST,9001) HGSTGE(:,IMOD)%NSND +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(:,IMOD)%NSND +#endif IF ( SUM(HGSTGE(:,IMOD)%NSND) .EQ. 0 ) RETURN ELSE -!/T WRITE (MDST,9001) HGSTGE(:,IMOD)%NSN1 +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(:,IMOD)%NSN1 +#endif IF ( SUM(HGSTGE(:,IMOD)%NSN1) .EQ. 0 ) RETURN END IF ! @@ -1198,11 +1492,13 @@ SUBROUTINE WMIOHS ( IMOD ) END IF END IF ! -!/T IF ( NR .EQ. 0 ) THEN -!/T WRITE (MDST,9010) J, NR -!/T ELSE -!/T WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)), DTOUTP -!/T END IF +#ifdef W3_T + IF ( NR .EQ. 0 ) THEN + WRITE (MDST,9010) J, NR + ELSE + WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)), DTOUTP + END IF +#endif ! IF ( NR .EQ. 0 ) CYCLE IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) CYCLE @@ -1210,72 +1506,104 @@ SUBROUTINE WMIOHS ( IMOD ) ! -------------------------------------------------------------------- / ! 2. Allocate arrays and/or point pointers ! -!/SHRD SHGH => HGSTGE(J,IMOD)%SHGH -!/MPI ALLOCATE ( HGSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) -!/MPI SHGH => HGSTGE(J,IMOD)%TSTORE -! -!/MPI ALLOCATE ( HGSTGE(J,IMOD)%IRQHGS(NR) ) -!/MPI ALLOCATE ( HGSTGE(J,IMOD)%OUTDAT(NR,3) ) -! -!/MPI NRQ => HGSTGE(J,IMOD)%NRQHGS -!/MPI NRQOUT => HGSTGE(J,IMOD)%NRQOUT -!/MPI IRQ => HGSTGE(J,IMOD)%IRQHGS -!/MPI OUTDAT => HGSTGE(J,IMOD)%OUTDAT -!/MPI NRQ = 0 -!/MPI NRQOUT = 0 -!/MPI IRQ = 0 +#ifdef W3_SHRD + SHGH => HGSTGE(J,IMOD)%SHGH +#endif +#ifdef W3_MPI + ALLOCATE ( HGSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) + SHGH => HGSTGE(J,IMOD)%TSTORE +#endif +! +#ifdef W3_MPI + ALLOCATE ( HGSTGE(J,IMOD)%IRQHGS(NR) ) + ALLOCATE ( HGSTGE(J,IMOD)%OUTDAT(NR,3) ) +#endif +! +#ifdef W3_MPI + NRQ => HGSTGE(J,IMOD)%NRQHGS + NRQOUT => HGSTGE(J,IMOD)%NRQOUT + IRQ => HGSTGE(J,IMOD)%IRQHGS + OUTDAT => HGSTGE(J,IMOD)%OUTDAT + NRQ = 0 + NRQOUT = 0 + IRQ = 0 +#endif ! ! -------------------------------------------------------------------- / ! 3. Set the time ! !/SHRD only. ! -!/T WRITE (MDST,9030) TIME +#ifdef W3_T + WRITE (MDST,9030) TIME +#endif ! -!/SHRD HGSTGE(J,IMOD)%VTIME = TIME +#ifdef W3_SHRD + HGSTGE(J,IMOD)%VTIME = TIME +#endif ! ! -------------------------------------------------------------------- / ! 4. Stage the spectral data ! -!/MPIT WRITE (MDST,9080) -!/MPI IT0 = MTAG1 + 1 +#ifdef W3_MPIT + WRITE (MDST,9080) +#endif +#ifdef W3_MPI + IT0 = MTAG1 + 1 +#endif ! DO I=1, NR ! JSEA = HGSTGE(J,IMOD)%ISEND(I,1) CALL INIT_GET_ISEA(ISEA, JSEA) -!/DIST IP = HGSTGE(J,IMOD)%ISEND(I,2) +#ifdef W3_DIST + IP = HGSTGE(J,IMOD)%ISEND(I,2) +#endif I1 = HGSTGE(J,IMOD)%ISEND(I,3) I2 = HGSTGE(J,IMOD)%ISEND(I,4) -!/MPI ITAG = HGSTGE(J,IMOD)%ISEND(I,5) + IT0 -!/MPI IF ( ITAG .GT. MTAG2 ) THEN -!/MPI WRITE (MDSE,1001) -!/MPI CALL EXTCDE (1001) -!/MPI END IF +#ifdef W3_MPI + ITAG = HGSTGE(J,IMOD)%ISEND(I,5) + IT0 + IF ( ITAG .GT. MTAG2 ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF +#endif ! DO IS=1, NSPEC -!/SHRD SHGH(IS,I2,I1) = VA(IS,JSEA) * SIG2(IS) & -!/SHRD / CG(1+(IS-1)/NTH,ISEA) -!/MPI SHGH( IS,I ) = VA(IS,JSEA) * SIG2(IS) & -!/MPI / CG(1+(IS-1)/NTH,ISEA) +#ifdef W3_SHRD + SHGH(IS,I2,I1) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) +#endif +#ifdef W3_MPI + SHGH( IS,I ) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) +#endif END DO ! -!/MPI IF ( IP .NE. IMPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_ISEND ( SHGH(1,I), NSPEC, MPI_REAL, IP-1, & -!/MPI ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG1, & -!/MPIT IRQ(NRQ), IERR_MPI -!/MPI ELSE -!/MPI NRQOUT = NRQOUT + 1 -!/MPI OUTDAT(NRQOUT,1) = I -!/MPI OUTDAT(NRQOUT,2) = I2 -!/MPI OUTDAT(NRQOUT,3) = I1 -!/MPI END IF +#ifdef W3_MPI + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( SHGH(1,I), NSPEC, MPI_REAL, IP-1, & + ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG1, & + IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + ELSE + NRQOUT = NRQOUT + 1 + OUTDAT(NRQOUT,1) = I + OUTDAT(NRQOUT,2) = I2 + OUTDAT(NRQOUT,3) = I1 + END IF +#endif ! END DO ! -!/MPIT WRITE (MDST,9083) -!/MPIT WRITE (MDST,9084) NRQ +#ifdef W3_MPIT + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ +#endif ! END DO ! @@ -1283,27 +1611,37 @@ SUBROUTINE WMIOHS ( IMOD ) ! ! Formats ! -!/MPI 1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', & -!/MPI ' UPPER BOUND (MTAG2) ***') -!/T 9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',I3, & -!/T ' FLGHG1 = ',L1) -!/T 9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ & -!/T ' ',15I6) -! -!/T 9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & -!/T ' NR = ',I6) -!/T 9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & -!/T ' NR = ',I6,' TIME GAP = ',2F8.1) -! -!/T 9030 FORMAT ( ' TEST WMIOHS : TIME :',I10.8,I7.6) -! -!/MPIT 9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9083 FORMAT ( ' +------+------+------+------+--------------+') -!/MPIT 9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',I10/) +#ifdef W3_MPI + 1001 FORMAT (/' *** ERROR WMIOHS : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG2) ***') +#endif +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOHS : STAGING DATA FROM GRID ',I3, & + ' FLGHG1 = ',L1) + 9001 FORMAT ( ' TEST WMIOHS : NR. OF SPECTRA PER GRID : '/ & + ' ',15I6) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & + ' NR = ',I6) + 9011 FORMAT ( ' TEST WMIOHS : POSTING DATA TO GRID ',I3, & + ' NR = ',I6,' TIME GAP = ',2F8.1) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMIOHS : TIME :',I10.8,I7.6) +#endif +! +#ifdef W3_MPIT + 9080 FORMAT (/' MPIT WMIOHS: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9083 FORMAT ( ' +------+------+------+------+--------------+') + 9084 FORMAT ( ' MPIT WMIOHS: NRQHGS:',I10/) +#endif !/ !/ End of WMIOHS ----------------------------------------------------- / !/ @@ -1393,14 +1731,20 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) USE W3CSPCMD, ONLY: W3CSPC USE W3TIMEMD, ONLY: DSEC21 ! USE W3SERVMD, ONLY: EXTCDE -!/PDLIB use yowNodepool, only: npa -!/PDLIB USE yowExchangeModule, only : PDLIB_exchange2Dreal +#ifdef W3_PDLIB + use yowNodepool, only: npa + USE yowExchangeModule, only : PDLIB_exchange2Dreal +#endif USE W3PARALL, ONLY : INIT_GET_ISEA -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1412,20 +1756,34 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) !/ Local parameters !/ INTEGER :: NTOT, J, IS, NA, IA, JSEA, ISEA, I -!/MPI INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, & -!/MPI ISPROC, IERR_MPI, ICOUNT, & -!/MPI I0, I1, I2 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: ITAG, IT0, IFROM, ILOC, NLOC, & + ISPROC, IERR_MPI, ICOUNT, & + I0, I1, I2 +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, POINTER :: VTIME(:) -!/MPI INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) +#endif REAL :: DTTST, WGTH REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) -!/MPI REAL, POINTER :: SHGH(:,:,:) +#ifdef W3_MPI + REAL, POINTER :: SHGH(:,:,:) +#endif LOGICAL :: FLGALL -!/MPI LOGICAL :: FLAGOK -!/MPIT LOGICAL :: FLAG +#ifdef W3_MPI + LOGICAL :: FLAGOK +#endif +#ifdef W3_MPIT + LOGICAL :: FLAG +#endif !/ -!/S CALL STRACE (IENT, 'WMIOHG') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOHG') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations @@ -1446,13 +1804,19 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) FLGALL = .FALSE. END IF ! -!/T WRITE (MDST,9000) IMOD, DTTST, FLGALL +#ifdef W3_T + WRITE (MDST,9000) IMOD, DTTST, FLGALL +#endif ! IF ( FLGALL ) THEN -!/T WRITE (MDST,9001) HGSTGE(IMOD,:)%NREC +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(IMOD,:)%NREC +#endif NTOT = SUM(HGSTGE(IMOD,:)%NREC) ELSE -!/T WRITE (MDST,9001) HGSTGE(IMOD,:)%NRC1 +#ifdef W3_T + WRITE (MDST,9001) HGSTGE(IMOD,:)%NRC1 +#endif NTOT = SUM(HGSTGE(IMOD,:)%NRC1) END IF ! @@ -1460,7 +1824,9 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! IF ( NTOT .EQ. 0 ) THEN IF ( PRESENT(DONE) ) DONE = .TRUE. -!/T WRITE (MDST,9003) +#ifdef W3_T + WRITE (MDST,9003) +#endif RETURN END IF ! @@ -1472,191 +1838,281 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! -------------------------------------------------------------------- / ! 1. Testing / gathering data in staging arrays ! -!/T WRITE (MDST,9010) TIME +#ifdef W3_T + WRITE (MDST,9010) TIME +#endif ! ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / ! -!/SHRD DO J=1, NRGRD +#ifdef W3_SHRD + DO J=1, NRGRD +#endif ! -!/SHRD IF ( FLGALL ) THEN -!/SHRD NTOT = HGSTGE(IMOD,J)%NREC -!/SHRD ELSE -!/SHRD NTOT = HGSTGE(IMOD,J)%NRC1 -!/SHRD END IF -!/SHRD IF ( NTOT .EQ. 0 ) CYCLE +#ifdef W3_SHRD + IF ( FLGALL ) THEN + NTOT = HGSTGE(IMOD,J)%NREC + ELSE + NTOT = HGSTGE(IMOD,J)%NRC1 + END IF + IF ( NTOT .EQ. 0 ) CYCLE +#endif ! -!/SHRD VTIME => HGSTGE(IMOD,J)%VTIME -!/SHRD IF ( VTIME(1) .EQ. -1 ) RETURN -!/SHRD DTTST = DSEC21 ( TIME, VTIME ) -!/SHRD IF ( DTTST .NE. 0. ) RETURN +#ifdef W3_SHRD + VTIME => HGSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) RETURN + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST .NE. 0. ) RETURN +#endif ! -!/SHRD END DO +#ifdef W3_SHRD + END DO +#endif ! ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / ! -!/MPIT WRITE (MDST,9011) HGHSTA(IMOD) +#ifdef W3_MPIT + WRITE (MDST,9011) HGHSTA(IMOD) +#endif ! ! 1.b.1 HGHSTA = 0 ! Check if staging arrays are initialized. ! Post the proper receives. ! -!/MPI IF ( HGHSTA(IMOD) .EQ. 0 ) THEN -! -!/MPI NRQ => MDATAS(IMOD)%NRQHGG -!/MPI NRQ = 0 -!/MPI DO J=1, NRGRD -!/MPI IF ( FLGALL ) THEN -!/MPI NRQ = NRQ + HGSTGE(IMOD,J)%NREC * & -!/MPI HGSTGE(IMOD,J)%NSMX -!/MPI ELSE -!/MPI NRQ = NRQ + HGSTGE(IMOD,J)%NRC1 * & -!/MPI HGSTGE(IMOD,J)%NSMX -!/MPI END IF -!/MPI END DO -!/MPI NRQ = MAX(1,NRQ) -!/MPI ALLOCATE ( IRQ(NRQ) ) -!/MPI IRQ = 0 -!/MPI NRQ = 0 -! -!/MPI DO J=1, NRGRD -!/MPI IF ( HGSTGE(IMOD,J)%NTOT .EQ. 0 ) CYCLE +#ifdef W3_MPI + IF ( HGHSTA(IMOD) .EQ. 0 ) THEN +#endif +! +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQHGG + NRQ = 0 + DO J=1, NRGRD + IF ( FLGALL ) THEN + NRQ = NRQ + HGSTGE(IMOD,J)%NREC * & + HGSTGE(IMOD,J)%NSMX + ELSE + NRQ = NRQ + HGSTGE(IMOD,J)%NRC1 * & + HGSTGE(IMOD,J)%NSMX + END IF + END DO + NRQ = MAX(1,NRQ) + ALLOCATE ( IRQ(NRQ) ) + IRQ = 0 + NRQ = 0 +#endif +! +#ifdef W3_MPI + DO J=1, NRGRD + IF ( HGSTGE(IMOD,J)%NTOT .EQ. 0 ) CYCLE +#endif ! ! ..... Check valid time to determine staging. ! -!/MPI VTIME => HGSTGE(IMOD,J)%VTIME -!/MPI IF ( VTIME(1) .EQ. -1 ) THEN -!/MPI DTTST = 1. -!/MPI ELSE -!/MPI DTTST = DSEC21 ( TIME, VTIME ) -!/MPI END IF -!/MPIT WRITE (MDST,9013) VTIME, DTTST +#ifdef W3_MPI + VTIME => HGSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF +#endif +#ifdef W3_MPIT + WRITE (MDST,9013) VTIME, DTTST +#endif ! ! ..... Post receives for data gather ! -!/MPI IF ( DTTST .NE. 0. ) THEN -!/MPIT WRITE (MDST,9014) J +#ifdef W3_MPI + IF ( DTTST .NE. 0. ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9014) J +#endif ! ! ..... Spectra ! -!/MPI IT0 = MTAG1 + 1 -!/MPI SHGH => HGSTGE(IMOD,J)%SHGH -! -!/MPI IF ( FLGALL ) THEN -!/MPI NTOT = HGSTGE(IMOD,J)%NREC -!/MPI ELSE -!/MPI NTOT = HGSTGE(IMOD,J)%NRC1 -!/MPI END IF -! -!/MPI DO I=1, NTOT -!/MPIT JSEA = HGSTGE(IMOD,J)%LJSEA(I) -!/MPI NLOC = HGSTGE(IMOD,J)%NRAVG(I) -!/MPI DO ILOC=1, NLOC -!/MPI ISPROC = HGSTGE(IMOD,J)%IMPSRC(I,ILOC) -!/MPI ITAG = HGSTGE(IMOD,J)%ITAG(I,ILOC) + IT0 -!/MPI IF ( ISPROC .NE. IMPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_IRECV ( SHGH(1,ILOC,I), & -!/MPI SGRDS(J)%NSPEC, MPI_REAL, & -!/MPI ISPROC-1, ITAG, MPI_COMM_MWAVE, & -!/MPI IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9016) NRQ, JSEA, ISPROC, & -!/MPIT ITAG-MTAG1, IRQ(NRQ), IERR_MPI -!/MPI END IF -!/MPI END DO -!/MPI END DO +#ifdef W3_MPI + IT0 = MTAG1 + 1 + SHGH => HGSTGE(IMOD,J)%SHGH +#endif +! +#ifdef W3_MPI + IF ( FLGALL ) THEN + NTOT = HGSTGE(IMOD,J)%NREC + ELSE + NTOT = HGSTGE(IMOD,J)%NRC1 + END IF +#endif +! +#ifdef W3_MPI + DO I=1, NTOT +#endif +#ifdef W3_MPIT + JSEA = HGSTGE(IMOD,J)%LJSEA(I) +#endif +#ifdef W3_MPI + NLOC = HGSTGE(IMOD,J)%NRAVG(I) + DO ILOC=1, NLOC + ISPROC = HGSTGE(IMOD,J)%IMPSRC(I,ILOC) + ITAG = HGSTGE(IMOD,J)%ITAG(I,ILOC) + IT0 + IF ( ISPROC .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_IRECV ( SHGH(1,ILOC,I), & + SGRDS(J)%NSPEC, MPI_REAL, & + ISPROC-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9016) NRQ, JSEA, ISPROC, & + ITAG-MTAG1, IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + END IF + END DO + END DO +#endif ! ! ..... End IF for posting receives 1.b.1 ! -!/MPIT WRITE (MDST,9017) -!/MPI END IF +#ifdef W3_MPIT + WRITE (MDST,9017) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End grid loop J in 1.b.1 ! -!/MPI END DO -!/MPIT WRITE (MDST,9018) NRQ +#ifdef W3_MPI + END DO +#endif +#ifdef W3_MPIT + WRITE (MDST,9018) NRQ +#endif ! -!/MPI ALLOCATE ( MDATAS(IMOD)%IRQHGG(NRQ) ) -!/MPI MDATAS(IMOD)%IRQHGG = IRQ(1:NRQ) -!/MPI DEALLOCATE ( IRQ ) +#ifdef W3_MPI + ALLOCATE ( MDATAS(IMOD)%IRQHGG(NRQ) ) + MDATAS(IMOD)%IRQHGG = IRQ(1:NRQ) + DEALLOCATE ( IRQ ) +#endif ! ! ..... Reset status ! -!/MPI IF ( NRQ .GT. 0 ) THEN -!/MPI HGHSTA(IMOD) = 1 -!/MPIT WRITE (MDST,9011) HGHSTA(IMOD) -!/MPI END IF +#ifdef W3_MPI + IF ( NRQ .GT. 0 ) THEN + HGHSTA(IMOD) = 1 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) HGHSTA(IMOD) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End IF in 1.b.1 ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! 1.b.2 HGHSTA = 1 ! Wait for communication to finish. ! If DONE defined, check if done, otherwise wait. ! -!/MPI IF ( HGHSTA(IMOD) .EQ. 1 ) THEN +#ifdef W3_MPI + IF ( HGHSTA(IMOD) .EQ. 1 ) THEN +#endif ! -!/MPI NRQ => MDATAS(IMOD)%NRQHGG -!/MPI IRQ => MDATAS(IMOD)%IRQHGG -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQHGG + IRQ => MDATAS(IMOD)%IRQHGG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#endif ! ! ..... Test communication if DONE is present, wait otherwise ! -!/MPI IF ( PRESENT(DONE) ) THEN -! -!/MPI CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & -!/MPI IERR_MPI ) -! -!/MPIT ICOUNT = 0 -!/MPIT DO I=1, NRQ -!/MPIT CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & -!/MPIT IERR_MPI ) -!/MPIT FLAGOK = FLAGOK .AND. FLAG -!/MPIT IF ( FLAG ) ICOUNT = ICOUNT + 1 -!/MPIT END DO -!/MPIT WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) -! -!/MPI ELSE -! -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI FLAGOK = .TRUE. -!/MPIT WRITE (MDST,9019) 100. -! -!/MPI END IF +#ifdef W3_MPI + IF ( PRESENT(DONE) ) THEN +#endif +! +#ifdef W3_MPI + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) +#endif +! +#ifdef W3_MPIT + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) +#endif +! +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPI + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) 100. +#endif +! +#ifdef W3_MPI + END IF +#endif ! -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + DEALLOCATE ( STATUS ) +#endif ! ! ..... Go on based on FLAGOK ! -!/MPI IF ( FLAGOK ) THEN -!/MPI NRQ = 0 -!/MPI DEALLOCATE ( MDATAS(IMOD)%IRQHGG ) -!/MPI ELSE -!/MPI RETURN -!/MPI END IF +#ifdef W3_MPI + IF ( FLAGOK ) THEN + NRQ = 0 + DEALLOCATE ( MDATAS(IMOD)%IRQHGG ) + ELSE + RETURN + END IF +#endif ! -!/MPI HGHSTA(IMOD) = 0 -!/MPIT WRITE (MDST,9011) HGHSTA(IMOD) +#ifdef W3_MPI + HGHSTA(IMOD) = 0 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) HGHSTA(IMOD) +#endif ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! ..... process locally stored data ! -!/MPI DO J=1, NRGRD -!/MPI HGSTGE(IMOD,J)%VTIME = TIME -!/MPI IF ( J .EQ. IMOD ) CYCLE -!/MPI DO IS=1, HGSTGE(IMOD,J)%NRQOUT -!/MPI I0 = HGSTGE(IMOD,J)%OUTDAT(IS,1) -!/MPI I2 = HGSTGE(IMOD,J)%OUTDAT(IS,2) -!/MPI I1 = HGSTGE(IMOD,J)%OUTDAT(IS,3) -!/MPI HGSTGE(IMOD,J)%SHGH(:,I2,I1) = HGSTGE(IMOD,J)%TSTORE(:,I0) -!/MPI END DO -!/MPI END DO +#ifdef W3_MPI + DO J=1, NRGRD + HGSTGE(IMOD,J)%VTIME = TIME + IF ( J .EQ. IMOD ) CYCLE + DO IS=1, HGSTGE(IMOD,J)%NRQOUT + I0 = HGSTGE(IMOD,J)%OUTDAT(IS,1) + I2 = HGSTGE(IMOD,J)%OUTDAT(IS,2) + I1 = HGSTGE(IMOD,J)%OUTDAT(IS,3) + HGSTGE(IMOD,J)%SHGH(:,I2,I1) = HGSTGE(IMOD,J)%TSTORE(:,I0) + END DO + END DO +#endif ! ! -------------------------------------------------------------------- / ! 2. Data available, process grid by grid ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! ! 2.a Loop over grids ! @@ -1669,7 +2125,9 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) END IF IF ( NTOT .EQ. 0 ) CYCLE ! -!/T WRITE (MDST,9021) J, NTOT +#ifdef W3_T + WRITE (MDST,9021) J, NTOT +#endif ! ! 2.b Set up temp data structures ! @@ -1683,7 +2141,9 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! ! 2.c Average spectra to temp storage ! -!/T WRITE (MDST,9022) +#ifdef W3_T + WRITE (MDST,9022) +#endif ! DO IS=1, NTOT NA = HGSTGE(IMOD,J)%NRAVG(IS) @@ -1699,7 +2159,9 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! IF ( RESPEC(IMOD,J) ) THEN ! -!/T WRITE (MDST,9023) +#ifdef W3_T + WRITE (MDST,9023) +#endif ! CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & SGRDS(J)%XFR, SGRDS(J)%FR1, SGRDS(J)%TH(1), & @@ -1711,7 +2173,9 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! ! 2.e Move spectra to model ! -!/T WRITE (MDST,9024) +#ifdef W3_T + WRITE (MDST,9024) +#endif ! DO IS=1, NTOT JSEA = HGSTGE(IMOD,J)%LJSEA(IS) @@ -1730,33 +2194,43 @@ SUBROUTINE WMIOHG ( IMOD, DONE ) ! IF ( PRESENT(DONE) ) DONE = .TRUE. ! -!/PDLIB CALL PDLIB_exchange2Dreal(VA(:,1:NPA)) +#ifdef W3_PDLIB + CALL PDLIB_exchange2Dreal(VA(:,1:NPA)) +#endif ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',I3/ & -!/T ' DTOUTP, FLGALL :',F8.1,L4) -!/T 9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ & -!/T ' ',25I4) -!/T 9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED') -! -!/T 9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) -!/MPIT 9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',I2) -!/MPIT 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) -!/MPIT 9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',I4/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | FROM | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9017 FORMAT ( ' +------+------+------+------+--------------+'/) -!/MPIT 9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',I10/) -!/MPIT 9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',F6.1,'%') -! -!/T 9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID') -!/T 9021 FORMAT ( ' FROM GRID ',I3,' NR OF SPECTRA :',I6) -!/T 9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE') -!/T 9023 FORMAT ( ' CONVERT SPECTRAL GRID') -!/T 9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE') +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOHG : GATHERING DATA FOR GRID ',I3/ & + ' DTOUTP, FLGALL :',F8.1,L4) + 9001 FORMAT ( ' TEST WMIOHG : NR. OF SPECTRA PER SOURCE GRID : '/ & + ' ',25I4) + 9003 FORMAT ( ' TEST WMIOHG : NO DATA TO BE GATHERED') +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOHG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) +#endif +#ifdef W3_MPIT + 9011 FORMAT ( ' MPIT WMIOHG : HGHSTA =',I2) + 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) + 9014 FORMAT (/' MPIT WMIOHG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9017 FORMAT ( ' +------+------+------+------+--------------+'/) + 9018 FORMAT ( ' MPIT WMIOHG : NRQBPT:',I10/) + 9019 FORMAT ( ' MPIT WMIOHG : RECEIVES FINISHED :',F6.1,'%') +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMIOHG : PROCESSING DATA GRID BY GRID') + 9021 FORMAT ( ' FROM GRID ',I3,' NR OF SPECTRA :',I6) + 9022 FORMAT ( ' AVERAGE SPECTRA TO TEMP STORAGE') + 9023 FORMAT ( ' CONVERT SPECTRAL GRID') + 9024 FORMAT ( ' MOVE SPECTRA TO PERMANENT STORAGE') +#endif !/ !/ End of WMIOHG ----------------------------------------------------- / !/ @@ -1828,11 +2302,15 @@ SUBROUTINE WMIOHF ( IMOD ) ! USE WMMDATMD ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1843,44 +2321,62 @@ SUBROUTINE WMIOHF ( IMOD ) !/ Local parameters !/ INTEGER :: J -!/MPI INTEGER :: IERR_MPI -!/MPI INTEGER, POINTER :: NRQ, IRQ(:) -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) -!/S INTEGER, SAVE :: IENT = 0 -!/ -!/S CALL STRACE (IENT, 'WMIOHF') +#ifdef W3_MPI + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'WMIOHF') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 1. Loop over grids ! DO J=1, NRGRD ! -!/MPI NRQ => HGSTGE(J,IMOD)%NRQHGS +#ifdef W3_MPI + NRQ => HGSTGE(J,IMOD)%NRQHGS +#endif ! ! 1.a Nothing to finalize ! -!/MPI IF ( NRQ .EQ. 0 ) CYCLE -!/MPI IRQ => HGSTGE(J,IMOD)%IRQHGS +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => HGSTGE(J,IMOD)%IRQHGS +#endif ! ! 1.b Wait for communication to end ! -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif ! ! 1.c Reset arrays and counter ! -!/MPI NRQ = 0 -!/MPI DEALLOCATE ( HGSTGE(J,IMOD)%IRQHGS, & -!/MPI HGSTGE(J,IMOD)%TSTORE, & -!/MPI HGSTGE(J,IMOD)%OUTDAT ) +#ifdef W3_MPI + NRQ = 0 + DEALLOCATE ( HGSTGE(J,IMOD)%IRQHGS, & + HGSTGE(J,IMOD)%TSTORE, & + HGSTGE(J,IMOD)%OUTDAT ) +#endif ! -!/T WRITE (MDST,9010) J +#ifdef W3_T + WRITE (MDST,9010) J +#endif ! END DO ! @@ -1888,8 +2384,10 @@ SUBROUTINE WMIOHF ( IMOD ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',I3) -!/T 9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',I3) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOHF : FINALIZE STAGING DATA FROM GRID ',I3) + 9010 FORMAT ( ' TEST WMIOHF : FINISHED WITH TARGET ',I3) +#endif !/ !/ End of WMIOHF ----------------------------------------------------- / !/ @@ -1975,12 +2473,16 @@ SUBROUTINE WMIOES ( IMOD ) USE WMMDATMD ! USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD, ONLY: DSEC21 ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1991,19 +2493,33 @@ SUBROUTINE WMIOES ( IMOD ) !/ Local parameters !/ INTEGER :: J, NR, I, ISEA, JSEA, IS, I1, I2 -!/MPI INTEGER :: IT0, ITAG, IP, IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 -!/MPI INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) -!/SHRD REAL, POINTER :: SEQL(:,:,:) -!/MPI REAL, POINTER :: SEQL(:,:) -!/ -!/S CALL STRACE (IENT, 'WMIOES') +#ifdef W3_MPI + INTEGER :: IT0, ITAG, IP, IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + INTEGER, POINTER :: NRQ, IRQ(:), NRQOUT, OUTDAT(:,:) +#endif +#ifdef W3_SHRD + REAL, POINTER :: SEQL(:,:,:) +#endif +#ifdef W3_MPI + REAL, POINTER :: SEQL(:,:) +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'WMIOES') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD -!/T WRITE (MDST,9001) EQSTGE(:,IMOD)%NSND +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) EQSTGE(:,IMOD)%NSND +#endif ! CALL W3SETO ( IMOD, MDSE, MDST ) CALL W3SETG ( IMOD, MDSE, MDST ) @@ -2018,11 +2534,13 @@ SUBROUTINE WMIOES ( IMOD ) IF ( J .EQ. IMOD ) CYCLE NR = EQSTGE(J,IMOD)%NSND ! -!/T IF ( NR .EQ. 0 ) THEN -!/T WRITE (MDST,9010) J, NR -!/T ELSE -!/T WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)) -!/T END IF +#ifdef W3_T + IF ( NR .EQ. 0 ) THEN + WRITE (MDST,9010) J, NR + ELSE + WRITE (MDST,9011) J, NR, DSEC21(TIME,TSYNC(:,J)) + END IF +#endif ! IF ( NR .EQ. 0 ) CYCLE IF ( DSEC21(TIME,TSYNC(:,J)) .NE. 0. ) STOP @@ -2033,35 +2551,51 @@ SUBROUTINE WMIOES ( IMOD ) ! -------------------------------------------------------------------- / ! 2. Allocate arrays and/or point pointers ! -!/SHRD SEQL => EQSTGE(J,IMOD)%SEQL -!/MPI ALLOCATE ( EQSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) -!/MPI SEQL => EQSTGE(J,IMOD)%TSTORE -! -!/MPI ALLOCATE ( EQSTGE(J,IMOD)%IRQEQS(NR) , & -!/MPI EQSTGE(J,IMOD)%OUTDAT(NR,3) ) -! -!/MPI NRQ => EQSTGE(J,IMOD)%NRQEQS -!/MPI NRQOUT => EQSTGE(J,IMOD)%NRQOUT -!/MPI IRQ => EQSTGE(J,IMOD)%IRQEQS -!/MPI OUTDAT => EQSTGE(J,IMOD)%OUTDAT -!/MPI NRQ = 0 -!/MPI NRQOUT = 0 -!/MPI IRQ = 0 +#ifdef W3_SHRD + SEQL => EQSTGE(J,IMOD)%SEQL +#endif +#ifdef W3_MPI + ALLOCATE ( EQSTGE(J,IMOD)%TSTORE(NSPEC,NR) ) + SEQL => EQSTGE(J,IMOD)%TSTORE +#endif +! +#ifdef W3_MPI + ALLOCATE ( EQSTGE(J,IMOD)%IRQEQS(NR) , & + EQSTGE(J,IMOD)%OUTDAT(NR,3) ) +#endif +! +#ifdef W3_MPI + NRQ => EQSTGE(J,IMOD)%NRQEQS + NRQOUT => EQSTGE(J,IMOD)%NRQOUT + IRQ => EQSTGE(J,IMOD)%IRQEQS + OUTDAT => EQSTGE(J,IMOD)%OUTDAT + NRQ = 0 + NRQOUT = 0 + IRQ = 0 +#endif ! ! -------------------------------------------------------------------- / ! 3. Set the time ! Note that with MPI the send needs to be posted to the local ! processor too to make time management possible. ! -!/T WRITE (MDST,9030) TIME +#ifdef W3_T + WRITE (MDST,9030) TIME +#endif ! -!/SHRD EQSTGE(J,IMOD)%VTIME = TIME +#ifdef W3_SHRD + EQSTGE(J,IMOD)%VTIME = TIME +#endif ! ! -------------------------------------------------------------------- / ! 4. Stage the spectral data ! -!/MPIT WRITE (MDST,9080) -!/MPI IT0 = MTAG2 + 1 +#ifdef W3_MPIT + WRITE (MDST,9080) +#endif +#ifdef W3_MPI + IT0 = MTAG2 + 1 +#endif ! DO I=1, NR ! @@ -2069,42 +2603,66 @@ SUBROUTINE WMIOES ( IMOD ) JSEA = EQSTGE(J,IMOD)%SJS(I) I1 = EQSTGE(J,IMOD)%SI1(I) I2 = EQSTGE(J,IMOD)%SI2(I) -!/MPI IP = EQSTGE(J,IMOD)%SIP(I) -!/MPI ITAG = EQSTGE(J,IMOD)%STG(I) + IT0 -!/MPI IF ( ITAG .GT. MTAG_UB ) THEN -!/MPI WRITE (MDSE,1001) -!/MPI CALL EXTCDE (1001) -!/MPI END IF -! -!/SMC !! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020 -!/MPI!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/MPI!/SMC SEQL(:, I) = VA(:, JSEA) -!/MPI!/SMC ELSE +#ifdef W3_MPI + IP = EQSTGE(J,IMOD)%SIP(I) + ITAG = EQSTGE(J,IMOD)%STG(I) + IT0 + IF ( ITAG .GT. MTAG_UB ) THEN + WRITE (MDSE,1001) + CALL EXTCDE (1001) + END IF +#endif +! +#ifdef W3_SMC + !! Equal ranked SMC grids simply pass the wave action. JGLi16Dec2020 +#endif +#ifdef W3_MPI +#ifdef W3_SMC + IF( GTYPE .EQ. SMCTYPE ) THEN + SEQL(:, I) = VA(:, JSEA) + ELSE +#endif +#endif DO IS=1, NSPEC -!/SHRD SEQL(IS,I1,I2) = VA(IS,JSEA) * SIG2(IS) & -!/SHRD / CG(1+(IS-1)/NTH,ISEA) -!/MPI SEQL( IS,I ) = VA(IS,JSEA) * SIG2(IS) & -!/MPI / CG(1+(IS-1)/NTH,ISEA) +#ifdef W3_SHRD + SEQL(IS,I1,I2) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) +#endif +#ifdef W3_MPI + SEQL( IS,I ) = VA(IS,JSEA) * SIG2(IS) & + / CG(1+(IS-1)/NTH,ISEA) +#endif END DO -!/MPI!/SMC ENDIF -! -!/MPI IF ( IP .NE. IMPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_ISEND ( SEQL(1,I), NSPEC, MPI_REAL, IP-1, & -!/MPI ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG2, & -!/MPIT IRQ(NRQ), IERR_MPI -!/MPI ELSE -!/MPI NRQOUT = NRQOUT + 1 -!/MPI OUTDAT(NRQOUT,1) = I -!/MPI OUTDAT(NRQOUT,2) = I1 -!/MPI OUTDAT(NRQOUT,3) = I2 -!/MPI END IF +#ifdef W3_MPI +#ifdef W3_SMC + ENDIF +#endif +#endif +! +#ifdef W3_MPI + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_ISEND ( SEQL(1,I), NSPEC, MPI_REAL, IP-1, & + ITAG, MPI_COMM_MWAVE, IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9082) NRQ, JSEA, IP, ITAG-MTAG2, & + IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + ELSE + NRQOUT = NRQOUT + 1 + OUTDAT(NRQOUT,1) = I + OUTDAT(NRQOUT,2) = I1 + OUTDAT(NRQOUT,3) = I2 + END IF +#endif ! END DO ! -!/MPIT WRITE (MDST,9083) -!/MPIT WRITE (MDST,9084) NRQ +#ifdef W3_MPIT + WRITE (MDST,9083) + WRITE (MDST,9084) NRQ +#endif ! END DO ! @@ -2112,26 +2670,36 @@ SUBROUTINE WMIOES ( IMOD ) ! ! Formats ! -!/MPI 1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', & -!/MPI ' UPPER BOUND (MTAG_UB) ***') -!/T 9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',I3) -!/T 9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ & -!/T ' ',15I6) -! -!/T 9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & -!/T ' NR = ',I6) -!/T 9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & -!/T ' NR = ',I6,' TIME GAP = ',F8.1) -! -!/T 9030 FORMAT ( ' TEST WMIOES : TIME :',I10.8,I7.6) -!/ -!/MPIT 9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | TARG | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9083 FORMAT ( ' +------+------+------+------+--------------+') -!/MPIT 9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',I10/) +#ifdef W3_MPI + 1001 FORMAT (/' *** ERROR WMIOES : REQUESTED MPI TAG EXCEEDS', & + ' UPPER BOUND (MTAG_UB) ***') +#endif +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOES : STAGING DATA FROM GRID ',I3) + 9001 FORMAT ( ' TEST WMIOES : NR. OF SPECTRA PER GRID : '/ & + ' ',15I6) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & + ' NR = ',I6) + 9011 FORMAT ( ' TEST WMIOES : POSTING DATA TO GRID ',I3, & + ' NR = ',I6,' TIME GAP = ',F8.1) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMIOES : TIME :',I10.8,I7.6) +#endif +!/ +#ifdef W3_MPIT + 9080 FORMAT (/' MPIT WMIOES: COMMUNICATION CALLS '/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9082 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9083 FORMAT ( ' +------+------+------+------+--------------+') + 9084 FORMAT ( ' MPIT WMIOES: NRQEQS:',I10/) +#endif !/ !/ End of WMIOES ----------------------------------------------------- / !/ @@ -2222,13 +2790,19 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) USE W3CSPCMD, ONLY: W3CSPC USE W3TIMEMD, ONLY: DSEC21 USE W3SERVMD, ONLY: EXTCDE -!/PDLIB use yowNodepool, only: npa -!/PDLIB USE yowExchangeModule, only : PDLIB_exchange2Dreal -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_PDLIB + use yowNodepool, only: npa + USE yowExchangeModule, only : PDLIB_exchange2Dreal +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -2240,31 +2814,47 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) !/ Local parameters !/ INTEGER :: J, I, ISEA, JSEA, IA, IS -!/S INTEGER, SAVE :: IENT = 0 -!/MPI INTEGER :: IT0, ITAG, IFROM, IERR_MPI, & -!/MPI NA, IP, I1, I2 -!/MPIT INTEGER :: ICOUNT +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + INTEGER :: IT0, ITAG, IFROM, IERR_MPI, & + NA, IP, I1, I2 +#endif +#ifdef W3_MPIT + INTEGER :: ICOUNT +#endif INTEGER, POINTER :: VTIME(:) -!/MPI INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: NRQ, IRQ(:), STATUS(:,:) +#endif REAL :: DTTST, WGHT REAL, POINTER :: SPEC1(:,:), SPEC2(:,:), SPEC(:,:) -!/MPI REAL, POINTER :: SEQL(:,:,:) -!/MPI LOGICAL :: FLAGOK -!/MPI LOGICAL :: FLAG +#ifdef W3_MPI + REAL, POINTER :: SEQL(:,:,:) + LOGICAL :: FLAGOK + LOGICAL :: FLAG +#endif !/ -!/S CALL STRACE (IENT, 'WMIOEG') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOEG') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD -!/T WRITE (MDST,9001) 'NREC', EQSTGE(IMOD,:)%NREC +#ifdef W3_T + WRITE (MDST,9000) IMOD + WRITE (MDST,9001) 'NREC', EQSTGE(IMOD,:)%NREC +#endif ! IF ( PRESENT(DONE) ) DONE = .FALSE. ! IF ( EQSTGE(IMOD,IMOD)%NREC .EQ. 0 ) THEN IF ( PRESENT(DONE) ) DONE = .TRUE. -!/T WRITE (MDST,9002) +#ifdef W3_T + WRITE (MDST,9002) +#endif RETURN END IF ! @@ -2276,184 +2866,272 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) ! -------------------------------------------------------------------- / ! 1. Testing / gathering data in staging arrays ! -!/T WRITE (MDST,9010) TIME +#ifdef W3_T + WRITE (MDST,9010) TIME +#endif ! ! 1.a Shared memory version, test valid times. - - - - - - - - - - - - / ! -!/SHRD DO J=1, NRGRD +#ifdef W3_SHRD + DO J=1, NRGRD +#endif ! -!/SHRD IF ( IMOD .EQ. J ) CYCLE -!/SHRD IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE +#ifdef W3_SHRD + IF ( IMOD .EQ. J ) CYCLE + IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE +#endif ! -!/SHRD VTIME => EQSTGE(IMOD,J)%VTIME -!/SHRD IF ( VTIME(1) .EQ. -1 ) RETURN -!/SHRD DTTST = DSEC21 ( TIME, VTIME ) -!/SHRD IF ( DTTST .NE. 0. ) RETURN +#ifdef W3_SHRD + VTIME => EQSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) RETURN + DTTST = DSEC21 ( TIME, VTIME ) + IF ( DTTST .NE. 0. ) RETURN +#endif ! -!/SHRD END DO +#ifdef W3_SHRD + END DO +#endif ! ! 1.b Distributed memory version - - - - - - - - - - - - - - - - - - - / ! -!/MPIT WRITE (MDST,9011) EQLSTA(IMOD) +#ifdef W3_MPIT + WRITE (MDST,9011) EQLSTA(IMOD) +#endif ! ! 1.b.1 EQLSTA = 0 ! Check if staging arrays are initialized. ! Post the proper receives. ! -!/MPI IF ( EQLSTA(IMOD) .EQ. 0 ) THEN -! -!/MPI NRQ => MDATAS(IMOD)%NRQEQG -!/MPI NRQ = 0 -!/MPI DO J=1, NRGRD -!/MPI IF ( J .EQ. IMOD ) CYCLE -!/MPI NRQ = NRQ + EQSTGE(IMOD,J)%NREC * & -!/MPI EQSTGE(IMOD,J)%NAVMAX -!/MPI END DO -!/MPI ALLOCATE ( IRQ(NRQ) ) -!/MPI IRQ = 0 -!/MPI NRQ = 0 +#ifdef W3_MPI + IF ( EQLSTA(IMOD) .EQ. 0 ) THEN +#endif +! +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQEQG + NRQ = 0 + DO J=1, NRGRD + IF ( J .EQ. IMOD ) CYCLE + NRQ = NRQ + EQSTGE(IMOD,J)%NREC * & + EQSTGE(IMOD,J)%NAVMAX + END DO + ALLOCATE ( IRQ(NRQ) ) + IRQ = 0 + NRQ = 0 +#endif ! -!/MPI DO J=1, NRGRD -!/MPI IF ( IMOD .EQ. J ) CYCLE -!/MPI IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE +#ifdef W3_MPI + DO J=1, NRGRD + IF ( IMOD .EQ. J ) CYCLE + IF ( EQSTGE(IMOD,J)%NREC .EQ. 0 ) CYCLE +#endif ! ! ..... Check valid time to determine staging. ! -!/MPI VTIME => EQSTGE(IMOD,J)%VTIME -!/MPI IF ( VTIME(1) .EQ. -1 ) THEN -!/MPI DTTST = 1. -!/MPI ELSE -!/MPI DTTST = DSEC21 ( TIME, VTIME ) -!/MPI END IF -!/MPIT WRITE (MDST,9013) VTIME, DTTST +#ifdef W3_MPI + VTIME => EQSTGE(IMOD,J)%VTIME + IF ( VTIME(1) .EQ. -1 ) THEN + DTTST = 1. + ELSE + DTTST = DSEC21 ( TIME, VTIME ) + END IF +#endif +#ifdef W3_MPIT + WRITE (MDST,9013) VTIME, DTTST +#endif ! ! ..... Post receives for data gather ! -!/MPI IF ( DTTST .NE. 0. ) THEN -!/MPIT WRITE (MDST,9014) J +#ifdef W3_MPI + IF ( DTTST .NE. 0. ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9014) J +#endif ! ! ..... Spectra ! -!/MPI IT0 = MTAG2 + 1 -!/MPI SEQL => EQSTGE(IMOD,J)%SEQL -! -!/MPI DO I=1, EQSTGE(IMOD,J)%NREC -!/MPI JSEA = EQSTGE(IMOD,J)%JSEA(I) -!/MPI NA = EQSTGE(IMOD,J)%NAVG(I) -!/MPI DO IA=1, NA -!/MPI IP = EQSTGE(IMOD,J)%RIP(I,IA) -!/MPI ITAG = EQSTGE(IMOD,J)%RTG(I,IA) + IT0 -!/MPI IF ( IP .NE. IMPROC ) THEN -!/MPI NRQ = NRQ + 1 -!/MPI CALL MPI_IRECV ( SEQL(1,I,IA), & -!/MPI SGRDS(J)%NSPEC, MPI_REAL, & -!/MPI IP-1, ITAG, MPI_COMM_MWAVE, & -!/MPI IRQ(NRQ), IERR_MPI ) -!/MPIT WRITE (MDST,9016) NRQ, JSEA, IP, & -!/MPIT ITAG-MTAG2, IRQ(NRQ), IERR_MPI -!/MPI END IF -!/MPI END DO -!/MPI END DO +#ifdef W3_MPI + IT0 = MTAG2 + 1 + SEQL => EQSTGE(IMOD,J)%SEQL +#endif +! +#ifdef W3_MPI + DO I=1, EQSTGE(IMOD,J)%NREC + JSEA = EQSTGE(IMOD,J)%JSEA(I) + NA = EQSTGE(IMOD,J)%NAVG(I) + DO IA=1, NA + IP = EQSTGE(IMOD,J)%RIP(I,IA) + ITAG = EQSTGE(IMOD,J)%RTG(I,IA) + IT0 + IF ( IP .NE. IMPROC ) THEN + NRQ = NRQ + 1 + CALL MPI_IRECV ( SEQL(1,I,IA), & + SGRDS(J)%NSPEC, MPI_REAL, & + IP-1, ITAG, MPI_COMM_MWAVE, & + IRQ(NRQ), IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9016) NRQ, JSEA, IP, & + ITAG-MTAG2, IRQ(NRQ), IERR_MPI +#endif +#ifdef W3_MPI + END IF + END DO + END DO +#endif ! ! ..... End IF for posting receives 1.b.1 ! -!/MPIT WRITE (MDST,9017) -!/MPI END IF +#ifdef W3_MPIT + WRITE (MDST,9017) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End grid loop J in 1.b.1 ! -!/MPI END DO -!/MPIT WRITE (MDST,9018) NRQ -! -!/MPI IF ( NRQ .NE. 0 ) THEN -!/MPI ALLOCATE ( MDATAS(IMOD)%IRQEQG(NRQ) ) -!/MPI MDATAS(IMOD)%IRQEQG = IRQ(1:NRQ) -!/MPI END IF +#ifdef W3_MPI + END DO +#endif +#ifdef W3_MPIT + WRITE (MDST,9018) NRQ +#endif +! +#ifdef W3_MPI + IF ( NRQ .NE. 0 ) THEN + ALLOCATE ( MDATAS(IMOD)%IRQEQG(NRQ) ) + MDATAS(IMOD)%IRQEQG = IRQ(1:NRQ) + END IF +#endif ! -!/MPI DEALLOCATE ( IRQ ) +#ifdef W3_MPI + DEALLOCATE ( IRQ ) +#endif ! ! ..... Reset status ! -!/MPI IF ( NRQ .GT. 0 ) THEN -!/MPI EQLSTA(IMOD) = 1 -!/MPIT WRITE (MDST,9011) EQLSTA(IMOD) -!/MPI END IF +#ifdef W3_MPI + IF ( NRQ .GT. 0 ) THEN + EQLSTA(IMOD) = 1 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) EQLSTA(IMOD) +#endif +#ifdef W3_MPI + END IF +#endif ! ! ..... End IF in 1.b.1 ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! 1.b.2 EQLSTA = 1 ! Wait for communication to finish. ! If DONE defined, check if done, otherwise wait. ! -!/MPI IF ( EQLSTA(IMOD) .EQ. 1 ) THEN +#ifdef W3_MPI + IF ( EQLSTA(IMOD) .EQ. 1 ) THEN +#endif ! -!/MPI NRQ => MDATAS(IMOD)%NRQEQG -!/MPI IRQ => MDATAS(IMOD)%IRQEQG -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#ifdef W3_MPI + NRQ => MDATAS(IMOD)%NRQEQG + IRQ => MDATAS(IMOD)%IRQEQG + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) +#endif ! ! ..... Test communication if DONE is present, wait otherwise ! -!/MPI IF ( PRESENT(DONE) ) THEN -! -!/MPI CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & -!/MPI IERR_MPI ) -! -!/MPIT ICOUNT = 0 -!/MPIT DO I=1, NRQ -!/MPIT CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & -!/MPIT IERR_MPI ) -!/MPIT FLAGOK = FLAGOK .AND. FLAG -!/MPIT IF ( FLAG ) ICOUNT = ICOUNT + 1 -!/MPIT END DO -!/MPIT WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) -! -!/MPI ELSE -! -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI FLAGOK = .TRUE. -!/MPIT WRITE (MDST,9019) 100. -! -!/MPI END IF +#ifdef W3_MPI + IF ( PRESENT(DONE) ) THEN +#endif +! +#ifdef W3_MPI + CALL MPI_TESTALL ( NRQ, IRQ, FLAGOK, STATUS, & + IERR_MPI ) +#endif +! +#ifdef W3_MPIT + ICOUNT = 0 + DO I=1, NRQ + CALL MPI_TEST ( IRQ(I), FLAG, STATUS(1,1), & + IERR_MPI ) + FLAGOK = FLAGOK .AND. FLAG + IF ( FLAG ) ICOUNT = ICOUNT + 1 + END DO + WRITE (MDST,9019) 100. * REAL(ICOUNT) / REAL(NRQ) +#endif +! +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPI + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + FLAGOK = .TRUE. +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) 100. +#endif +! +#ifdef W3_MPI + END IF +#endif ! -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + DEALLOCATE ( STATUS ) +#endif ! ! ..... Go on based on FLAGOK ! -!/MPI IF ( FLAGOK ) THEN -!/MPI IF ( NRQ.NE.0 ) DEALLOCATE ( MDATAS(IMOD)%IRQEQG ) -!/MPI NRQ = 0 -!/MPI ELSE -!/MPI RETURN -!/MPI END IF +#ifdef W3_MPI + IF ( FLAGOK ) THEN + IF ( NRQ.NE.0 ) DEALLOCATE ( MDATAS(IMOD)%IRQEQG ) + NRQ = 0 + ELSE + RETURN + END IF +#endif ! -!/MPI EQLSTA(IMOD) = 0 -!/MPIT WRITE (MDST,9011) EQLSTA(IMOD) +#ifdef W3_MPI + EQLSTA(IMOD) = 0 +#endif +#ifdef W3_MPIT + WRITE (MDST,9011) EQLSTA(IMOD) +#endif ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! ..... process locally stored data ! -!/MPI DO J=1, NRGRD -!/MPI EQSTGE(IMOD,J)%VTIME = TIME -!/MPI IF ( J .EQ. IMOD ) CYCLE -!/MPI DO IS=1, EQSTGE(IMOD,J)%NRQOUT -!/MPI I = EQSTGE(IMOD,J)%OUTDAT(IS,1) -!/MPI I1 = EQSTGE(IMOD,J)%OUTDAT(IS,2) -!/MPI I2 = EQSTGE(IMOD,J)%OUTDAT(IS,3) -!/MPI EQSTGE(IMOD,J)%SEQL(:,I1,I2) = EQSTGE(IMOD,J)%TSTORE(:,I) -!/MPI END DO -!/MPI END DO +#ifdef W3_MPI + DO J=1, NRGRD + EQSTGE(IMOD,J)%VTIME = TIME + IF ( J .EQ. IMOD ) CYCLE + DO IS=1, EQSTGE(IMOD,J)%NRQOUT + I = EQSTGE(IMOD,J)%OUTDAT(IS,1) + I1 = EQSTGE(IMOD,J)%OUTDAT(IS,2) + I2 = EQSTGE(IMOD,J)%OUTDAT(IS,3) + EQSTGE(IMOD,J)%SEQL(:,I1,I2) = EQSTGE(IMOD,J)%TSTORE(:,I) + END DO + END DO +#endif ! ! -------------------------------------------------------------------- / ! 2. Data available, process grid by grid ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! ! 2.a Do 'native' grid IMOD ! -!/T WRITE (MDST,9021) IMOD, EQSTGE(IMOD,IMOD)%NREC +#ifdef W3_T + WRITE (MDST,9021) IMOD, EQSTGE(IMOD,IMOD)%NREC +#endif ! DO I=1, EQSTGE(IMOD,IMOD)%NREC JSEA = EQSTGE(IMOD,IMOD)%JSEA(I) @@ -2466,20 +3144,26 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) DO J=1, NRGRD IF ( IMOD.EQ.J .OR. EQSTGE(IMOD,J)%NREC.EQ.0 ) CYCLE ! -!/T WRITE (MDST,9022) J, EQSTGE(IMOD,J)%NREC +#ifdef W3_T + WRITE (MDST,9022) J, EQSTGE(IMOD,J)%NREC +#endif ! -!/SMC !! Use 1-1 full boundary spectra without modification. JGLi16Dec2020 -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC DO I=1, EQSTGE(IMOD,J)%NREC -!/SMC JSEA = EQSTGE(IMOD,J)%JSEA(I) -!/SMC VA(:,JSEA) = EQSTGE(IMOD,J)%SEQL(:,I,1) -!/SMC END DO -!/SMC ELSE -!/SMC !! Other grid boundary spectra may need conversion. JGLi12Apr2021 +#ifdef W3_SMC + !! Use 1-1 full boundary spectra without modification. JGLi16Dec2020 + IF( GTYPE .EQ. SMCTYPE ) THEN + DO I=1, EQSTGE(IMOD,J)%NREC + JSEA = EQSTGE(IMOD,J)%JSEA(I) + VA(:,JSEA) = EQSTGE(IMOD,J)%SEQL(:,I,1) + END DO + ELSE + !! Other grid boundary spectra may need conversion. JGLi12Apr2021 +#endif ! ! 2.c Average spectra ! -!/T WRITE (MDST,9023) +#ifdef W3_T + WRITE (MDST,9023) +#endif ALLOCATE ( SPEC1(SGRDS(J)%NSPEC,EQSTGE(IMOD,J)%NREC) ) SPEC1 = 0. ! @@ -2493,7 +3177,9 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) ! 2.d Convert spectra ! IF ( RESPEC(IMOD,J) ) THEN -!/T WRITE (MDST,9024) +#ifdef W3_T + WRITE (MDST,9024) +#endif ALLOCATE ( SPEC2(NSPEC,EQSTGE(IMOD,J)%NREC) ) ! CALL W3CSPC ( SPEC1, SGRDS(J)%NK, SGRDS(J)%NTH, & @@ -2512,15 +3198,19 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) ISEA = EQSTGE(IMOD,J)%ISEA(I) JSEA = EQSTGE(IMOD,J)%JSEA(I) WGHT = EQSTGE(IMOD,J)%WGHT(I) -!/SMC !! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021 -!/SMC IF( NGRPSMC .GT. 0 ) THEN -!/SMC VA(:,JSEA) = SPEC(:,I) -!/SMC ELSE +#ifdef W3_SMC + !! Regular grid in same ranked SMC group uses 1-1 mapping. JGLi12Apr2021 + IF( NGRPSMC .GT. 0 ) THEN + VA(:,JSEA) = SPEC(:,I) + ELSE +#endif DO IS=1, NSPEC VA(IS,JSEA) = VA(IS,JSEA) + WGHT * & SPEC(IS,I) / SIG2(IS) * CG(1+(IS-1)/NTH,ISEA) END DO -!/SMC ENDIF !! NGRPSMC .GT. 0 +#ifdef W3_SMC + ENDIF !! NGRPSMC .GT. 0 +#endif END DO ! ! 2.f Final clean up @@ -2528,8 +3218,10 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) DEALLOCATE ( SPEC1 ) IF ( RESPEC(IMOD,J) ) DEALLOCATE ( SPEC2 ) -!/SMC !! End GTYPE .EQ. SMCTYPE -!/SMC ENDIF +#ifdef W3_SMC + !! End GTYPE .EQ. SMCTYPE + ENDIF +#endif !! End 2.b J grid loop. END DO @@ -2539,32 +3231,42 @@ SUBROUTINE WMIOEG ( IMOD, DONE ) ! IF ( PRESENT(DONE) ) DONE = .TRUE. ! -!/PDLIB CALL PDLIB_exchange2Dreal(VA(:,1:NPA)) +#ifdef W3_PDLIB + CALL PDLIB_exchange2Dreal(VA(:,1:NPA)) +#endif ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',I4) -!/T 9001 FORMAT ( ' TEST WMIOEG : ',A,' PER SOURCE GRID : '/13X,20I5) -!/T 9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED') -! -!/T 9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) -!/MPIT 9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',I2) -!/MPIT 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) -!/MPIT 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) -!/MPIT 9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',I4/ & -!/MPIT ' +------+------+------+------+--------------+'/ & -!/MPIT ' | IH | ID | FROM | TAG | handle err |'/ & -!/MPIT ' +------+------+------+------+--------------+') -!/MPIT 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') -!/MPIT 9017 FORMAT ( ' +------+------+------+------+--------------+'/) -!/MPIT 9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',I10/) -!/MPIT 9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',F6.1,'%') -! -!/T 9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID') -!/T 9021 FORMAT ( ' NATIVE GRID ',I3,' DATA :',I6) -!/T 9022 FORMAT ( ' RECEIVING GRID ',I3,' DATA :',I6) -!/T 9023 FORMAT ( ' AVERAGE SPECTRA') -!/T 9024 FORMAT ( ' CONVERTING SPECTRA') +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOEG : GATHERING DATA FOR GRID ',I4) + 9001 FORMAT ( ' TEST WMIOEG : ',A,' PER SOURCE GRID : '/13X,20I5) + 9002 FORMAT ( ' TEST WMIOEG : NO DATA TO BE GATHERED') +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOEG : TEST DATA AVAILABILITY FOR',I9.8,I7.6) +#endif +#ifdef W3_MPIT + 9011 FORMAT ( ' MPIT WMIOEG : EQLSTA =',I2) + 9012 FORMAT ( ' STAGING ARRAY FROM',I4,1X,A) + 9013 FORMAT ( ' VTIME, DTTST :',I9.8,I7.6,1X,F8.1) + 9014 FORMAT (/' MPIT WMIOEG : RECEIVE FROM GRID',I4/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | FROM | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') + 9016 FORMAT ( ' |',I5,' |',I5,' |',2(I5,' |'),I9,I4,' |') + 9017 FORMAT ( ' +------+------+------+------+--------------+'/) + 9018 FORMAT ( ' MPIT WMIOEG : NRQBPT:',I10/) + 9019 FORMAT ( ' MPIT WMIOEG : RECEIVES FINISHED :',F6.1,'%') +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMIOEG : PROCESSING DATA GRID BY GRID') + 9021 FORMAT ( ' NATIVE GRID ',I3,' DATA :',I6) + 9022 FORMAT ( ' RECEIVING GRID ',I3,' DATA :',I6) + 9023 FORMAT ( ' AVERAGE SPECTRA') + 9024 FORMAT ( ' CONVERTING SPECTRA') +#endif !/ !/ End of WMIOEG ----------------------------------------------------- / !/ @@ -2636,11 +3338,15 @@ SUBROUTINE WMIOEF ( IMOD ) ! USE WMMDATMD ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -2651,44 +3357,62 @@ SUBROUTINE WMIOEF ( IMOD ) !/ Local parameters !/ INTEGER :: J -!/MPI INTEGER :: IERR_MPI -!/MPI INTEGER, POINTER :: NRQ, IRQ(:) -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) -!/S INTEGER, SAVE :: IENT = 0 -!/ -!/S CALL STRACE (IENT, 'WMIOEF') +#ifdef W3_MPI + INTEGER :: IERR_MPI + INTEGER, POINTER :: NRQ, IRQ(:) + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +!/ +#ifdef W3_S + CALL STRACE (IENT, 'WMIOEF') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) IMOD +#ifdef W3_T + WRITE (MDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 1. Loop over grids ! DO J=1, NRGRD ! -!/MPI NRQ => EQSTGE(J,IMOD)%NRQEQS +#ifdef W3_MPI + NRQ => EQSTGE(J,IMOD)%NRQEQS +#endif ! ! 1.a Nothing to finalize ! -!/MPI IF ( NRQ .EQ. 0 ) CYCLE -!/MPI IRQ => EQSTGE(J,IMOD)%IRQEQS +#ifdef W3_MPI + IF ( NRQ .EQ. 0 ) CYCLE + IRQ => EQSTGE(J,IMOD)%IRQEQS +#endif ! ! 1.b Wait for communication to end ! -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) -!/MPI CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) -!/MPI DEALLOCATE ( STATUS ) +#ifdef W3_MPI + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQ) ) + CALL MPI_WAITALL ( NRQ, IRQ, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) +#endif ! ! 1.c Reset arrays and counter ! -!/MPI DEALLOCATE ( EQSTGE(J,IMOD)%IRQEQS, & -!/MPI EQSTGE(J,IMOD)%TSTORE, & -!/MPI EQSTGE(J,IMOD)%OUTDAT ) -!/MPI NRQ = 0 +#ifdef W3_MPI + DEALLOCATE ( EQSTGE(J,IMOD)%IRQEQS, & + EQSTGE(J,IMOD)%TSTORE, & + EQSTGE(J,IMOD)%OUTDAT ) + NRQ = 0 +#endif ! -!/T WRITE (MDST,9010) J +#ifdef W3_T + WRITE (MDST,9010) J +#endif ! END DO ! @@ -2696,8 +3420,10 @@ SUBROUTINE WMIOEF ( IMOD ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',I3) -!/T 9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',I3) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOEF : FINALIZE STAGING DATA FROM GRID ',I3) + 9010 FORMAT ( ' TEST WMIOEF : FINISHED WITH TARGET ',I3) +#endif !/ !/ End of WMIOEF ----------------------------------------------------- / !/ diff --git a/model/ftn/wminitmd.ftn b/model/src/wminitmd.F90 similarity index 84% rename from model/ftn/wminitmd.ftn rename to model/src/wminitmd.F90 index 44c83baf3..5f8e41cfd 100644 --- a/model/ftn/wminitmd.ftn +++ b/model/src/wminitmd.F90 @@ -343,20 +343,28 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & USE WMIOPOMD, ONLY: WMIOPP !/ USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME, NEXTLN -!/S USE W3SERVMD, ONLY: STRACE -!/MPRF USE W3TIMEMD, ONLY: PRINIT, PRTIME +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPRF + USE W3TIMEMD, ONLY: PRINIT, PRTIME +#endif USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ !/ USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS -!/SMC USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC -!/SMC USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE -!/MPI USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & -!/MPI XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & -!/MPI HQFAC, HPFAC, MAPSTA, MAPST2, & -!/MPI GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & -!/MPI TH, DTMAX, DTCFL -!/MPI USE W3GSRUMD +#ifdef W3_SMC + USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC + USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE +#endif +#ifdef W3_MPI + USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & + XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & + HQFAC, HPFAC, MAPSTA, MAPST2, & + GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & + TH, DTMAX, DTCFL + USE W3GSRUMD +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: WADATS USE W3IDATMD, ONLY: INFLAGS1, INFLAGS2, INPUTS, IINIT, & @@ -376,16 +384,22 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & INPMAP, IDINP, NGRPSMC USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & -!/MPI MPI_COMM_BCT, CROOT, FBCAST -!/MPRF USE WMMDATMD, ONLY: MDSP +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST +#endif +#ifdef W3_MPRF + USE WMMDATMD, ONLY: MDSP +#endif USE W3INITMD, ONLY: WWVER USE W3ODATMD, ONLY: OFILES ! !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -407,16 +421,22 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & NAPRES, NAPADD, NAPBCT, IFI, IFJ, IW,& IFT INTEGER :: STMPT(2), ETMPT(2) -!/MPI INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & TMPRNK(:), TMPGRP(:), NINGRP(:), & TMOVE(:,:), LOADMP(:,:), IPRT(:,:), & NDPOUT(:), OUTFF(:,:) REAL :: DTTST, XX, YY -!/MPRF REAL :: PRFT0, PRFTN -!/MPRF REAL(KIND=8) :: get_memory +#ifdef W3_MPRF + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory +#endif REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & RP1(:), RPN(:) LOGICAL :: FLT, TFLAGI, TFLAGS(-7:14), PSHARE @@ -429,7 +449,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CHARACTER(LEN=5) :: STOUT, OUTSTR(6) CHARACTER(LEN=6) :: ACTION(11), YESXX, XXXNO CHARACTER(LEN=8) :: LFILE, STTIME -!/SHRD CHARACTER(LEN=9) :: TFILE +#ifdef W3_SHRD + CHARACTER(LEN=9) :: TFILE +#endif CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) CHARACTER(LEN=40) :: PN CHARACTER(LEN=13), & @@ -437,8 +459,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CHARACTER(LEN=40), & ALLOCATABLE :: PNAMES(:) CHARACTER(LEN=12) :: FORMAT -!/DIST CHARACTER(LEN=18) :: TFILE -!/MPRF CHARACTER(LEN=18) :: PFILE +#ifdef W3_DIST + CHARACTER(LEN=18) :: TFILE +#endif +#ifdef W3_MPRF + CHARACTER(LEN=18) :: PFILE +#endif CHARACTER(LEN=13) :: IDFLDS(-7:9) CHARACTER(LEN=23) :: DTME21 @@ -485,16 +511,20 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & DATA YESXX / 'YES/--' / DATA XXXNO / '---/NO' / ! -!/MPRF CALL PRINIT -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRINIT + CALL PRTIME ( PRFT0 ) +#endif ! CALL DATE_AND_TIME ( VALUES=CLKDT1 ) ! MPI_COMM_LOC = MPI_COMM -!/MPI MPI_COMM_MWAVE = MPI_COMM -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB !/ @@ -510,19 +540,21 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') ! -!/NL2 CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#ifdef W3_NL2 + CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#endif ! ! ... Unit numbers from parameter list ! Dynamic scripture updated per file @@ -543,7 +575,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! CALL ITRACE ( MDST, NTRMAX ) ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif ! ! 1.c Input file ! @@ -564,9 +598,15 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) IW = MAX ( 3 , MIN ( 9 , IW ) ) WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' -!/SHRD TFILE = 'test.mww3' -!/DIST WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' -!/MPRF WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#ifdef W3_SHRD + TFILE = 'test.mww3' +#endif +#ifdef W3_DIST + WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' +#endif +#ifdef W3_MPRF + WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#endif ! IF ( IMPROC .EQ. NMPLOG ) THEN OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) @@ -586,15 +626,19 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') END IF ! -!/MPRF IFT = LEN_TRIM(PFILE) -!/MPRF CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) -!/MPRF CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & -!/MPRF TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') -!/MPRF OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#ifdef W3_MPRF + IFT = LEN_TRIM(PFILE) + CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & + TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') + OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#endif ! ! 1.e Initial and test output ! -!/S CALL STRACE (IENT, 'WMINIT') +#ifdef W3_S + CALL STRACE (IENT, 'WMINIT') +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,912) COMSTR ! @@ -604,7 +648,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSO,901) WWVER, STDATE, STTIME END IF ! -!/T WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#ifdef W3_T + WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#endif ! ! 2. Set-up of data structures and I/O ----------------------------- / ! 2.a Get number of grids @@ -697,10 +743,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & NTRACE( 2,I) = NTRMAX END DO ! -!/T WRITE (MDST,9020) 'INITIAL' -!/T DO I=1, NRGRD -!/T WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) -!/T END DO +#ifdef W3_T + WRITE (MDST,9020) 'INITIAL' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif ! ! 3. Get individual grid information -------------------------------- / ! @@ -722,7 +770,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 3.a Read data ! -!/T WRITE (MDST,9030) +#ifdef W3_T + WRITE (MDST,9030) +#endif ! ! 3.a.1 Input grids ! @@ -778,8 +828,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & I = I + 1 CALL W3SETI ( I, MDSE, MDST ) INFLAGS1 = .FALSE. -!/MGW INFLAGS1(10) = .TRUE. -!/MGP INFLAGS1(10) = .TRUE. +#ifdef W3_MGW + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGP + INFLAGS1(10) = .TRUE. +#endif INAMES(I,:)= INAMES(J,:) MNAMES(I) = MNAMES(J) TMPRNK(I) = TMPRNK(J) @@ -787,8 +841,10 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & RP1(I) = RP1(J) RPN(I) = RPN(J) BCDUMP(I) = BCDTMP(J) -!/T WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & -!/T TMPGRP(I), RP1(I), RPN(I) +#ifdef W3_T + WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & + TMPGRP(I), RP1(I), RPN(I) +#endif END IF END DO IF ( I .EQ. NRGRD ) EXIT @@ -873,15 +929,19 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,9022) -!/T DO I=-NRINP, NRGRD -!/T IF ( I .EQ. 0 ) CYCLE -!/T WRITE (MDST,9021) I, MDSF(I,JFIRST:9) -!/T END DO +#ifdef W3_T + WRITE (MDST,9022) + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + WRITE (MDST,9021) I, MDSF(I,JFIRST:9) + END DO +#endif ! ! 3.c Set rank and group data ! -!/T WRITE (MDST,9032) +#ifdef W3_T + WRITE (MDST,9032) +#endif ! RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 RNKTMP = 0 @@ -898,9 +958,11 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T DO I=1, NRGRD -!/T WRITE (MDST,9033) I, MNAMES(I), GRANK(I) -!/T END DO +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + END DO +#endif ! RNKMAX = RNKTMP GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 @@ -926,11 +988,13 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,9034) NRGRP -!/T DO I=1, NRGRD -!/T WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) -!/T END DO -!/T WRITE (MDST,9035) NINGRP(1:NRGRP) +#ifdef W3_T + WRITE (MDST,9034) NRGRP + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) + END DO + WRITE (MDST,9035) NINGRP(1:NRGRP) +#endif ! ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) DEALLOCATE ( TMPRNK, TMPGRP, NINGRP, BCDTMP ) @@ -941,17 +1005,21 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I END DO ! -!/T WRITE (MDST,9036) -!/T DO J=1, NRGRP -!/T WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9036) + DO J=1, NRGRP + WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) + END DO +#endif ! ! ! 3.d Unified point output ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' + PRFT0 = PRFTN +#endif ! IF ( UNIPTS ) THEN ! @@ -1230,7 +1298,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') ELSE MDSI2 = SCRATCH -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif OPEN & (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') REWIND (SCRATCH) @@ -1276,11 +1346,15 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & NPTS.EQ.0 ) WRITE (MDSS,959) IF ( IMPROC .EQ. 1 ) THEN -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif CLOSE (SCRATCH,STATUS='DELETE') ELSE CLOSE (SCRATCH) -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif END IF ! ELSE IF ( J .EQ. 3 ) THEN @@ -1541,7 +1615,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') ELSE MDSI2 = SCRATCH -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif OPEN & (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_multi.scratch') REWIND (SCRATCH) @@ -1586,11 +1662,15 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC .AND. & OT2(I)%NPTS.EQ.0 ) WRITE (MDSS,959) IF ( IMPROC .EQ. 1 ) THEN -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif CLOSE (SCRATCH,STATUS='DELETE') ELSE CLOSE (SCRATCH) -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif END IF ! ELSE IF ( J .EQ. 3 ) THEN @@ -1645,12 +1725,14 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! END DO ! -!/T DO I=1, NRGRD -!/T WRITE (MDST,9050) I -!/T WRITE (MDST,9051) ODAT(:,I) -!/T WRITE (MDST,9051) OUTFF(:,I) -!/T WRITE (MDST,9052) FLGRD(:,:,I) -!/T END DO +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9050) I + WRITE (MDST,9051) ODAT(:,I) + WRITE (MDST,9051) OUTFF(:,I) + WRITE (MDST,9052) FLGRD(:,:,I) + END DO +#endif ! ! 6. Read moving grid data ------------------------------------------ / ! @@ -1665,7 +1747,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSS,966) 'Continuous grid movement data' END IF ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif DO ILOOP=1, 2 IF ( ILOOP .EQ. 1 ) THEN MDSI2 = MDSI @@ -1673,7 +1757,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') ELSE MDSI2 = SCRATCH -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif OPEN (SCRATCH,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') REWIND (SCRATCH) ALLOCATE ( TMOVE(2,NMOVE), AMOVE(NMOVE), DMOVE(NMOVE) ) @@ -1713,17 +1799,23 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO ! IF ( IMPROC .EQ. 1 ) THEN -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif CLOSE (SCRATCH,STATUS='DELETE') ELSE CLOSE (SCRATCH) -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif END IF ! -!/T WRITE (MDST,9060) -!/T DO I=1, NMOVE -!/T WRITE (MDST,9061) I, TMOVE(:,I), AMOVE(I), DMOVE(I) -!/T END DO +#ifdef W3_T + WRITE (MDST,9060) + DO I=1, NMOVE + WRITE (MDST,9061) I, TMOVE(:,I), AMOVE(I), DMOVE(I) + END DO +#endif ! IF ( NMOVE .EQ. 0 ) GOTO 2060 ! @@ -1857,11 +1949,15 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 7.c Set communicators and ALLPRC array ! -!/T WRITE (MDST,9070) +#ifdef W3_T + WRITE (MDST,9070) +#endif IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) ! -!/MPI CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#endif ALLOCATE ( TMPRNK(NMPROC) ) NAPRES = NCPROC ! @@ -1874,10 +1970,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CALL WMSETM ( I, MDSE, MDST ) NAPLOC = 1 + IPN - IP1 NAPADD = NAPLOC -!/MPI CROOT = IP1 -!/MPI FBCAST = NAPLOC .NE. NCPROC -!/MPI FBCAST = NAPLOC .NE. NCPROC .OR. & -!/MPI ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) +#ifdef W3_MPI + CROOT = IP1 + FBCAST = NAPLOC .NE. NCPROC + FBCAST = NAPLOC .NE. NCPROC .OR. & + ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) +#endif DO J=IP1, IPN TMPRNK(1+J-IP1) = J - 1 END DO @@ -1896,11 +1994,13 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & TMPRNK(NAPADD) = NMPROC - 1 END IF ! -!/MPI CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & -!/MPI IERR_MPI ) -!/MPI CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & -!/MPI MPI_COMM_GRD, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_GRD, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#endif ! DO II=IP1, IPN ALLPRC(II,I) = 1 + II - IP1 @@ -1925,7 +2025,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ALLPRC(NMPROC,I) = II END IF ! -!/T WRITE (MDST,9071) I, ALLPRC(:,I) +#ifdef W3_T + WRITE (MDST,9071) I, ALLPRC(:,I) +#endif ! ! ... output ! @@ -2008,21 +2110,23 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( NMPLOG .EQ. IMPROC ) & WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR ! -!/MPI IF ( FBCAST ) THEN -!/MPI TMPRNK(1) = IP1 - 1 -!/MPI NAPBCT = 1 -!/MPI DO J=1, NMPROC -!/MPI IF ( ALLPRC(J,I) .EQ. 0 ) THEN -!/MPI NAPBCT = NAPBCT + 1 -!/MPI TMPRNK(NAPBCT) = J - 1 -!/MPI END IF -!/MPI END DO -!/MPI CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & -!/MPI LGROUP, IERR_MPI ) -!/MPI CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) -!/MPI END IF +#ifdef W3_MPI + IF ( FBCAST ) THEN + TMPRNK(1) = IP1 - 1 + NAPBCT = 1 + DO J=1, NMPROC + IF ( ALLPRC(J,I) .EQ. 0 ) THEN + NAPBCT = NAPBCT + 1 + TMPRNK(NAPBCT) = J - 1 + END IF + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & + LGROUP, IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + END IF +#endif ! END DO ! @@ -2058,14 +2162,16 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,8042) -!/T DO J=1, NRGRP -!/T WRITE (MDST,8044) J, MODMAP(:,J) -!/T END DO -!/T WRITE (MDST,8043) -!/T DO J=1, NRGRP -!/T WRITE (MDST,8044) J, LOADMP(:,J) -!/T END DO +#ifdef W3_T + WRITE (MDST,8042) + DO J=1, NRGRP + WRITE (MDST,8044) J, MODMAP(:,J) + END DO + WRITE (MDST,8043) + DO J=1, NRGRP + WRITE (MDST,8044) J, LOADMP(:,J) + END DO +#endif ! ! 7.e Warnings ! @@ -2082,16 +2188,22 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 7.f Reset NMPSCR to first processor of first rank 1 grid ! -!/MPI CALL WMSETM ( INGRP(1,1), MDSE, MDST ) -!/MPI NMPSCR = CROOT +#ifdef W3_MPI + CALL WMSETM ( INGRP(1,1), MDSE, MDST ) + NMPSCR = CROOT +#endif ! -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! ! 8. Actual initializations ----------------------------------------- / ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' + PRFT0 = PRFTN +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & @@ -2109,10 +2221,14 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.a Loop over models for per-model initialization ! -!/T WRITE (MDST,9080) -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' -!/MPRF PRFT0 = PRFTN +#ifdef W3_T + WRITE (MDST,9080) +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' + PRFT0 = PRFTN +#endif ! DO I=1, NRGRD J = LEN_TRIM(MNAMES(I)) @@ -2122,14 +2238,18 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & WRITE (MDSS,981) I, MNAMES(I)(1:J) ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! ! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) ! ..... Initial output file hook up ! CALL WMSETM ( I, MDSE, MDST ) -!/MPI MPI_COMM_LOC = MPI_COMM_GRD -!/MPI IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#ifdef W3_MPI + MPI_COMM_LOC = MPI_COMM_GRD + IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#endif ! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) @@ -2269,7 +2389,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END IF END IF ! -!/T WRITE (MDST,9081) I, TIME +#ifdef W3_T + WRITE (MDST,9081) I, TIME +#endif ! ! 8.a.2 Data file initialization (forcing) ! @@ -2394,123 +2516,145 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & GRSTAT(I) = 0 TSYNC(:,I) = TIME(:) ! -!/SMC !!Li Check GTYPE values after initialization. JGLi08Apr2021 -!/SMC IF( IMPROC .EQ. CROOT ) WRITE(MDSE,*) " GRID CROOT GTYPE", & -!/SMC I, CROOT, GRIDS(I)%GTYPE +#ifdef W3_SMC + !!Li Check GTYPE values after initialization. JGLi08Apr2021 + IF( IMPROC .EQ. CROOT ) WRITE(MDSE,*) " GRID CROOT GTYPE", & + I, CROOT, GRIDS(I)%GTYPE +#endif ! -!/T WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) +#ifdef W3_T + WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) +#endif ! END DO !! 8.a I-NRGRD loop ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) -!/MPI CALL W3SETO ( I, MDSE, MDST ) -!/MPI IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN -!/MPI CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif ! ! 8.a.4 Grid sizes etc. for processors that are not used. ! -!/MPI CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & -!/SMC !! SMC grid related variables are not needed beyond MPI_COMM_GRD -!/SMC !! so all dimensions are minimised to 1. JGLi29Mar2021 -!/MPI/!/SMC !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & -!/MPI/!/SMC !!Li , NARC, NBAC, NSPEC & -!/MPI/!/SMC , 1, 1, 1, 1, 1, 1, 1, 1 & -!/MPI ) -!/MPI CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( XGRD, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( YGRD, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & -!/MPI XGRD, YGRD ) -!/MPI CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) -!/MPI CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI END IF -!/MPI END DO -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & +#endif +#ifdef W3_SMC + !! SMC grid related variables are not needed beyond MPI_COMM_GRD + !! so all dimensions are minimised to 1. JGLi29Mar2021 +#endif +#ifdef W3_MPI +#ifdef W3_SMC + !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & + !!Li , NARC, NBAC, NSPEC & + , 1, 1, 1, 1, 1, 1, 1, 1 & +#endif + ) + CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XGRD, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( YGRD, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & + XGRD, YGRD ) + CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) + CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + END IF + END DO + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! DO I=1, NRGRD IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN @@ -2521,10 +2665,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.a.5 Test output ! -!/T WRITE (MDST,9020) 'AFTER SETUP' -!/T DO I=1, NRGRD -!/T WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) -!/T END DO +#ifdef W3_T + WRITE (MDST,9020) 'AFTER SETUP' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif ! ! 8.a.6 Check for coordinate system ! @@ -2534,9 +2680,11 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.b Input files ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' + PRFT0 = PRFTN +#endif ! DO I=1, NRINP ! @@ -2590,9 +2738,11 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.c Inter model initialization ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' + PRFT0 = PRFTN +#endif ! 8.c.1 Spectral conversion flags and source term flags ! @@ -2612,14 +2762,18 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ..... At this point the grid-search-utility (GSU) object for grids ! that do not belong to this processor is no longer needed. ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) +#endif ! the next line (with the W3GSUD call) removed Jan 8 2013. ! ...ref: personal communication, ! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. ! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) -!/MPI END DO +#ifdef W3_MPI + END DO +#endif ! ! ..... Unit numbers ! @@ -2641,9 +2795,13 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & BCDUMP(I) = .FALSE. END IF ! -!/SHRD IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN -!/MPI IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & -!/MPI MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#ifdef W3_SHRD + IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN +#endif +#ifdef W3_MPI + IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#endif CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN J = LEN_TRIM(FILEXT) @@ -2665,44 +2823,58 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ..... Data initialization ! DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) -!/SHRD CALL WMIOBS ( I ) +#ifdef W3_MPI + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) +#endif +#ifdef W3_SHRD + CALL WMIOBS ( I ) +#endif END DO ! DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) -!/SHRD CALL WMIOBG ( I ) +#ifdef W3_MPI + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) +#endif +#ifdef W3_SHRD + CALL WMIOBG ( I ) +#endif END DO ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) -!/MPI END DO +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) + END DO +#endif ! ! 8.c.3 Relation to same ranked grids ! -!/SMC !! Check whether there is a SMC grid group. JGLi12Apr2021 -!/SMC NGRPSMC = 0 -!/SMC DO JJ=1, NRGRP -!/SMC J = 0 -!/SMC DO II=1, INGRP(JJ,0) -!/SMC I = INGRP(JJ,II) -!/SMC IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 -!/SMC ENDDO -!/SMC IF( J .GT. 1 ) NGRPSMC = JJ -!/SMC ENDDO -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC -!/SMC -!/SMC !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 -!/SMC IF( NGRPSMC .GT. 0 ) THEN -!/SMC CALL WMSMCEQL -!/SMC ELSE +#ifdef W3_SMC + !! Check whether there is a SMC grid group. JGLi12Apr2021 + NGRPSMC = 0 + DO JJ=1, NRGRP + J = 0 + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 + ENDDO + IF( J .GT. 1 ) NGRPSMC = JJ + ENDDO + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC + + !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 + IF( NGRPSMC .GT. 0 ) THEN + CALL WMSMCEQL + ELSE +#endif ! CALL WMGEQL ! -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif ! ! 8.c.4 Relation to higher ranked grids ! @@ -2746,15 +2918,17 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & OT2(0)%PNAMES ) END IF ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) -!/MPI CALL W3SETO ( I, MDSE, MDST ) -!/MPI IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN -!/MPI CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + END IF + END DO +#endif ! END IF ! @@ -2857,10 +3031,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSO,937) 'No higher rank grid dependencies' END IF ! -!/T WRITE (MDST,9083) -!/T DO I=-NRINP, NRGRD -!/T WRITE (MDST,9084) I, IDINP(I,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9083) + DO I=-NRINP, NRGRD + WRITE (MDST,9084) I, IDINP(I,:) + END DO +#endif ! ! Test output of connected units (always) ! @@ -2871,16 +3047,22 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & MNAMES & ,OUTFF ) ! -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! CALL DATE_AND_TIME ( VALUES=CLKDT2 ) CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif !!!!!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) !!!!!/MPI CALL MPI_FINALIZE ( IERR_MPI ) !!!!!/MPI stop 'Ending in wminitmd, case 1' @@ -3101,7 +3283,9 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & 987 FORMAT ( ' Initializing grids ...') 988 FORMAT ( ' Input data grid',I3,' [',A,']') ! -!/MPRF 990 FORMAT (1X,3F12.3,' WMINIT',1X,A) +#ifdef W3_MPRF + 990 FORMAT (1X,3F12.3,' WMINIT',1X,A) +#endif ! 998 FORMAT ( ' Running the model :'/ & ' --------------------------------------------------'/) @@ -3163,45 +3347,57 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & 1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') 1082 FORMAT ( ' No boundary data dump for grid',I3/) ! -!/T 9000 FORMAT ( ' TEST WMINIT : UNIT NUMBERS : ',5I6/ & -!/T ' INPUT FILE NAME : ',A) -! -!/T 9020 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR GRIDS (',A,')'/ & -!/T 15X,'GRID MDS(1-13)',43X,'NTRACE') -!/T 9021 FORMAT (14X,16I4) -!/T 9022 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR INTPUT FILES'/ & -!/T 15X,'GRID MDSF(JFIRST-9)') -!/T 9030 FORMAT ( ' TEST WMINIT : FILE EXTENSIONS, INPUT FLAGS,', & -!/T ' RANK AND GROUP, PROC RANGE') -!/T 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) -!/T 9032 FORMAT ( ' TEST WMINIT : PROCESSED RANK NUMBERS') -!/T 9033 FORMAT ( ' ',I3,1X,A,1X,I4) -!/T 9034 FORMAT ( ' TEST WMINIT : NUMBER OF GROUPS :',I4) -!/T 9035 FORMAT ( ' TEST WMINIT : SIZE OF GROUPS :',20I3) -!/T 9036 FORMAT ( ' TEST WMINIT : GROUP SIZE AND COMPONENTS :') -!/T 9037 FORMAT ( ' ',2I3,':',20I3) -! -!/T 9050 FORMAT ( ' TEST WMINIT : GRID NUMBER',I3,' =================') -!/T 9051 FORMAT ( ' TEST WMINIT : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & -!/T 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) -!/T 9053 FORMAT ( ' TEST WMINITNML : OUTFF : ',I9.8 & -!/T 5(/24X,I9.8) ) -!/T 9052 FORMAT ( ' TEST WMINIT : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) -! -!/T 9060 FORMAT ( ' TEST WMINIT : GRID MOVEMENT DATA') -!/T 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) -! -!/T 9070 FORMAT ( ' TEST WMINIT : ALLPRC ') -!/T 9071 FORMAT ( ' ',I3,' : ',250I3) -!/T 8042 FORMAT ( ' TEST WMINIT : MODMAP ') -!/T 8043 FORMAT ( ' TEST WMINIT : LOADMP ') -!/T 8044 FORMAT ( ' ',I3,' : ',250I2) -! -!/T 9080 FORMAT ( ' TEST WMINIT : MODEL INITIALIZATION') -!/T 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) -!/T 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) -!/T 9083 FORMAT ( ' TEST WMINIT : IDINP AFTER INITIALIZATION :') -!/T 9084 FORMAT ( ' ',I4,17(2X,A3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMINIT : UNIT NUMBERS : ',5I6/ & + ' INPUT FILE NAME : ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR GRIDS (',A,')'/ & + 15X,'GRID MDS(1-13)',43X,'NTRACE') + 9021 FORMAT (14X,16I4) + 9022 FORMAT ( ' TEST WMINIT : UNIT NUMBERS FOR INTPUT FILES'/ & + 15X,'GRID MDSF(JFIRST-9)') + 9030 FORMAT ( ' TEST WMINIT : FILE EXTENSIONS, INPUT FLAGS,', & + ' RANK AND GROUP, PROC RANGE') + 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) + 9032 FORMAT ( ' TEST WMINIT : PROCESSED RANK NUMBERS') + 9033 FORMAT ( ' ',I3,1X,A,1X,I4) + 9034 FORMAT ( ' TEST WMINIT : NUMBER OF GROUPS :',I4) + 9035 FORMAT ( ' TEST WMINIT : SIZE OF GROUPS :',20I3) + 9036 FORMAT ( ' TEST WMINIT : GROUP SIZE AND COMPONENTS :') + 9037 FORMAT ( ' ',2I3,':',20I3) +#endif +! +#ifdef W3_T + 9050 FORMAT ( ' TEST WMINIT : GRID NUMBER',I3,' =================') + 9051 FORMAT ( ' TEST WMINIT : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) + 9053 FORMAT ( ' TEST WMINITNML : OUTFF : ',I9.8 & + 5(/24X,I9.8) ) + 9052 FORMAT ( ' TEST WMINIT : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) +#endif +! +#ifdef W3_T + 9060 FORMAT ( ' TEST WMINIT : GRID MOVEMENT DATA') + 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) +#endif +! +#ifdef W3_T + 9070 FORMAT ( ' TEST WMINIT : ALLPRC ') + 9071 FORMAT ( ' ',I3,' : ',250I3) + 8042 FORMAT ( ' TEST WMINIT : MODMAP ') + 8043 FORMAT ( ' TEST WMINIT : LOADMP ') + 8044 FORMAT ( ' ',I3,' : ',250I2) +#endif +! +#ifdef W3_T + 9080 FORMAT ( ' TEST WMINIT : MODEL INITIALIZATION') + 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) + 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) + 9083 FORMAT ( ' TEST WMINIT : IDINP AFTER INITIALIZATION :') + 9084 FORMAT ( ' ',I4,17(2X,A3)) +#endif !/ !/ End of WMINIT ----------------------------------------------------- / !/ @@ -3467,20 +3663,28 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & USE WMIOPOMD, ONLY: WMIOPP !/ USE W3SERVMD, ONLY: ITRACE, EXTCDE, NEXTLN, WWDATE, WWTIME -!/S USE W3SERVMD, ONLY: STRACE -!/MPRF USE W3TIMEMD, ONLY: PRINIT, PRTIME +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPRF + USE W3TIMEMD, ONLY: PRINIT, PRTIME +#endif USE W3TIMEMD, ONLY: STME21, DSEC21, TICK21, TDIFF USE WMUNITMD, ONLY: WMUINI, WMUDMP, WMUSET, WMUGET, WMUINQ !/ USE W3GDATMD, ONLY: GTYPE, NX, NY, FILEXT, NSEA, FLAGST, GRIDS -!/SMC USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC -!/SMC USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE -!/MPI USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & -!/MPI XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & -!/MPI HQFAC, HPFAC, MAPSTA, MAPST2, & -!/MPI GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & -!/MPI TH, DTMAX, DTCFL -!/MPI USE W3GSRUMD +#ifdef W3_SMC + USE W3GDATMD, ONLY: NCel, NUFc, NVFc, NRLv, NBSMC + USE W3GDATMD, ONLY: NARC, NBAC, NSPEC, SMCTYPE +#endif +#ifdef W3_MPI + USE W3GDATMD, ONLY: FLAGLL, ICLOSE, GSU, X0, Y0, SX, SY, & + XGRD, YGRD, DXDP, DXDQ, DYDP, DYDQ, & + HQFAC, HPFAC, MAPSTA, MAPST2, & + GRIDSHIFT, NSEAL, NK, NTH, XFR, FR1, & + TH, DTMAX, DTCFL + USE W3GSRUMD +#endif USE W3WDATMD, ONLY: TIME USE W3ADATMD, ONLY: WADATS USE W3IDATMD, ONLY: INFLAGS1, INPUTS, IINIT, & @@ -3500,15 +3704,21 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & GRSTAT, DTRES, BCDUMP, FLGHG1, FLGHG2, & INPMAP, IDINP, NGRPSMC USE WMMDATMD, ONLY: CLKDT1, CLKDT2, CLKFIN -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & -!/MPI MPI_COMM_BCT, CROOT, FBCAST -!/MPRF USE WMMDATMD, ONLY: MDSP +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST +#endif +#ifdef W3_MPRF + USE WMMDATMD, ONLY: MDSP +#endif USE W3INITMD, ONLY: WWVER USE W3NMLMULTIMD !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -3547,8 +3757,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! INTEGER :: TTIME(2), TOUT(2), STMPT(2), ETMPT(2),& TLST(2) -!/MPI INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: IERR_MPI, BGROUP, LGROUP, IROOT +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! INTEGER, ALLOCATABLE :: MDS(:,:), NTRACE(:,:), ODAT(:,:), & TMPRNK(:), TMPGRP(:), NINGRP(:), & @@ -3557,8 +3771,10 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ,OUTFF(:,:) ! REAL :: DTTST, XX, YY -!/MPRF REAL :: PRFT0, PRFTN -!/MPRF REAL(KIND=8) :: get_memory +#ifdef W3_MPRF + REAL :: PRFT0, PRFTN + REAL(KIND=8) :: get_memory +#endif ! REAL, ALLOCATABLE :: X(:), Y(:), AMOVE(:), DMOVE(:), & RP1(:), RPN(:) @@ -3577,7 +3793,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CHARACTER(LEN=6), & ALLOCATABLE :: ACTION(:) CHARACTER(LEN=8) :: LFILE, STTIME -!/SHRD CHARACTER(LEN=9) :: TFILE +#ifdef W3_SHRD + CHARACTER(LEN=9) :: TFILE +#endif CHARACTER(LEN=13) :: STDATE, MN, TNAMES(9) CHARACTER(LEN=40) :: PN CHARACTER(LEN=13), & @@ -3585,8 +3803,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CHARACTER(LEN=40), & ALLOCATABLE :: PNAMES(:) CHARACTER(LEN=12) :: FORMAT -!/DIST CHARACTER(LEN=18) :: TFILE -!/MPRF CHARACTER(LEN=18) :: PFILE +#ifdef W3_DIST + CHARACTER(LEN=18) :: TFILE +#endif +#ifdef W3_MPRF + CHARACTER(LEN=18) :: PFILE +#endif CHARACTER(LEN=13) :: IDFLDS(-7:9) CHARACTER(LEN=23) :: DTME21 CHARACTER(LEN=30) :: IDOTYP(8) @@ -3626,16 +3848,20 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & DATA YESXX / 'YES/--' / DATA XXXNO / '---/NO' / ! -!/MPRF CALL PRINIT -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRINIT + CALL PRTIME ( PRFT0 ) +#endif ! CALL DATE_AND_TIME ( VALUES=CLKDT1 ) ! MPI_COMM_LOC = MPI_COMM -!/MPI MPI_COMM_MWAVE = MPI_COMM -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + MPI_COMM_MWAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_MWAVE, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_MWAVE, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! IF ( PRESENT(PREAMB) ) FNMPRE = PREAMB !/ @@ -3651,19 +3877,21 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CALL WMUSET ( 6,6, 5, .TRUE., 'SYS', 'stdin', 'Standart input' ) CALL WMUSET ( 6,6, 6, .TRUE., 'SYS', 'stdout','Standart output') ! -!/NL2 CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) -!/NL2 CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#ifdef W3_NL2 + CALL WMUSET (6,6,103, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,104, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,105, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,106, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,107, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,108, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,109, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,110, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,111, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,112, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,113, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,114, .TRUE., 'FIX', DESC='Reserved SNL2' ) + CALL WMUSET (6,6,117, .TRUE., 'FIX', DESC='Reserved SNL2' ) +#endif ! ! ... Unit numbers from parameter list ! Dynamic scripture updated per file @@ -3686,7 +3914,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! CALL ITRACE ( MDST, NTRMAX ) ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif ! ! 1.c Input file ! @@ -3718,9 +3948,15 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IW = 1 + INT ( LOG10 ( REAL(NMPROC) + 0.5 ) ) IW = MAX ( 3 , MIN ( 9 , IW ) ) WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') '(A4,I',IW,'.',IW,',A5)' -!/SHRD TFILE = 'test.mww3' -!/DIST WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' -!/MPRF WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#ifdef W3_SHRD + TFILE = 'test.mww3' +#endif +#ifdef W3_DIST + WRITE (TFILE,FORMAT) 'test', IMPROC, '.mww3' +#endif +#ifdef W3_MPRF + WRITE (PFILE,FORMAT) 'prf.', IMPROC, '.mww3' +#endif ! IF ( IMPROC .EQ. NMPLOG ) THEN OPEN (MDSO,FILE=TRIM(FNMPRE)//LFILE,ERR=2010,IOSTAT=IERR) @@ -3740,15 +3976,19 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & TRIM(FNMPRE)//TFILE(:IFT), 'Test output file') END IF ! -!/MPRF IFT = LEN_TRIM(PFILE) -!/MPRF CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) -!/MPRF CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & -!/MPRF TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') -!/MPRF OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#ifdef W3_MPRF + IFT = LEN_TRIM(PFILE) + CALL WMUGET ( MDSS, MDST, MDSP, 'OUT' ) + CALL WMUSET ( MDSS, MDST, MDSP, .TRUE., 'OUT', & + TRIM(FNMPRE)//PFILE(:IFT), 'Profiling file') + OPEN (MDSP,FILE=TRIM(FNMPRE)//PFILE(:IFT),ERR=2011,IOSTAT=IERR) +#endif ! ! 1.e Initial and test output ! -!/S CALL STRACE (IENT, 'WMINITNML') +#ifdef W3_S + CALL STRACE (IENT, 'WMINITNML') +#endif ! IF ( IMPROC .EQ. NMPLOG ) THEN CALL WWDATE ( STDATE ) @@ -3756,7 +3996,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSO,901) WWVER, STDATE, STTIME END IF ! -!/T WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#ifdef W3_T + WRITE(MDST,9000) IDSI, IDSO, IDSS, IDST, IDSE, IFNAME +#endif ! ! 2. Set-up of data structures and I/O ----------------------------- / ! 2.a Get number of grids @@ -3852,10 +4094,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & NTRACE( 2,I) = NTRMAX END DO ! -!/T WRITE (MDST,9020) 'INITIAL' -!/T DO I=1, NRGRD -!/T WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) -!/T END DO +#ifdef W3_T + WRITE (MDST,9020) 'INITIAL' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif ! ! 3. Get individual grid information -------------------------------- / ! @@ -3877,7 +4121,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 3.a Read data ! -!/T WRITE (MDST,9030) +#ifdef W3_T + WRITE (MDST,9030) +#endif ! ! 3.a.1 Input grids ! @@ -3967,8 +4213,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & I = I + 1 CALL W3SETI ( I, MDSE, MDST ) INFLAGS1 = .FALSE. -!/MGW INFLAGS1(10) = .TRUE. -!/MGP INFLAGS1(10) = .TRUE. +#ifdef W3_MGW + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGP + INFLAGS1(10) = .TRUE. +#endif INAMES(I,:)= INAMES(J,:) MNAMES(I) = MNAMES(J) TMPRNK(I) = TMPRNK(J) @@ -3976,8 +4226,10 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & RP1(I) = RP1(J) RPN(I) = RPN(J) BCDUMP(I) = BCDTMP(J) -!/T WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & -!/T TMPGRP(I), RP1(I), RPN(I) +#ifdef W3_T + WRITE (MDST,9031) I, MNAMES(I), INFLAGS1, TMPRNK(I), & + TMPGRP(I), RP1(I), RPN(I) +#endif END IF END DO IF ( I .EQ. NRGRD ) EXIT @@ -4062,15 +4314,19 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,9022) -!/T DO I=-NRINP, NRGRD -!/T IF ( I .EQ. 0 ) CYCLE -!/T WRITE (MDST,9021) I, MDSF(I,JFIRST:9) -!/T END DO +#ifdef W3_T + WRITE (MDST,9022) + DO I=-NRINP, NRGRD + IF ( I .EQ. 0 ) CYCLE + WRITE (MDST,9021) I, MDSF(I,JFIRST:9) + END DO +#endif ! ! 3.c Set rank and group data ! -!/T WRITE (MDST,9032) +#ifdef W3_T + WRITE (MDST,9032) +#endif ! RNKMAX = MAXVAL ( TMPRNK(1:NRGRD) ) + 1 RNKTMP = 0 @@ -4087,9 +4343,11 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T DO I=1, NRGRD -!/T WRITE (MDST,9033) I, MNAMES(I), GRANK(I) -!/T END DO +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRANK(I) + END DO +#endif ! RNKMAX = RNKTMP GRPMAX = MAXVAL ( TMPGRP(1:NRGRD) ) + 1 @@ -4115,11 +4373,13 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,9034) NRGRP -!/T DO I=1, NRGRD -!/T WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) -!/T END DO -!/T WRITE (MDST,9035) NINGRP(1:NRGRP) +#ifdef W3_T + WRITE (MDST,9034) NRGRP + DO I=1, NRGRD + WRITE (MDST,9033) I, MNAMES(I), GRGRP(I) + END DO + WRITE (MDST,9035) NINGRP(1:NRGRP) +#endif ! ALLOCATE ( ACTION(JFIRST:11) ) ALLOCATE ( INGRP(NRGRP,0:MAXVAL(NINGRP(:NRGRP))) ) @@ -4131,17 +4391,21 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & INGRP(GRGRP(I),INGRP(GRGRP(I),0)) = I END DO ! -!/T WRITE (MDST,9036) -!/T DO J=1, NRGRP -!/T WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) -!/T END DO +#ifdef W3_T + WRITE (MDST,9036) + DO J=1, NRGRP + WRITE (MDST,9037) J, INGRP(J,:INGRP(J,0)) + END DO +#endif ! ! ! 3.d Unified point output ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.b' + PRFT0 = PRFTN +#endif ! IF ( UNIPTS ) THEN ! @@ -4620,11 +4884,13 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! END DO ! -!/T DO I=1, NRGRD -!/T WRITE (MDST,9050) I -!/T WRITE (MDST,9053) ODAT(:,I) -!/T WRITE (MDST,9052) FLGRD(:,:,I) -!/T END DO +#ifdef W3_T + DO I=1, NRGRD + WRITE (MDST,9050) I + WRITE (MDST,9053) ODAT(:,I) + WRITE (MDST,9052) FLGRD(:,:,I) + END DO +#endif ! ! 6. Read moving grid data ------------------------------------------ / ! @@ -4796,11 +5062,15 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 7.c Set communicators and ALLPRC array ! -!/T WRITE (MDST,9070) +#ifdef W3_T + WRITE (MDST,9070) +#endif IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,974) IF ( NMPLOG.EQ.IMPROC ) WRITE (MDSO,1974) ! -!/MPI CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_COMM_GROUP ( MPI_COMM_MWAVE, BGROUP, IERR_MPI ) +#endif ALLOCATE ( TMPRNK(NMPROC) ) NAPRES = NCPROC ! @@ -4813,10 +5083,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & CALL WMSETM ( I, MDSE, MDST ) NAPLOC = 1 + IPN - IP1 NAPADD = NAPLOC -!/MPI CROOT = IP1 -!/MPI FBCAST = NAPLOC .NE. NCPROC -!/MPI FBCAST = NAPLOC .NE. NCPROC .OR. & -!/MPI ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) +#ifdef W3_MPI + CROOT = IP1 + FBCAST = NAPLOC .NE. NCPROC + FBCAST = NAPLOC .NE. NCPROC .OR. & + ( IOSTYP.GT.1 .AND. .NOT.PSHARE ) +#endif DO J=IP1, IPN TMPRNK(1+J-IP1) = J - 1 END DO @@ -4835,11 +5107,13 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & TMPRNK(NAPADD) = NMPROC - 1 END IF ! -!/MPI CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & -!/MPI IERR_MPI ) -!/MPI CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & -!/MPI MPI_COMM_GRD, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_GROUP_INCL ( BGROUP, NAPADD, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_GRD, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) +#endif ! DO II=IP1, IPN ALLPRC(II,I) = 1 + II - IP1 @@ -4864,7 +5138,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ALLPRC(NMPROC,I) = II END IF ! -!/T WRITE (MDST,9071) I, ALLPRC(:,I) +#ifdef W3_T + WRITE (MDST,9071) I, ALLPRC(:,I) +#endif ! ! ... output ! @@ -4949,21 +5225,23 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( NMPLOG .EQ. IMPROC ) & WRITE (MDSO,1975)MNAMES(I), IP1, IPN, OUTSTR ! -!/MPI IF ( FBCAST ) THEN -!/MPI TMPRNK(1) = IP1 - 1 -!/MPI NAPBCT = 1 -!/MPI DO J=1, NMPROC -!/MPI IF ( ALLPRC(J,I) .EQ. 0 ) THEN -!/MPI NAPBCT = NAPBCT + 1 -!/MPI TMPRNK(NAPBCT) = J - 1 -!/MPI END IF -!/MPI END DO -!/MPI CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & -!/MPI LGROUP, IERR_MPI ) -!/MPI CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) -!/MPI END IF +#ifdef W3_MPI + IF ( FBCAST ) THEN + TMPRNK(1) = IP1 - 1 + NAPBCT = 1 + DO J=1, NMPROC + IF ( ALLPRC(J,I) .EQ. 0 ) THEN + NAPBCT = NAPBCT + 1 + TMPRNK(NAPBCT) = J - 1 + END IF + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPBCT, TMPRNK, & + LGROUP, IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_MWAVE, LGROUP, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + END IF +#endif ! END DO ! @@ -4999,14 +5277,16 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO END DO ! -!/T WRITE (MDST,8042) -!/T DO J=1, NRGRP -!/T WRITE (MDST,8044) J, MODMAP(:,J) -!/T END DO -!/T WRITE (MDST,8043) -!/T DO J=1, NRGRP -!/T WRITE (MDST,8044) J, LOADMP(:,J) -!/T END DO +#ifdef W3_T + WRITE (MDST,8042) + DO J=1, NRGRP + WRITE (MDST,8044) J, MODMAP(:,J) + END DO + WRITE (MDST,8043) + DO J=1, NRGRP + WRITE (MDST,8044) J, LOADMP(:,J) + END DO +#endif ! ! 7.e Warnings ! @@ -5023,16 +5303,22 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 7.f Reset NMPSCR to first processor of first rank 1 grid ! -!/MPI CALL WMSETM ( INGRP(1,1), MDSE, MDST ) -!/MPI NMPSCR = CROOT +#ifdef W3_MPI + CALL WMSETM ( INGRP(1,1), MDSE, MDST ) + NMPSCR = CROOT +#endif ! -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! ! 8. Actual initializations ----------------------------------------- / ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8' + PRFT0 = PRFTN +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,980) ALLOCATE ( TSYNC(2,0:NRGRD), TMAX(2,NRGRD), TOUTP(2,0:NRGRD), & @@ -5050,10 +5336,14 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.a Loop over models for per-model initialization ! -!/T WRITE (MDST,9080) -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' -!/MPRF PRFT0 = PRFTN +#ifdef W3_T + WRITE (MDST,9080) +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.a' + PRFT0 = PRFTN +#endif ! DO I=1, NRGRD J = LEN_TRIM(MNAMES(I)) @@ -5063,14 +5353,18 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & IF ( MDSS.NE.MDSO .AND. NMPSC2.EQ.IMPROC ) & WRITE (MDSS,981) I, MNAMES(I)(1:J) ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! ! 8.a.1 Wave model initialization (NOTE: sets all grid pointers) ! ..... Initial output file hook up ! CALL WMSETM ( I, MDSE, MDST ) -!/MPI MPI_COMM_LOC = MPI_COMM_GRD -!/MPI IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#ifdef W3_MPI + MPI_COMM_LOC = MPI_COMM_GRD + IF ( MPI_COMM_LOC .EQ. MPI_COMM_NULL ) CYCLE +#endif ! CALL WMUGET ( MDSE, MDST, NDSFND, 'OUT' ) CALL WMUSET ( MDSE, MDST, NDSFND, .TRUE., DESC='Log file' ) @@ -5209,7 +5503,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END IF END IF ! -!/T WRITE (MDST,9081) I, TIME +#ifdef W3_T + WRITE (MDST,9081) I, TIME +#endif ! ! 8.a.2 Data file initialization (forcing) ! @@ -5331,119 +5627,139 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & GRSTAT(I) = 0 TSYNC(:,I) = TIME(:) ! -!/T WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) +#ifdef W3_T + WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) +#endif ! END DO ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) -!/MPI CALL W3SETO ( I, MDSE, MDST ) -!/MPI IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN -!/MPI CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( TOUTP(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TSYNC(1,I), 2, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRSTAT(I), 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif ! ! 8.a.4 Grid sizes etc. for processors that are not used. ! -!/MPI CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & -!/SMC !! SMC grid related variables are not needed beyond MPI_COMM_GRD -!/SMC !! so all dimensions are minimised to 1. JGLi29Mar2021 -!/MPI/!/SMC !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & -!/MPI/!/SMC !!Li , NARC, NBAC, NSPEC & -!/MPI/!/SMC , 1, 1, 1, 1, 1, 1, 1, 1 & -!/MPI ) -!/MPI CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( XGRD, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( YGRD, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & -!/MPI XGRD, YGRD ) -!/MPI CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & -!/MPI CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) -!/MPI CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -! -!/MPI END IF -!/MPI END DO -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BCAST ( FLAGLL,1, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GTYPE, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( ICLOSE,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NX , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NY , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( X0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SX , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( Y0 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( SY , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEA , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NSEAL, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTMAX, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTCFL, 1, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FILEXT, 10, MPI_CHARACTER, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMX ( I, NX, NY, NSEA, MDSE, MDST & +#endif +#ifdef W3_SMC + !! SMC grid related variables are not needed beyond MPI_COMM_GRD + !! so all dimensions are minimised to 1. JGLi29Mar2021 +#endif +#ifdef W3_MPI +#ifdef W3_SMC + !!Li , NCel, NUFc, NVFc, NRLv, NBSMC & + !!Li , NARC, NBAC, NSPEC & + , 1, 1, 1, 1, 1, 1, 1, 1 & +#endif + ) + CALL MPI_BCAST ( HQFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( HPFAC, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XGRD, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( YGRD, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + GSU = W3GSUC( .FALSE., FLAGLL, ICLOSE, & + XGRD, YGRD ) + CALL MPI_BCAST ( DXDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DXDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDP, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DYDQ, NX*NY, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPSTA, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( MAPST2, NX*NY, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( GRIDSHIFT, 1, MPI_DOUBLE_PRECISION, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( NK , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NTH , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( XFR , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( FR1 , 1, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) + IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) & + CALL W3DIMS ( I, NK, NTH, MDSE, MDST ) + CALL MPI_BCAST ( TH , NTH, MPI_REAL , 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( NAPROC,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NAPPNT,1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( NBI , 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + CALL MPI_BCAST ( FLOUT, 8, MPI_LOGICAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( DTOUT , 8, MPI_REAL, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TONEXT,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + CALL MPI_BCAST ( TOLAST,16, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) +#endif +! +#ifdef W3_MPI + END IF + END DO + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! DO I=1, NRGRD IF ( ALLPRC(IMPROC,I) .EQ. 0 ) THEN @@ -5454,10 +5770,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.a.5 Test output ! -!/T WRITE (MDST,9020) 'AFTER SETUP' -!/T DO I=1, NRGRD -!/T WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) -!/T END DO +#ifdef W3_T + WRITE (MDST,9020) 'AFTER SETUP' + DO I=1, NRGRD + WRITE (MDST,9021) I, MDS(:,I), NTRACE(:,I) + END DO +#endif ! ! 8.a.6 Check for coordinate system ! @@ -5467,9 +5785,11 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.b Input files ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.c' + PRFT0 = PRFTN +#endif ! DO I=1, NRINP ! @@ -5522,9 +5842,11 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ! 8.c Inter model initialization ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' -!/MPRF PRFT0 = PRFTN +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'START Sec. 8.d' + PRFT0 = PRFTN +#endif ! 8.c.1 Spectral conversion flags and source term flags ! @@ -5544,14 +5866,18 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ..... At this point the grid-search-utility (GSU) object for grids ! that do not belong to this processor is no longer needed. ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) +#endif ! the next line (with the W3GSUD call) removed Jan 8 2013. ! ...ref: personal communication, ! ...email from Rogers to Alves, Campbell, Tolman, Chawla Dec 13 2012. ! REMOVED !/MPI IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) CALL W3GSUD( GSU ) -!/MPI END DO +#ifdef W3_MPI + END DO +#endif ! ! ..... Unit numbers ! @@ -5573,9 +5899,13 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & BCDUMP(I) = .FALSE. END IF ! -!/SHRD IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN -!/MPI IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & -!/MPI MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#ifdef W3_SHRD + IF ( .NOT. FLRBPI(I) .AND. FLBPI ) THEN +#endif +#ifdef W3_MPI + IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL) THEN +#endif CALL WMUSET ( MDSE, MDST, NDS(9), .FALSE. ) IF ( BCDUMP(I) .AND. IAPROC.EQ.NAPBPT ) THEN J = LEN_TRIM(FILEXT) @@ -5597,44 +5927,58 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ! ..... Data initialization ! DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) -!/SHRD CALL WMIOBS ( I ) +#ifdef W3_MPI + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBS ( I ) +#endif +#ifdef W3_SHRD + CALL WMIOBS ( I ) +#endif END DO ! DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) -!/SHRD CALL WMIOBG ( I ) +#ifdef W3_MPI + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBG ( I ) +#endif +#ifdef W3_SHRD + CALL WMIOBG ( I ) +#endif END DO ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) -!/MPI END DO +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) CALL WMIOBF ( I ) + END DO +#endif ! ! 8.c.3 Relation to same ranked grids ! -!/SMC !! Check whether there is a SMC grid group. JGLi12Apr2021 -!/SMC NGRPSMC = 0 -!/SMC DO JJ=1, NRGRP -!/SMC J = 0 -!/SMC DO II=1, INGRP(JJ,0) -!/SMC I = INGRP(JJ,II) -!/SMC IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 -!/SMC ENDDO -!/SMC IF( J .GT. 1 ) NGRPSMC = JJ -!/SMC ENDDO -!/SMC IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC -!/SMC -!/SMC !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 -!/SMC IF( NGRPSMC .GT. 0 ) THEN -!/SMC CALL WMSMCEQL -!/SMC ELSE +#ifdef W3_SMC + !! Check whether there is a SMC grid group. JGLi12Apr2021 + NGRPSMC = 0 + DO JJ=1, NRGRP + J = 0 + DO II=1, INGRP(JJ,0) + I = INGRP(JJ,II) + IF( GRIDS(I)%GTYPE .EQ. SMCTYPE ) J = J + 1 + ENDDO + IF( J .GT. 1 ) NGRPSMC = JJ + ENDDO + IF( IMPROC.EQ.NMPERR ) WRITE (MDSE,*) " NGRPSMC =", NGRPSMC + + !! Equal ranked SMC grid group uses its own sub. JGLi12Apr2021 + IF( NGRPSMC .GT. 0 ) THEN + CALL WMSMCEQL + ELSE +#endif ! CALL WMGEQL ! -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif ! ! 8.c.4 Relation to higher ranked grids ! @@ -5676,15 +6020,17 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & OT2(0)%PNAMES ) END IF ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI CALL W3SETG ( I, MDSE, MDST ) -!/MPI CALL W3SETO ( I, MDSE, MDST ) -!/MPI IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN -!/MPI CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & -!/MPI MPI_COMM_BCT, IERR_MPI ) -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + CALL W3SETG ( I, MDSE, MDST ) + CALL W3SETO ( I, MDSE, MDST ) + IF ( FBCAST .AND. MPI_COMM_BCT.NE.MPI_COMM_NULL ) THEN + CALL MPI_BCAST ( NOPTS, 1, MPI_INTEGER, 0, & + MPI_COMM_BCT, IERR_MPI ) + END IF + END DO +#endif ! END IF ! @@ -5787,10 +6133,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSO,937) 'No higher rank grid dependencies' END IF ! -!/T WRITE (MDST,9083) -!/T DO I=-NRINP, NRGRD -!/T WRITE (MDST,9084) I, IDINP(I,:) -!/T END DO +#ifdef W3_T + WRITE (MDST,9083) + DO I=-NRINP, NRGRD + WRITE (MDST,9084) I, IDINP(I,:) + END DO +#endif ! ! Test output of connected units (always) ! @@ -5800,16 +6148,22 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & DEALLOCATE ( MDS, NTRACE, ODAT, FLGRD, FLGR2, FLGD, FLG2, INAMES,& MNAMES ) ! -!/MPI CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! CALL DATE_AND_TIME ( VALUES=CLKDT2 ) CLKFIN = TDIFF ( CLKDT1,CLKDT2 ) ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory(), 'END' +#endif ! IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,998) -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif !!!!!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) !!!!!/MPI CALL MPI_FINALIZE ( IERR_MPI ) !!!!!/MPI stop @@ -6045,7 +6399,9 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & 987 FORMAT ( ' Initializing grids ...') 988 FORMAT ( ' Input data grid',I3,' [',A,']') ! -!/MPRF 990 FORMAT (1X,3F12.3,' WMINITNML',1X,A) +#ifdef W3_MPRF + 990 FORMAT (1X,3F12.3,' WMINITNML',1X,A) +#endif ! 998 FORMAT ( ' Running the model :'/ & ' --------------------------------------------------'/) @@ -6113,43 +6469,55 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & 1081 FORMAT (/' *** NO BOUNDARY DATA TO DUMP, GRID :',I4,' ***') 1082 FORMAT ( ' No boundary data dump for grid',I3/) ! -!/T 9000 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS : ',5I6/ & -!/T ' INPUT FILE NAME : ',A) -! -!/T 9020 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR GRIDS (',A,')'/ & -!/T 15X,'GRID MDS(1-13)',43X,'NTRACE') -!/T 9021 FORMAT (14X,16I4) -!/T 9022 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR INTPUT FILES'/ & -!/T 15X,'GRID MDSF(JFIRST-9)') -!/T 9030 FORMAT ( ' TEST WMINITNML : FILE EXTENSIONS, INPUT FLAGS,', & -!/T ' RANK AND GROUP, PROC RANGE') -!/T 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) -!/T 9032 FORMAT ( ' TEST WMINITNML : PROCESSED RANK NUMBERS') -!/T 9033 FORMAT ( ' ',I3,1X,A,1X,I4) -!/T 9034 FORMAT ( ' TEST WMINITNML : NUMBER OF GROUPS :',I4) -!/T 9035 FORMAT ( ' TEST WMINITNML : SIZE OF GROUPS :',20I3) -!/T 9036 FORMAT ( ' TEST WMINITNML : GROUP SIZE AND COMPONENTS :') -!/T 9037 FORMAT ( ' ',2I3,':',20I3) -! -!/T 9050 FORMAT ( ' TEST WMINITNML : GRID NUMBER',I3,' =================') -!/T 9051 FORMAT ( ' TEST WMINITNML : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & -!/T 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) -!/T 9052 FORMAT ( ' TEST WMINITNML : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) -! -!/T 9060 FORMAT ( ' TEST WMINITNML : GRID MOVEMENT DATA') -!/T 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) -! -!/T 9070 FORMAT ( ' TEST WMINITNML : ALLPRC ') -!/T 9071 FORMAT ( ' ',I3,' : ',250I3) -!/T 8042 FORMAT ( ' TEST WMINITNML : MODMAP ') -!/T 8043 FORMAT ( ' TEST WMINITNML : LOADMP ') -!/T 8044 FORMAT ( ' ',I3,' : ',250I2) -! -!/T 9080 FORMAT ( ' TEST WMINITNML : MODEL INITIALIZATION') -!/T 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) -!/T 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) -!/T 9083 FORMAT ( ' TEST WMINITNML : IDINP AFTER INITIALIZATION :') -!/T 9084 FORMAT ( ' ',I4,17(2X,A3)) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS : ',5I6/ & + ' INPUT FILE NAME : ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR GRIDS (',A,')'/ & + 15X,'GRID MDS(1-13)',43X,'NTRACE') + 9021 FORMAT (14X,16I4) + 9022 FORMAT ( ' TEST WMINITNML : UNIT NUMBERS FOR INTPUT FILES'/ & + 15X,'GRID MDSF(JFIRST-9)') + 9030 FORMAT ( ' TEST WMINITNML : FILE EXTENSIONS, INPUT FLAGS,', & + ' RANK AND GROUP, PROC RANGE') + 9031 FORMAT ( ' ',I3,1X,A,20L2,2I4,2F6.2) + 9032 FORMAT ( ' TEST WMINITNML : PROCESSED RANK NUMBERS') + 9033 FORMAT ( ' ',I3,1X,A,1X,I4) + 9034 FORMAT ( ' TEST WMINITNML : NUMBER OF GROUPS :',I4) + 9035 FORMAT ( ' TEST WMINITNML : SIZE OF GROUPS :',20I3) + 9036 FORMAT ( ' TEST WMINITNML : GROUP SIZE AND COMPONENTS :') + 9037 FORMAT ( ' ',2I3,':',20I3) +#endif +! +#ifdef W3_T + 9050 FORMAT ( ' TEST WMINITNML : GRID NUMBER',I3,' =================') + 9051 FORMAT ( ' TEST WMINITNML : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 5(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) + 9052 FORMAT ( ' TEST WMINITNML : FLGRD : ',5(5L2,1X)/24X,5(5L2,1X)) +#endif +! +#ifdef W3_T + 9060 FORMAT ( ' TEST WMINITNML : GRID MOVEMENT DATA') + 9061 FORMAT ( ' ',I8.8,I7,1X,2F8.2) +#endif +! +#ifdef W3_T + 9070 FORMAT ( ' TEST WMINITNML : ALLPRC ') + 9071 FORMAT ( ' ',I3,' : ',250I3) + 8042 FORMAT ( ' TEST WMINITNML : MODMAP ') + 8043 FORMAT ( ' TEST WMINITNML : LOADMP ') + 8044 FORMAT ( ' ',I3,' : ',250I2) +#endif +! +#ifdef W3_T + 9080 FORMAT ( ' TEST WMINITNML : MODEL INITIALIZATION') + 9081 FORMAT ( ' MODEL AND TIME :',I4,I10.8,I8.6) + 9082 FORMAT ( ' STATUS AND TIMES :',I4,3(I10.8,I8.6)) + 9083 FORMAT ( ' TEST WMINITNML : IDINP AFTER INITIALIZATION :') + 9084 FORMAT ( ' ',I4,17(2X,A3)) +#endif !/ !/ End of WMINITNML ----------------------------------------------------- / !/ diff --git a/model/ftn/wmiopomd.ftn b/model/src/wmiopomd.F90 similarity index 61% rename from model/ftn/wmiopomd.ftn rename to model/src/wmiopomd.F90 index 7e9aaae9b..39e7fc157 100644 --- a/model/ftn/wmiopomd.ftn +++ b/model/src/wmiopomd.F90 @@ -185,25 +185,35 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) USE W3WDATMD, ONLY: W3SETW USE W3ODATMD, ONLY: W3SETO, W3DMO2 USE WMMDATMD, ONLY: WMSETM -!/MPI USE W3INITMD, ONLY: W3MPIP +#ifdef W3_MPI + USE W3INITMD, ONLY: W3MPIP +#endif USE W3IOPOMD, ONLY: W3IOPP USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, MAPSTA, GRIDS, & FLAGLL, ICLOSE, ICLOSE_NONE, GTYPE, UNGTYPE, & CLGTYPE, GSU USE W3GDATMD, ONLY: XYB, TRIGP, MAXX, MAXY, DXYMAX ! unstructured grids USE W3ODATMD, ONLY: O2INIT, NOPTS, PTLOC, PTNME, GRDID, OUTPTS -!/MPI USE W3ODATMD, ONLY: O2IRQI +#ifdef W3_MPI + USE W3ODATMD, ONLY: O2IRQI +#endif USE WMMDATMD, ONLY: MDSE, MDST, NRGRD, MDATAS, IMPROC, NMPSCR, & NMPERR, MDSS USE W3TRIAMD -!/MPI USE WMMDATMD, ONLY: MPI_COMM_GRD, MPI_COMM_MWAVE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_GRD, MPI_COMM_MWAVE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -219,7 +229,9 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) INTEGER :: IX(4), IY(4) ! created by w3grmp REAL :: RD(4) ! created by w3grmp INTEGER :: itout, I1, I2, I3 ! unstructured grids -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IERR_MPI REAL :: RX, RY, RDX, RDY REAL, PARAMETER :: ACC = 0.05 @@ -229,23 +241,31 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) LOGICAL, SAVE :: SETUP = .FALSE., FLGO7a = .FALSE. CHARACTER(LEN=40), ALLOCATABLE :: PN(:) !/ -!/S CALL STRACE (IENT, 'WMIOPP') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOPP') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! CALL W3SETO ( 0, MDSE, MDST ) ! -!/T WRITE (MDST,9000) O2INIT, NPT, PRESENT(XPT), & -!/T PRESENT(YPT), PRESENT(PNAMES) -!/O7a FLGO7a = .TRUE. +#ifdef W3_T + WRITE (MDST,9000) O2INIT, NPT, PRESENT(XPT), & + PRESENT(YPT), PRESENT(PNAMES) +#endif +#ifdef W3_O7a + FLGO7a = .TRUE. +#endif ! ! -------------------------------------------------------------------- / ! 1. Initialize if necessary and possible ! IF ( .NOT. O2INIT ) THEN ! -!/T WRITE (MDST,9010) +#ifdef W3_T + WRITE (MDST,9010) +#endif ! IF ( .NOT.PRESENT(XPT) .OR. .NOT.PRESENT(YPT) .OR. & .NOT.PRESENT(PNAMES) ) THEN @@ -267,7 +287,9 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) ! 2. Locate points in grids ! 2.a Check all points for all grids ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! IF ( FLAGLL ) THEN FACTOR = 1. @@ -342,35 +364,41 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) ! ! 2.c Diagnostic output ! -!/O7b IF ( IMPROC .EQ. NMPSCR ) THEN -!/O7b WRITE (MDSS,920) -!/O7b DO IPT=1, NOPTS -!/O7b DO J=1, NRGRD -!/O7b IF ( GRIDS(J)%FILEXT .EQ. GRDID(IPT) ) EXIT -!/O7b END DO -!/O7b IF ( J .GT. NRGRD ) THEN -!/O7b WRITE (MDSS,921) PTNME(IPT), PTLOC(:,IPT)*FACTOR -!/O7b ELSE -!/O7b WRITE (MDSS,922) PTNME(IPT), PTLOC(:,IPT)*FACTOR, & -!/O7b GRIDS(J)%FILEXT -!/O7b END IF -!/O7b END DO -!/O7b WRITE (MDSS,929) -!/O7b END IF +#ifdef W3_O7b + IF ( IMPROC .EQ. NMPSCR ) THEN + WRITE (MDSS,920) + DO IPT=1, NOPTS + DO J=1, NRGRD + IF ( GRIDS(J)%FILEXT .EQ. GRDID(IPT) ) EXIT + END DO + IF ( J .GT. NRGRD ) THEN + WRITE (MDSS,921) PTNME(IPT), PTLOC(:,IPT)*FACTOR + ELSE + WRITE (MDSS,922) PTNME(IPT), PTLOC(:,IPT)*FACTOR, & + GRIDS(J)%FILEXT + END IF + END DO + WRITE (MDSS,929) + END IF +#endif ! ! 2.d Test output ! -!/T DO IPT=1, NOPTS -!/T WRITE (MDST,9021) IPT, PTNME(IPT), GRDID(IPT) -!/T END DO +#ifdef W3_T + DO IPT=1, NOPTS + WRITE (MDST,9021) IPT, PTNME(IPT), GRDID(IPT) + END DO +#endif ! -!/T IPT = NOPTS -!/T WRITE (MDST,9022) -!/T DO J=1, NRGRD -!/T WRITE (MDST,9023) J, MDATAS(J)%NRUPTS, GRIDS(J)%FILEXT -!/T IPT = IPT - MDATAS(J)%NRUPTS -!/T END DO -!/T WRITE (MDST,9024) IPT +#ifdef W3_T + IPT = NOPTS + WRITE (MDST,9022) + DO J=1, NRGRD + WRITE (MDST,9023) J, MDATAS(J)%NRUPTS, GRIDS(J)%FILEXT + IPT = IPT - MDATAS(J)%NRUPTS + END DO + WRITE (MDST,9024) IPT +#endif ! DEALLOCATE ( INGRID ) ! @@ -380,7 +408,9 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) ! DO J=1, NRGRD ! -!/T WRITE (MDST,9030) J +#ifdef W3_T + WRITE (MDST,9030) J +#endif ! ! 3.b (De)allocate map arrays ! @@ -404,75 +434,107 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) PN(IPT) = PTNME(II) END DO ! -!/T DO IPT=1, MDATAS(J)%NRUPTS -!/T WRITE (MDST,9031) IPT, MDATAS(J)%UPTMAP(IPT),XP(IPT),YP(IPT),PN(IPT) -!/T END DO +#ifdef W3_T + DO IPT=1, MDATAS(J)%NRUPTS + WRITE (MDST,9031) IPT, MDATAS(J)%UPTMAP(IPT),XP(IPT),YP(IPT),PN(IPT) + END DO +#endif ! -!/MPI IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) -!/O7a IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,930) & -!/O7a J, GRIDS(J)%FILEXT, IPT +#ifdef W3_MPI + IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_O7a + IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,930) & + J, GRIDS(J)%FILEXT, IPT +#endif ! ! 3.d Preprocessing for output ! -!/T WRITE (MDST,9032) +#ifdef W3_T + WRITE (MDST,9032) +#endif ! ! 3.d.1 Shared memory version ! -!/SHRD CALL W3SETO ( J, MDSE, MDST ) -!/SHRD CALL W3SETG ( J, MDSE, MDST ) -! -!/SHRD IF ( O2INIT ) THEN -!/SHRD DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & -!/SHRD OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & -!/SHRD OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & -!/SHRD OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & -!/SHRD OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & -!/SHRD OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & -!/SHRD OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & -!/SHRD OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) -!/SHRD O2INIT = .FALSE. -!/SHRD END IF +#ifdef W3_SHRD + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) +#endif +! +#ifdef W3_SHRD + IF ( O2INIT ) THEN + DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & + OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & + OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & + OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & + OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & + OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & + OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & + OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) + O2INIT = .FALSE. + END IF +#endif ! -!/SHRD CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) +#ifdef W3_SHRD + CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) +#endif ! ! 3.d.2 Distributed memory version ! -!/MPI CALL WMSETM ( J, MDSE, MDST ) -! -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -! -!/MPI CALL W3SETO ( J, MDSE, MDST ) -!/MPI CALL W3SETG ( J, MDSE, MDST ) -!/MPI CALL W3SETA ( J, MDSE, MDST ) -!/MPI CALL W3SETW ( J, MDSE, MDST ) -! -!/MPI IF ( O2INIT ) THEN -!/MPI DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & -!/MPI OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & -!/MPI OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & -!/MPI OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & -!/MPI OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & -!/MPI OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & -!/MPI OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & -!/MPI OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) -!/MPI O2INIT = .FALSE. -!/MPI END IF +#ifdef W3_MPI + CALL WMSETM ( J, MDSE, MDST ) +#endif +! +#ifdef W3_MPI + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#endif +! +#ifdef W3_MPI + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) + CALL W3SETA ( J, MDSE, MDST ) + CALL W3SETW ( J, MDSE, MDST ) +#endif +! +#ifdef W3_MPI + IF ( O2INIT ) THEN + DEALLOCATE ( OUTPTS(J)%OUT2%IPTINT, & + OUTPTS(J)%OUT2%IL , OUTPTS(J)%OUT2%IW , & + OUTPTS(J)%OUT2%II , OUTPTS(J)%OUT2%PTIFAC, & + OUTPTS(J)%OUT2%PTNME, OUTPTS(J)%OUT2%GRDID , & + OUTPTS(J)%OUT2%DPO , OUTPTS(J)%OUT2%WAO , & + OUTPTS(J)%OUT2%WDO , OUTPTS(J)%OUT2%ASO , & + OUTPTS(J)%OUT2%CAO , OUTPTS(J)%OUT2%CDO , & + OUTPTS(J)%OUT2%SPCO , OUTPTS(J)%OUT2%PTLOC ) + O2INIT = .FALSE. + END IF +#endif ! -!/MPI CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) +#ifdef W3_MPI + CALL W3IOPP ( MDATAS(J)%NRUPTS, XP, YP, PN, J ) +#endif ! -!/MPI IF ( O2IRQI ) THEN -!/MPI DEALLOCATE (OUTPTS(J)%OUT2%IRQPO1, & -!/MPI OUTPTS(J)%OUT2%IRQPO2 ) -!/MPI O2IRQI = .FALSE. -!/MPI END IF +#ifdef W3_MPI + IF ( O2IRQI ) THEN + DEALLOCATE (OUTPTS(J)%OUT2%IRQPO1, & + OUTPTS(J)%OUT2%IRQPO2 ) + O2IRQI = .FALSE. + END IF +#endif ! -!/MPI CALL W3MPIP ( J ) +#ifdef W3_MPI + CALL W3MPIP ( J ) +#endif ! -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! ! This barrier is needed to straighten out output. ! -!/O7a IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,939) +#ifdef W3_O7a + IF ( IMPROC.EQ.NMPSCR ) WRITE (MDSS,939) +#endif ! ! 3.e Reset pointers and clean up ! @@ -481,7 +543,9 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) ! END DO ! -!/MPI IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#ifdef W3_MPI + IF ( FLGO7a ) CALL MPI_BARRIER ( MPI_COMM_MWAVE, IERR_MPI ) +#endif ! ! -------------------------------------------------------------------- / ! 4. Finalize @@ -492,34 +556,46 @@ SUBROUTINE WMIOPP ( NPT, XPT, YPT, PNAMES ) ! ! Formats ! -!/O7b 920 FORMAT (/' Diagnostic test output for output points :'/ & -!/O7b ' -------------------------------------------------') -!/O7b 921 FORMAT ( ' ',A,' (',2F8.2,') NO GRID FOUND') -!/O7b 922 FORMAT ( ' ',A,' (',2F8.2,') grid ',A) -!/O7b 929 FORMAT ( ' ') +#ifdef W3_O7b + 920 FORMAT (/' Diagnostic test output for output points :'/ & + ' -------------------------------------------------') + 921 FORMAT ( ' ',A,' (',2F8.2,') NO GRID FOUND') + 922 FORMAT ( ' ',A,' (',2F8.2,') grid ',A) + 929 FORMAT ( ' ') +#endif ! -!/O7a 930 FORMAT (/' Grid ',I3,' [',A,']',I4,' points :'/ & -!/O7a ' -------------------------------------------------') -!/O7a 939 FORMAT ( ' ') +#ifdef W3_O7a + 930 FORMAT (/' Grid ',I3,' [',A,']',I4,' points :'/ & + ' -------------------------------------------------') + 939 FORMAT ( ' ') +#endif ! 1000 FORMAT (/' *** ERROR WMIOPP : INITALIZATION DATA NOT', & ' AVAILABLE *** '/) ! -!/T 9000 FORMAT ( ' TEST WMIOPP : O2INIT :',L2/ & -!/T ' PAR LIST :',I4,3L2) -! -!/T 9010 FORMAT ( ' TEST WMIOPP : INITIALIZING DATA GRID 0') -! -!/T 9020 FORMAT ( ' TEST WMIOPP : FINDING POINTS IN GRID') -!/T 9021 FORMAT ( ' ',I4,2X,A,2X,A) -!/T 9022 FORMAT ( ' TEST WMIOPP : OUTPUT POINTS PER GRID') -!/T 9023 FORMAT ( ' GRID',I3,' HAS',I4,' OUTPUT ', & -!/T 'POINTS, NAME = ',A) -!/T 9024 FORMAT ( ' UNALLOCATED POINTS :',I4) -! -!/T 9030 FORMAT ( ' TEST WMIOPP : PREPPING GRID',I3) -!/T 9031 FORMAT ( ' ',2I5,2E12.3,2X,A) -!/T 9032 FORMAT ( ' TEST WMIOPP : RUNNING W3IOPP / W3MPIP') +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOPP : O2INIT :',L2/ & + ' PAR LIST :',I4,3L2) +#endif +! +#ifdef W3_T + 9010 FORMAT ( ' TEST WMIOPP : INITIALIZING DATA GRID 0') +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMIOPP : FINDING POINTS IN GRID') + 9021 FORMAT ( ' ',I4,2X,A,2X,A) + 9022 FORMAT ( ' TEST WMIOPP : OUTPUT POINTS PER GRID') + 9023 FORMAT ( ' GRID',I3,' HAS',I4,' OUTPUT ', & + 'POINTS, NAME = ',A) + 9024 FORMAT ( ' UNALLOCATED POINTS :',I4) +#endif +! +#ifdef W3_T + 9030 FORMAT ( ' TEST WMIOPP : PREPPING GRID',I3) + 9031 FORMAT ( ' ',2I5,2E12.3,2X,A) + 9032 FORMAT ( ' TEST WMIOPP : RUNNING W3IOPP / W3MPIP') +#endif !/ !/ End of WMIOPP ----------------------------------------------------- / !/ @@ -612,13 +688,19 @@ SUBROUTINE WMIOPO ( TOUT ) ICEO,ICEHO,ICEFO USE WMMDATMD, ONLY: MDST, MDSE, IMPROC, NMPROC, NMPUPT, NRGRD, & RESPEC, UPTMAP, MDSUP -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, ALLPRC, & -!/MPI MTAG0 -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, ALLPRC, & + MTAG0 +#endif +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -629,22 +711,34 @@ SUBROUTINE WMIOPO ( TOUT ) !/ Local parameters !/ INTEGER :: J, I, II, IT0, IT, ITARG, IFROM -!/SHRD INTEGER :: MPI_COMM_GRD = 1, CROOT = 1 -!/SHRD INTEGER, PARAMETER :: MPI_COMM_NULL = -1 -!/MPI INTEGER :: IERR_MPI, NMPPNT -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_SHRD + INTEGER :: MPI_COMM_GRD = 1, CROOT = 1 + INTEGER, PARAMETER :: MPI_COMM_NULL = -1 +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI, NMPPNT + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, POINTER :: SPEC(:,:) -!/MPI REAL, POINTER :: SPCR(:,:), DPR(:), WAR(:), & -!/MPI WDR(:), ASR(:), CAR(:), CDR(:) -!/MPI REAL, POINTER :: ICRO(:), ICRFO(:), ICRHO(:) +#ifdef W3_MPI + REAL, POINTER :: SPCR(:,:), DPR(:), WAR(:), & + WDR(:), ASR(:), CAR(:), CDR(:) + REAL, POINTER :: ICRO(:), ICRFO(:), ICRHO(:) +#endif !/ -!/S CALL STRACE (IENT, 'WMIOPO') +#ifdef W3_S + CALL STRACE (IENT, 'WMIOPO') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/T WRITE (MDST,9000) NMPUPT, IMPROC +#ifdef W3_T + WRITE (MDST,9000) NMPUPT, IMPROC +#endif ! IF ( IMPROC .EQ. NMPUPT ) THEN OUTPTS(0)%OUT2%SPCO = 0. @@ -670,34 +764,46 @@ SUBROUTINE WMIOPO ( TOUT ) CALL W3SETG ( J, MDSE, MDST ) CALL WMSETM ( J, MDSE, MDST ) ! -!/T WRITE (MDST,9010) J, NOPTS, IAPROC, NAPPNT +#ifdef W3_T + WRITE (MDST,9010) J, NOPTS, IAPROC, NAPPNT +#endif ! ! 1.b Determine if action ! IF ( MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN -!/T WRITE (MDST,9011) +#ifdef W3_T + WRITE (MDST,9011) +#endif CYCLE END IF ! IF ( NOPTS .EQ. 0 ) THEN -!/T WRITE (MDST,9012) +#ifdef W3_T + WRITE (MDST,9012) +#endif CYCLE END IF ! IF ( IAPROC .NE. NAPPNT ) THEN -!/T WRITE (MDST,9014) +#ifdef W3_T + WRITE (MDST,9014) +#endif CYCLE END IF ! ! 1.c Data here, and to remain on present processor. ! IF ( IMPROC .EQ. NMPUPT ) THEN -!/T WRITE (MDST,9015) +#ifdef W3_T + WRITE (MDST,9015) +#endif ! ! 1.c.1 Spectral conversion if needed ! IF ( RESPEC(0,J) ) THEN -!/T WRITE (MDST,9016) 'YES' +#ifdef W3_T + WRITE (MDST,9016) 'YES' +#endif ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) CALL W3CSPC ( SPCO, NK, NTH, XFR, FR1, TH(1), SPEC, & SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & @@ -707,13 +813,17 @@ SUBROUTINE WMIOPO ( TOUT ) ! 1.c.2 Spectral conversion not needed ! ELSE -!/T WRITE (MDST,9016) 'NO' +#ifdef W3_T + WRITE (MDST,9016) 'NO' +#endif SPEC => SPCO END IF ! ! 1.d Store data at grid 0 ! -!/T WRITE (MDST,9017) J +#ifdef W3_T + WRITE (MDST,9017) J +#endif ! DO I=1, NOPTS II = UPTMAP(I) @@ -733,42 +843,76 @@ SUBROUTINE WMIOPO ( TOUT ) ! ! 1.e Data here, and to be sent to other processor. ! -!/MPI ELSE -! -!/MPIT WRITE (MDST,9018) J, IMPROC, NMPUPT -! -!/MPI IT0 = MTAG0 - 7*NRGRD - 1 -!/MPI IT = IT0 + (J-1)*7 -!/MPI ITARG = NMPUPT - 1 -! -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( SPCO(1,1), NSPEC*NOPTS, MPI_REAL, & -!/MPI ITARG, IT, MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'SPECTRA' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( DPO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( WAO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WIND SPEED' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( WDO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( ASO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( CAO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' -!/MPI IT = IT + 1 -!/MPI CALL MPI_SEND ( CDO(1), NOPTS, MPI_REAL, ITARG, IT, & -!/MPI MPI_COMM_MWAVE, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#ifdef W3_MPI + ELSE +#endif +! +#ifdef W3_MPIT + WRITE (MDST,9018) J, IMPROC, NMPUPT +#endif +! +#ifdef W3_MPI + IT0 = MTAG0 - 7*NRGRD - 1 + IT = IT0 + (J-1)*7 + ITARG = NMPUPT - 1 +#endif +! +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( SPCO(1,1), NSPEC*NOPTS, MPI_REAL, & + ITARG, IT, MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'SPECTRA' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( DPO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( WAO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WIND SPEED' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( WDO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( ASO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( CAO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_SEND ( CDO(1), NOPTS, MPI_REAL, ITARG, IT, & + MPI_COMM_MWAVE, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#endif !JDM: The below should be added for points using partitioned processors ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so ! this is being left here commented out for now. @@ -794,71 +938,119 @@ SUBROUTINE WMIOPO ( TOUT ) ! 2. Check if this is output processor, otherwise exit ! IF ( IMPROC .NE. NMPUPT ) THEN -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif RETURN END IF ! ! -------------------------------------------------------------------- / ! 3. Loop over grids for processing remote data ! -!/MPIT WRITE (MDST,9030) +#ifdef W3_MPIT + WRITE (MDST,9030) +#endif ! ! 3.a Loop setup ! -!/MPI DO J=1, NRGRD -! -!/MPI CALL W3SETO ( J, MDSE, MDST ) -!/MPI CALL W3SETG ( J, MDSE, MDST ) -!/MPI CALL WMSETM ( J, MDSE, MDST ) +#ifdef W3_MPI + DO J=1, NRGRD +#endif ! -!/MPI DO NMPPNT= NMPROC, 1, -1 -!/MPI IF ( ALLPRC(NMPPNT,J) .EQ. NAPPNT ) EXIT -!/MPI END DO +#ifdef W3_MPI + CALL W3SETO ( J, MDSE, MDST ) + CALL W3SETG ( J, MDSE, MDST ) + CALL WMSETM ( J, MDSE, MDST ) +#endif ! -!/MPIT WRITE (MDST,9031) J, NOPTS, NMPPNT -!/MPI IF ( NMPPNT.EQ.NMPUPT .OR. NOPTS.EQ.0 ) THEN -!/MPIT WRITE (MDST,9032) -!/MPI CYCLE -!/MPI END IF +#ifdef W3_MPI + DO NMPPNT= NMPROC, 1, -1 + IF ( ALLPRC(NMPPNT,J) .EQ. NAPPNT ) EXIT + END DO +#endif +! +#ifdef W3_MPIT + WRITE (MDST,9031) J, NOPTS, NMPPNT +#endif +#ifdef W3_MPI + IF ( NMPPNT.EQ.NMPUPT .OR. NOPTS.EQ.0 ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9032) +#endif +#ifdef W3_MPI + CYCLE + END IF +#endif ! ! 3.b Receive data ! -!/MPI IT0 = MTAG0 - 7*NRGRD - 1 -!/MPI IT = IT0 + (J-1)*7 -!/MPI IFROM = NMPPNT - 1 -!/MPI ALLOCATE ( SPCR(NSPEC,NOPTS), STATUS(MPI_STATUS_SIZE,1), & -!/MPI DPR(NOPTS), WAR(NOPTS), WDR(NOPTS), ASR(NOPTS),& -!/MPI CAR(NOPTS), CDR(NOPTS), ICRO(NOPTS), & -!/MPI ICRFO(NOPTS), ICRHO(NOPTS) ) -! -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( SPCR(1,1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'SPECTRA' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( DPR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( WAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WIND SPEED' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( WDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( ASR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( CAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' -!/MPI IT = IT + 1 -!/MPI CALL MPI_RECV ( CDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & -!/MPI IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) -!/MPIT WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#ifdef W3_MPI + IT0 = MTAG0 - 7*NRGRD - 1 + IT = IT0 + (J-1)*7 + IFROM = NMPPNT - 1 + ALLOCATE ( SPCR(NSPEC,NOPTS), STATUS(MPI_STATUS_SIZE,1), & + DPR(NOPTS), WAR(NOPTS), WDR(NOPTS), ASR(NOPTS),& + CAR(NOPTS), CDR(NOPTS), ICRO(NOPTS), & + ICRFO(NOPTS), ICRHO(NOPTS) ) +#endif +! +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( SPCR(1,1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'SPECTRA' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( DPR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WATER DEPTHS' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( WAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WIND SPEED' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( WDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'WIND DIRECTION' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( ASR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'AIR_SEA TEMP DIFF' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( CAR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'CURRENT VELOCITY' +#endif +#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV ( CDR(1), NSPEC*NOPTS, MPI_REAL, IFROM, & + IT, MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif +#ifdef W3_MPIT + WRITE (MDST,9019) IT-IT0, 'CURRENT DIRECTION' +#endif !JDM: The below should be added for points using partitioned processors ! for multigrid, however I am unsure if the IT0 (7 to 10?) should be changed so ! this is being left here commented out for now. @@ -878,47 +1070,67 @@ SUBROUTINE WMIOPO ( TOUT ) ! ! 3.c Convert if necessary ! -!/MPI IF ( RESPEC(0,J) ) THEN -!/MPIT WRITE (MDST,9016) 'YES' -!/MPI ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) -!/MPI CALL W3CSPC ( SPCR, NK, NTH, XFR, FR1, TH(1), SPEC, & -!/MPI SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & -!/MPI SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & -!/MPI SGRDS(0)%FACHFE ) -!/MPI ELSE -!/MPIT WRITE (MDST,9016) 'NO' -!/MPI SPEC => SPCR -!/MPI END IF +#ifdef W3_MPI + IF ( RESPEC(0,J) ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9016) 'YES' +#endif +#ifdef W3_MPI + ALLOCATE ( SPEC(SGRDS(0)%NSPEC,NOPTS) ) + CALL W3CSPC ( SPCR, NK, NTH, XFR, FR1, TH(1), SPEC, & + SGRDS(0)%NK, SGRDS(0)%NTH, SGRDS(0)%XFR, & + SGRDS(0)%FR1, SGRDS(0)%TH(1), NOPTS, MDST, MDSE, & + SGRDS(0)%FACHFE ) + ELSE +#endif +#ifdef W3_MPIT + WRITE (MDST,9016) 'NO' +#endif +#ifdef W3_MPI + SPEC => SPCR + END IF +#endif ! ! 3.d Store data at grid 0 ! -!/MPIT WRITE (MDST,9117) J -! -!/MPI DO I=1, NOPTS -!/MPI II = UPTMAP(I) -!/MPI OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) -!/MPI OUTPTS(0)%OUT2%DPO(II) = DPR(I) -!/MPI OUTPTS(0)%OUT2%WAO(II) = WAR(I) -!/MPI OUTPTS(0)%OUT2%WDO(II) = WDR(I) -!/MPI OUTPTS(0)%OUT2%ASO(II) = ASR(I) -!/MPI OUTPTS(0)%OUT2%CAO(II) = CAR(I) -!/MPI OUTPTS(0)%OUT2%CDO(II) = CDR(I) -!/MPI OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) -!/MPI OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) -!/MPI OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) -!/MPI END DO -! -!/MPI IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) -!/MPI DEALLOCATE ( SPCR, DPR, WAR, WDR, ASR, CAR, CDR, STATUS ) +#ifdef W3_MPIT + WRITE (MDST,9117) J +#endif +! +#ifdef W3_MPI + DO I=1, NOPTS + II = UPTMAP(I) + OUTPTS(0)%OUT2%SPCO(:,II) = SPEC(:,I) + OUTPTS(0)%OUT2%DPO(II) = DPR(I) + OUTPTS(0)%OUT2%WAO(II) = WAR(I) + OUTPTS(0)%OUT2%WDO(II) = WDR(I) + OUTPTS(0)%OUT2%ASO(II) = ASR(I) + OUTPTS(0)%OUT2%CAO(II) = CAR(I) + OUTPTS(0)%OUT2%CDO(II) = CDR(I) + OUTPTS(0)%OUT2%ICEO(II) = ICEO(I) + OUTPTS(0)%OUT2%ICEFO(II) = ICEFO(I) + OUTPTS(0)%OUT2%ICEHO(II) = ICEHO(I) + END DO +#endif +! +#ifdef W3_MPI + IF ( RESPEC(0,J) ) DEALLOCATE ( SPEC ) + DEALLOCATE ( SPCR, DPR, WAR, WDR, ASR, CAR, CDR, STATUS ) +#endif ! !JDM add deallocates here and check the itag stuff.. really not ! sure aabout that -!/MPI DEALLOCATE (ICRO, ICRFO, ICRHO) -!/MPI END DO +#ifdef W3_MPI + DEALLOCATE (ICRO, ICRFO, ICRHO) + END DO +#endif ! ! -------------------------------------------------------------------- / ! 4. Output data ! -!/T WRITE (MDST,9040) +#ifdef W3_T + WRITE (MDST,9040) +#endif ! CALL W3SETO ( 0, MDSE, MDST ) CALL W3SETG ( 0, MDSE, MDST ) @@ -932,27 +1144,35 @@ SUBROUTINE WMIOPO ( TOUT ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMIOPO : OUTPUT/ACTUAL PROCESS : ',2I6) -!/T 9010 FORMAT ( ' TEST WMIOPO : PROCESSING GRID : ',I6/ & -!/T ' OUTPUT POINTS : ',I6/ & -!/T ' ACTUAL/OUTPUT PROCESS : ',2I6) -!/T 9011 FORMAT ( ' CYCLE : GRID NOT ON PROCESS') -!/T 9012 FORMAT ( ' CYCLE : GRID WITHOUT OUTPUT POINTS') -!/T 9014 FORMAT ( ' CYCLE : DATA NOT ON PRESENT PROCESS') -!/T 9015 FORMAT ( ' TEST WMIOPO : PROCESSING DATA LOCALLY') -!/T 9016 FORMAT ( ' TEST WMIOPO : NEED FOR SPECTRAL CONVERSION : ',A) -!/T 9017 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & -!/T ' IN GRID 0') -!/MPIT 9117 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & -!/MPIT ' IN GRID 0') -!/MPIT 9018 FORMAT ( ' TEST WMIOPO : GRID',I4,' SEND FROM',I4,' TO',I4) -!/MPIT 9019 FORMAT ( ' IT = ',I4,' PAR = ',A) -! -!/T 9020 FORMAT ( ' TEST WMIOPO : DONE AT THIS PROCESSOR') -! -!/MPIT 9030 FORMAT ( ' TEST WMIOPO : LOOP OVER GRIDS FOR REMOTE DATA') -!/MPIT 9031 FORMAT ( ' TEST WMIOPO : GRID',I4,',',I4,' POINTS FROM',I4) -!/MPIT 9032 FORMAT ( ' NOTHING TO RECEIVE') +#ifdef W3_T + 9000 FORMAT ( ' TEST WMIOPO : OUTPUT/ACTUAL PROCESS : ',2I6) + 9010 FORMAT ( ' TEST WMIOPO : PROCESSING GRID : ',I6/ & + ' OUTPUT POINTS : ',I6/ & + ' ACTUAL/OUTPUT PROCESS : ',2I6) + 9011 FORMAT ( ' CYCLE : GRID NOT ON PROCESS') + 9012 FORMAT ( ' CYCLE : GRID WITHOUT OUTPUT POINTS') + 9014 FORMAT ( ' CYCLE : DATA NOT ON PRESENT PROCESS') + 9015 FORMAT ( ' TEST WMIOPO : PROCESSING DATA LOCALLY') + 9016 FORMAT ( ' TEST WMIOPO : NEED FOR SPECTRAL CONVERSION : ',A) + 9017 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & + ' IN GRID 0') +#endif +#ifdef W3_MPIT + 9117 FORMAT ( ' TEST WMIOPO : STORING DATA FROM GRID',I4, & + ' IN GRID 0') + 9018 FORMAT ( ' TEST WMIOPO : GRID',I4,' SEND FROM',I4,' TO',I4) + 9019 FORMAT ( ' IT = ',I4,' PAR = ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMIOPO : DONE AT THIS PROCESSOR') +#endif +! +#ifdef W3_MPIT + 9030 FORMAT ( ' TEST WMIOPO : LOOP OVER GRIDS FOR REMOTE DATA') + 9031 FORMAT ( ' TEST WMIOPO : GRID',I4,',',I4,' POINTS FROM',I4) + 9032 FORMAT ( ' NOTHING TO RECEIVE') +#endif ! 9040 FORMAT ( ' TEST WMIOPO : PERFORM OUTPUT') !/ diff --git a/model/ftn/wmmdatmd.ftn b/model/src/wmmdatmd.F90 similarity index 88% rename from model/ftn/wmmdatmd.ftn rename to model/src/wmmdatmd.F90 index 6ab896885..03632283b 100644 --- a/model/ftn/wmmdatmd.ftn +++ b/model/src/wmmdatmd.F90 @@ -301,20 +301,26 @@ MODULE WMMDATMD STIME(2), ETIME(2), NRGRD, NRINP, & NRGRP, NMVMAX, NGRPSMC INTEGER :: CLKDT1(8), CLKDT2(8), CLKDT3(8) -!/MPRF INTEGER :: MDSP -!/MPI INTEGER :: MPI_COMM_MWAVE -!/MPI INTEGER, PARAMETER :: MTAGB = 0 -!/MPI INTEGER, PARAMETER :: MTAG0 = 1000 -!/MPI INTEGER, PARAMETER :: MTAG1 = 100000 -!/MPI INTEGER, PARAMETER :: MTAG2 = 1500000 -!/MPI INTEGER, PARAMETER :: MTAG_UB = 2**21-1 !MPI_TAG_UB on Cray XC40 +#ifdef W3_MPRF + INTEGER :: MDSP +#endif +#ifdef W3_MPI + INTEGER :: MPI_COMM_MWAVE + INTEGER, PARAMETER :: MTAGB = 0 + INTEGER, PARAMETER :: MTAG0 = 1000 + INTEGER, PARAMETER :: MTAG1 = 100000 + INTEGER, PARAMETER :: MTAG2 = 1500000 + INTEGER, PARAMETER :: MTAG_UB = 2**21-1 !MPI_TAG_UB on Cray XC40 +#endif INTEGER, ALLOCATABLE :: MDSF(:,:), GRANK(:), GRGRP(:), & INGRP(:,:), GRDHGH(:,:), GRDEQL(:,:),& GRDLOW(:,:), ALLPRC(:,:), & MODMAP(:,:), TSYNC(:,:), TMAX(:,:), & TOUTP(:,:), TDATA(:,:), GRSTAT(:), & NBI2G(:,:), INPMAP(:,:) -!/MPI INTEGER, ALLOCATABLE :: NBISTA(:), HGHSTA(:), EQLSTA(:) +#ifdef W3_MPI + INTEGER, ALLOCATABLE :: NBISTA(:), HGHSTA(:), EQLSTA(:) +#endif REAL :: CLKFIN REAL, ALLOCATABLE :: DTRES(:) LOGICAL :: FLGBDI=.FALSE., FLGHG1, FLGHG2 @@ -326,50 +332,76 @@ MODULE WMMDATMD !/ TYPE MDATA INTEGER :: RCLD(3), NDT(3), NMV, NRUPTS -!/MPI INTEGER :: MPI_COMM_GRD, MPI_COMM_BCT, & -!/MPI CROOT, NRQBPG, NRQHGG, NRQEQG +#ifdef W3_MPI + INTEGER :: MPI_COMM_GRD, MPI_COMM_BCT, & + CROOT, NRQBPG, NRQHGG, NRQEQG +#endif INTEGER, POINTER :: TMV(:,:,:), NBI2S(:,:), MAPMSK(:,:), & UPTMAP(:) -!/MPI INTEGER, POINTER :: IRQBPG(:), IRQHGG(:), IRQEQG(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQBPG(:), IRQHGG(:), IRQEQG(:) +#endif REAL, POINTER :: DATA0(:,:), DATA1(:,:), DATA2(:,:), & AMV(:,:), DMV(:,:) REAL, POINTER :: MAPBDI(:,:), MAPODI(:,:) -!/PDLIB INTEGER, POINTER :: SEA_IPGL(:), SEA_IPGL_TO_PROC(:) +#ifdef W3_PDLIB + INTEGER, POINTER :: SEA_IPGL(:), SEA_IPGL_TO_PROC(:) +#endif LOGICAL :: MINIT, MSKINI, FLLSTL, FLLSTR, & FLLSTI, FLDAT0, FLDAT1, FLDAT2 -!/MPI LOGICAL :: FBCAST +#ifdef W3_MPI + LOGICAL :: FBCAST +#endif END TYPE MDATA ! TYPE BPST -!/MPI INTEGER :: NRQBPS, STIME(2) +#ifdef W3_MPI + INTEGER :: NRQBPS, STIME(2) +#endif INTEGER :: VTIME(2) -!/MPI INTEGER, POINTER :: IRQBPS(:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQBPS(:) +#endif REAL, POINTER :: SBPI(:,:) -!/MPI REAL, POINTER :: TSTORE(:,:) +#ifdef W3_MPI + REAL, POINTER :: TSTORE(:,:) +#endif LOGICAL :: INIT END TYPE BPST ! TYPE HGST INTEGER :: VTIME(2), NTOT, NREC, NRC1, & NSND, NSN1, NSMX, XTIME(2) -!/MPI INTEGER :: NRQHGS, NRQOUT +#ifdef W3_MPI + INTEGER :: NRQHGS, NRQOUT +#endif INTEGER, POINTER :: LJSEA(:), NRAVG(:), IMPSRC(:,:), & ITAG(:,:), ISEND(:,:) -!/MPI INTEGER, POINTER :: IRQHGS(:), OUTDAT(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQHGS(:), OUTDAT(:,:) +#endif REAL, POINTER :: WGTH(:,:), SHGH(:,:,:) -!/MPI REAL, POINTER :: TSTORE(:,:) +#ifdef W3_MPI + REAL, POINTER :: TSTORE(:,:) +#endif LOGICAL :: INIT END TYPE HGST ! TYPE EQST INTEGER :: VTIME(2), NTOT, NREC, NSND, NAVMAX -!/MPI INTEGER :: NRQEQS, NRQOUT +#ifdef W3_MPI + INTEGER :: NRQEQS, NRQOUT +#endif INTEGER, POINTER :: ISEA(:), JSEA(:), NAVG(:), RIP(:,:), & RTG(:,:), SIS(:), SJS(:), SI1(:), & SI2(:), SIP(:), STG(:) -!/MPI INTEGER, POINTER :: IRQEQS(:), OUTDAT(:,:) +#ifdef W3_MPI + INTEGER, POINTER :: IRQEQS(:), OUTDAT(:,:) +#endif REAL, POINTER :: SEQL(:,:,:), WGHT(:), WAVG(:,:) -!/MPI REAL, POINTER :: TSTORE(:,:) +#ifdef W3_MPI + REAL, POINTER :: TSTORE(:,:) +#endif LOGICAL :: INIT END TYPE EQST !/ @@ -384,14 +416,20 @@ MODULE WMMDATMD !/ INTEGER, POINTER :: RCLD(:), NDT(:), NMV, TMV(:,:,:), & NBI2S(:,:), MAPMSK(:,:), UPTMAP(:) -!/MPI INTEGER, POINTER :: MPI_COMM_GRD, MPI_COMM_BCT, CROOT +#ifdef W3_MPI + INTEGER, POINTER :: MPI_COMM_GRD, MPI_COMM_BCT, CROOT +#endif REAL, POINTER :: DATA0(:,:), DATA1(:,:), DATA2(:,:), & AMV(:,:), DMV(:,:) REAL, POINTER :: MAPBDI(:,:), MAPODI(:,:) -!/PDLIB INTEGER, POINTER :: SEA_IPGL(:), SEA_IPGL_TO_PROC(:) +#ifdef W3_PDLIB + INTEGER, POINTER :: SEA_IPGL(:), SEA_IPGL_TO_PROC(:) +#endif LOGICAL, POINTER :: MINIT, FLLSTL, FLLSTR, FLLSTI, & FLDAT0, FLDAT1, FLDAT2 -!/MPI LOGICAL, POINTER :: FBCAST +#ifdef W3_MPI + LOGICAL, POINTER :: FBCAST +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -456,7 +494,9 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NGRIDS USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -469,9 +509,13 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) !/ Local parameters !/ INTEGER :: I, J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMNDAT') +#ifdef W3_S + CALL STRACE (IENT, 'WMNDAT') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -489,17 +533,21 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) BCDUMP(NRGRD), IFLSTI(NRINP), IFLSTL(NRINP), & IFLSTR(NRINP), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -!/MPI ALLOCATE ( NBISTA(NGRIDS), HGHSTA(NGRIDS), EQLSTA(NGRIDS), & -!/MPI STAT=ISTAT ) -!/MPI CHECK_ALLOC_STATUS ( ISTAT ) +#ifdef W3_MPI + ALLOCATE ( NBISTA(NGRIDS), HGHSTA(NGRIDS), EQLSTA(NGRIDS), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif NMDATA = NGRIDS ! ! -------------------------------------------------------------------- / ! 3. Initialize parameters ! -!/MPI NBISTA = 0 -!/MPI HGHSTA = 0 -!/MPI EQLSTA = 0 +#ifdef W3_MPI + NBISTA = 0 + HGHSTA = 0 + EQLSTA = 0 +#endif ! IFLSTI = .FALSE. IFLSTL = .FALSE. @@ -511,15 +559,21 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) MDATAS(I)%FLDAT0 = .FALSE. MDATAS(I)%FLDAT1 = .FALSE. MDATAS(I)%FLDAT2 = .FALSE. -!/MPI MDATAS(I)%MPI_COMM_GRD = -99 -!/MPI MDATAS(I)%MPI_COMM_BCT = -99 +#ifdef W3_MPI + MDATAS(I)%MPI_COMM_GRD = -99 + MDATAS(I)%MPI_COMM_BCT = -99 +#endif DO J=1, NGRIDS BPSTGE(I,J)%VTIME(1) = -1 BPSTGE(I,J)%VTIME(2) = 0 -!/MPI BPSTGE(I,J)%STIME(1) = -1 -!/MPI BPSTGE(I,J)%STIME(2) = 0 +#ifdef W3_MPI + BPSTGE(I,J)%STIME(1) = -1 + BPSTGE(I,J)%STIME(2) = 0 +#endif BPSTGE(I,J)%INIT = .FALSE. -!/MPI BPSTGE(I,J)%NRQBPS = 0 +#ifdef W3_MPI + BPSTGE(I,J)%NRQBPS = 0 +#endif HGSTGE(I,J)%VTIME(1) = -1 HGSTGE(I,J)%VTIME(2) = 0 HGSTGE(I,J)%XTIME(1) = -1 @@ -530,8 +584,10 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) HGSTGE(I,J)%NSND = 0 HGSTGE(I,J)%NSN1 = 0 HGSTGE(I,J)%NSMX = 0 -!/MPI HGSTGE(I,J)%NRQHGS = 0 -!/MPI HGSTGE(I,J)%NRQOUT = 0 +#ifdef W3_MPI + HGSTGE(I,J)%NRQHGS = 0 + HGSTGE(I,J)%NRQOUT = 0 +#endif HGSTGE(I,J)%INIT = .FALSE. EQSTGE(I,J)%VTIME(1) = -1 EQSTGE(I,J)%VTIME(2) = 0 @@ -539,13 +595,17 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) EQSTGE(I,J)%NREC = 0 EQSTGE(I,J)%NSND = 0 EQSTGE(I,J)%NAVMAX = 1 -!/MPI EQSTGE(I,J)%NRQEQS = 0 -!/MPI EQSTGE(I,J)%NRQOUT = 0 +#ifdef W3_MPI + EQSTGE(I,J)%NRQEQS = 0 + EQSTGE(I,J)%NRQOUT = 0 +#endif EQSTGE(I,J)%INIT = .FALSE. END DO END DO ! -!/T WRITE (NDST,9000) NGRIDS +#ifdef W3_T + WRITE (NDST,9000) NGRIDS +#endif ! RETURN ! @@ -555,7 +615,9 @@ SUBROUTINE WMNDAT ( NDSE, NDST ) ' NGRIDS = ',I10/ & ' RUN W3NMOD FIRST'/) ! -!/T 9000 FORMAT (' TEST WMNDAT : SETTING UP FOR ',I4,' GRIDS') +#ifdef W3_T + 9000 FORMAT (' TEST WMNDAT : SETTING UP FOR ',I4,' GRIDS') +#endif !/ !/ End of WMNDAT ----------------------------------------------------- / !/ @@ -627,7 +689,9 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG USE W3ODATMD, ONLY: NAPROC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -641,9 +705,13 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) !/ Local parameters !/ INTEGER :: JGRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMDIMD') +#ifdef W3_S + CALL STRACE (IENT, 'WMDIMD') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -663,7 +731,9 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -699,7 +769,9 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) FLDAT2 = .TRUE. END IF ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays @@ -712,7 +784,9 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) DMV = 0. END IF ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary @@ -730,9 +804,11 @@ SUBROUTINE WMDIMD ( IMOD, NDSE, NDST, J ) ' NMDATA = ',I10/) 1003 FORMAT (/' *** ERROR WMDIMD : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST WMDIMD : MODEL ',I4,' DIM. AT ',2I5,I7) -!/T 9001 FORMAT (' TEST WMDIMD : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST WMDIMD : POINTERS RESET') +#ifdef W3_T + 9000 FORMAT (' TEST WMDIMD : MODEL ',I4,' DIM. AT ',2I5,I7) + 9001 FORMAT (' TEST WMDIMD : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST WMDIMD : POINTERS RESET') +#endif !/ !/ End of WMDIMD ----------------------------------------------------- / !/ @@ -802,7 +878,9 @@ SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG USE W3ODATMD, ONLY: NAPROC USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! @@ -816,9 +894,13 @@ SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) !/ Local parameters !/ INTEGER :: JGRID -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMDIMM') +#ifdef W3_S + CALL STRACE (IENT, 'WMDIMM') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -838,7 +920,9 @@ SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) CALL EXTCDE (3) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! JGRID = IGRID IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) @@ -848,21 +932,27 @@ SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) ! ! ALLOCATE ( MDATAS(IMOD)%... ! -!/T WRITE (NDST,9001) +#ifdef W3_T + WRITE (NDST,9001) +#endif ! ! -------------------------------------------------------------------- / ! 3. Point to allocated arrays ! CALL WMSETM ( IMOD, NDSE, NDST ) ! -!/T WRITE (NDST,9002) +#ifdef W3_T + WRITE (NDST,9002) +#endif ! ! -------------------------------------------------------------------- / ! 4. Update flag ! MINIT = .TRUE. ! -!/T WRITE (NDST,9003) +#ifdef W3_T + WRITE (NDST,9003) +#endif ! ! -------------------------------------------------------------------- / ! 5. Restore previous grid setting if necessary @@ -880,10 +970,12 @@ SUBROUTINE WMDIMM ( IMOD, NDSE, NDST ) ' NMDATA = ',I10/) 1003 FORMAT (/' *** ERROR WMDIMM : ARRAY(S) ALREADY ALLOCATED *** ') ! -!/T 9000 FORMAT (' TEST WMDIMM : MODEL ',I4,' DIM. AT ',2I5,I7) -!/T 9001 FORMAT (' TEST WMDIMM : ARRAYS ALLOCATED') -!/T 9002 FORMAT (' TEST WMDIMM : POINTERS RESET') -!/T 9003 FORMAT (' TEST WMDIMM : FLAGS SET') +#ifdef W3_T + 9000 FORMAT (' TEST WMDIMM : MODEL ',I4,' DIM. AT ',2I5,I7) + 9001 FORMAT (' TEST WMDIMM : ARRAYS ALLOCATED') + 9002 FORMAT (' TEST WMDIMM : POINTERS RESET') + 9003 FORMAT (' TEST WMDIMM : FLAGS SET') +#endif !/ !/ End of WMDIMM ----------------------------------------------------- / !/ @@ -944,7 +1036,9 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -956,9 +1050,13 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMSETM') +#ifdef W3_S + CALL STRACE (IENT, 'WMSETM') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input and module status @@ -973,7 +1071,9 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) CALL EXTCDE (2) END IF ! -!/T WRITE (NDST,9000) IMOD +#ifdef W3_T + WRITE (NDST,9000) IMOD +#endif ! ! -------------------------------------------------------------------- / ! 2. Set model numbers @@ -988,10 +1088,12 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) TMV => MDATAS(IMOD)%TMV AMV => MDATAS(IMOD)%AMV DMV => MDATAS(IMOD)%DMV -!/MPI MPI_COMM_GRD => MDATAS(IMOD)%MPI_COMM_GRD -!/MPI MPI_COMM_BCT => MDATAS(IMOD)%MPI_COMM_BCT -!/MPI CROOT => MDATAS(IMOD)%CROOT -!/MPI FBCAST => MDATAS(IMOD)%FBCAST +#ifdef W3_MPI + MPI_COMM_GRD => MDATAS(IMOD)%MPI_COMM_GRD + MPI_COMM_BCT => MDATAS(IMOD)%MPI_COMM_BCT + CROOT => MDATAS(IMOD)%CROOT + FBCAST => MDATAS(IMOD)%FBCAST +#endif RCLD => MDATAS(IMOD)%RCLD NDT => MDATAS(IMOD)%NDT DATA0 => MDATAS(IMOD)%DATA0 @@ -1005,8 +1107,10 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) FLLSTR => MDATAS(IMOD)%FLLSTR MAPBDI => MDATAS(IMOD)%MAPBDI MAPODI => MDATAS(IMOD)%MAPODI -!/PDLIB SEA_IPGL => MDATAS(IMOD)%SEA_IPGL -!/PDLIB SEA_IPGL_TO_PROC => MDATAS(IMOD)%SEA_IPGL_TO_PROC +#ifdef W3_PDLIB + SEA_IPGL => MDATAS(IMOD)%SEA_IPGL + SEA_IPGL_TO_PROC => MDATAS(IMOD)%SEA_IPGL_TO_PROC +#endif UPTMAP => MDATAS(IMOD)%UPTMAP ! RETURN @@ -1019,7 +1123,9 @@ SUBROUTINE WMSETM ( IMOD, NDSE, NDST ) ' IMOD = ',I10/ & ' NMDATA = ',I10/) ! -!/T 9000 FORMAT (' TEST WMSETM : MODEL ',I4,' SELECTED') +#ifdef W3_T + 9000 FORMAT (' TEST WMSETM : MODEL ',I4,' SELECTED') +#endif !/ !/ End of WMSETM ----------------------------------------------------- / !/ @@ -1074,7 +1180,9 @@ SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) USE CONSTANTS, ONLY: LPDLIB USE W3ODATMD, ONLY: OUTPTS USE W3GDATMD, ONLY: GTYPE, GRIDS, UNGTYPE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ IMPLICIT NONE !/ ------------------------------------------------------------------- / @@ -1087,25 +1195,33 @@ SUBROUTINE INIT_GET_JSEA_ISPROC_GLOB(ISEA, J, JSEA, ISPROC) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC_GLOB') +#ifdef W3_S + CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC_GLOB') +#endif IF (.NOT. LPDLIB) THEN nb=OUTPTS(J)%NAPROC JSEA = 1 + (ISEA-1)/nb ISPROC=1 -!/DIST ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb +#ifdef W3_DIST + ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb +#endif ELSE -!/PDLIB IF (GRIDS(J)%GTYPE .ne. UNGTYPE) THEN -!/PDLIB nb=OUTPTS(J)%NAPROC -!/PDLIB JSEA = 1 + (ISEA-1)/nb -!/PDLIB ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb -!/PDLIB ELSE -!/PDLIB JSEA = MDATAS(J)%SEA_IPGL(ISEA) -!/PDLIB ISPROC = MDATAS(J)%SEA_IPGL_TO_PROC(ISEA) -!/PDLIB ENDIF +#ifdef W3_PDLIB + IF (GRIDS(J)%GTYPE .ne. UNGTYPE) THEN + nb=OUTPTS(J)%NAPROC + JSEA = 1 + (ISEA-1)/nb + ISPROC = MDATAS(J)%CROOT - 1 + ISEA - (JSEA-1)*nb + ELSE + JSEA = MDATAS(J)%SEA_IPGL(ISEA) + ISPROC = MDATAS(J)%SEA_IPGL_TO_PROC(ISEA) + ENDIF +#endif ENDIF !/ !/ End of INIT_GET_JSEA_ISPROC_GLOB ---------------------------------- / diff --git a/model/ftn/wmscrpmd.ftn b/model/src/wmscrpmd.F90 similarity index 95% rename from model/ftn/wmscrpmd.ftn rename to model/src/wmscrpmd.F90 index d96b08195..c31f1cf44 100644 --- a/model/ftn/wmscrpmd.ftn +++ b/model/src/wmscrpmd.F90 @@ -159,15 +159,19 @@ SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & REAL (SCRIP_R8) :: LAT_CONVERSION,OFFSET REAL (SCRIP_R8) :: CONV_DX,CONV_DY,WEIGHT REAL (SCRIP_R8) :: WTSUM -!/T38 CHARACTER (LEN=10) :: CDATE_TIME(3) -!/T38 INTEGER :: DATE_TIME(8) -!/T38 INTEGER :: ELAPSED_TIME, BEG_TIME, & -!/T38 END_TIME +#ifdef W3_T38 + CHARACTER (LEN=10) :: CDATE_TIME(3) + INTEGER :: DATE_TIME(8) + INTEGER :: ELAPSED_TIME, BEG_TIME, & + END_TIME +#endif ! test output for input variables -!/T38 if(l_master)write(*,*)'flagll = ',flagll -!/T38 if(l_master)write(*,*)'gridshift = ',gridshift +#ifdef W3_T38 + if(l_master)write(*,*)'flagll = ',flagll + if(l_master)write(*,*)'gridshift = ',gridshift +#endif ! ! START: universal settings @@ -227,23 +231,25 @@ SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & ENDIF !.....test output -!/T38 write(*,*)'l_master = ',l_master -!/T38 if(l_master)then -!/T38 write(*,*)'conv_dx=', conv_dx -!/T38 write(*,*)'conv_dy=', conv_dy -!/T38 write(*,*)'offset = ',offset -!/T38 write(*,*)'grid1_size=', grid1_size -!/T38 write(*,*)'grid2_size=', grid2_size -!/T38 write(*,*)'l_read = ',l_read -!/T38 write(*,*)'minval(grid1_center_lon) = ',minval(grid1_center_lon) -!/T38 write(*,*)'maxval(grid1_center_lon) = ',maxval(grid1_center_lon) -!/T38 write(*,*)'minval(grid1_center_lat) = ',minval(grid1_center_lat) -!/T38 write(*,*)'maxval(grid1_center_lat) = ',maxval(grid1_center_lat) -!/T38 write(*,*)'minval(grid2_center_lon) = ',minval(grid2_center_lon) -!/T38 write(*,*)'maxval(grid2_center_lon) = ',maxval(grid2_center_lon) -!/T38 write(*,*)'minval(grid2_center_lat) = ',minval(grid2_center_lat) -!/T38 write(*,*)'maxval(grid2_center_lat) = ',maxval(grid2_center_lat) -!/T38 endif +#ifdef W3_T38 + write(*,*)'l_master = ',l_master + if(l_master)then + write(*,*)'conv_dx=', conv_dx + write(*,*)'conv_dy=', conv_dy + write(*,*)'offset = ',offset + write(*,*)'grid1_size=', grid1_size + write(*,*)'grid2_size=', grid2_size + write(*,*)'l_read = ',l_read + write(*,*)'minval(grid1_center_lon) = ',minval(grid1_center_lon) + write(*,*)'maxval(grid1_center_lon) = ',maxval(grid1_center_lon) + write(*,*)'minval(grid1_center_lat) = ',minval(grid1_center_lat) + write(*,*)'maxval(grid1_center_lat) = ',maxval(grid1_center_lat) + write(*,*)'minval(grid2_center_lon) = ',minval(grid2_center_lon) + write(*,*)'maxval(grid2_center_lon) = ',maxval(grid2_center_lon) + write(*,*)'minval(grid2_center_lat) = ',minval(grid2_center_lat) + write(*,*)'maxval(grid2_center_lat) = ',maxval(grid2_center_lat) + endif +#endif CALL SCRIP_INFO_RENORMALIZATION( & & GRID1_CENTER_LON, GRID1_CENTER_LAT, & @@ -262,16 +268,22 @@ SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & WT_LOWEST =ZERO WT_HIGHEST =ONE+1.E-7_SCRIP_R8 -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + beg_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) +#endif CALL SCRIP(ID_SRC, ID_DST, L_MASTER, L_READ, L_TEST) -!/T38 call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) -!/T38 end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) -!/T38 elapsed_time = end_time - beg_time -!/T38 write(0,*) "SCRIP: ", elapsed_time, " MSEC" - -!/T38 if(l_master)write(*,*)'new minval(grid1_center_lon) = ',minval(grid1_center_lon) -!/T38 if(l_master)write(*,*)'new maxval(grid1_center_lon) = ',maxval(grid1_center_lon) +#ifdef W3_T38 + call date_and_time (CDATE_TIME(1), CDATE_TIME(2), CDATE_TIME(3), DATE_TIME) + end_time = ((date_time(5)*60 + date_time(6))*60 +date_time(7))*1000 + date_time(8) + elapsed_time = end_time - beg_time + write(0,*) "SCRIP: ", elapsed_time, " MSEC" +#endif + +#ifdef W3_T38 + if(l_master)write(*,*)'new minval(grid1_center_lon) = ',minval(grid1_center_lon) + if(l_master)write(*,*)'new maxval(grid1_center_lon) = ',maxval(grid1_center_lon) +#endif !.....notes: at this point we have the following useful variables: ! num_wts, e.g. num_wts=3....for first order conservative remapping, @@ -290,20 +302,22 @@ SUBROUTINE SCRIP_WRAPPER (ID_SRC, ID_DST, & !.....note re: notation: I use k for the combined i/j array, similar to isea, ! but not necessarily the same as isea since some points may ! be land etc. -!/T38 if(l_master)then -!/T38 do k=1,grid2_size -!/T38 write(403,*)grid2_frac(k) -!/T38 end do -!/T38 do ilink=1,max_links_map1 -!/T38 write(405,'(999(1x,f20.7))')(wts_map1(iw,ilink),iw=1,num_wts) -!/T38 end do -!/T38 do ilink=1,max_links_map1 -!/T38 write(406,'(i20)')grid1_add_map1(ilink) ! equivalent to -!/T38 ! my "src_address" -!/T38 write(407,'(i20)')grid2_add_map1(ilink) ! equivalent to -!/T38 ! my "dst_address" -!/T38 end do -!/T38 endif +#ifdef W3_T38 + if(l_master)then + do k=1,grid2_size + write(403,*)grid2_frac(k) + end do + do ilink=1,max_links_map1 + write(405,'(999(1x,f20.7))')(wts_map1(iw,ilink),iw=1,num_wts) + end do + do ilink=1,max_links_map1 + write(406,'(i20)')grid1_add_map1(ilink) ! equivalent to + ! my "src_address" + write(407,'(i20)')grid2_add_map1(ilink) ! equivalent to + ! my "dst_address" + end do + endif +#endif !.....organize results and return to wmghgh. diff --git a/model/ftn/wmunitmd.ftn b/model/src/wmunitmd.F90 similarity index 88% rename from model/ftn/wmunitmd.ftn rename to model/src/wmunitmd.F90 index 8cae6e91d..68365256d 100644 --- a/model/ftn/wmunitmd.ftn +++ b/model/src/wmunitmd.F90 @@ -149,7 +149,9 @@ SUBROUTINE WMUINI ( NDSE, NDST ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -162,15 +164,21 @@ SUBROUTINE WMUINI ( NDSE, NDST ) !/ Local parameters !/ INTEGER :: J, I1, IN, I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif CHARACTER(LEN=3) :: STRING !/ -!/S CALL STRACE (IENT, 'WMUINI') +#ifdef W3_S + CALL STRACE (IENT, 'WMUINI') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test parameter settings ! -!/T WRITE (NDST,9000) +#ifdef W3_T + WRITE (NDST,9000) +#endif ! IF ( UNITLW .GE. UNITHG ) THEN WRITE (NDSE,1000) UNITLW, UNITHG @@ -199,7 +207,9 @@ SUBROUTINE WMUINI ( NDSE, NDST ) ! -------------------------------------------------------------------- / ! 1. Allocate and initialize arrays ! -!/T WRITE (NDST,9010) UNITLW, UNITHG +#ifdef W3_T + WRITE (NDST,9010) UNITLW, UNITHG +#endif ! ALLOCATE ( U_USED(UNITLW:UNITHG) , U_TYPE(UNITLW:UNITHG) , & U_NAME(UNITLW:UNITHG) , U_DESC(UNITLW:UNITHG) ) @@ -212,7 +222,9 @@ SUBROUTINE WMUINI ( NDSE, NDST ) ! -------------------------------------------------------------------- / ! 2. Designate file types ! -!/T WRITE (NDST,9020) +#ifdef W3_T + WRITE (NDST,9020) +#endif ! DO J=1, 3 ! @@ -242,17 +254,21 @@ SUBROUTINE WMUINI ( NDSE, NDST ) ! -------------------------------------------------------------------- / ! 3. Set flags ! -!/T WRITE (NDST,9030) +#ifdef W3_T + WRITE (NDST,9030) +#endif ! FLINIT = .TRUE. ! ! -------------------------------------------------------------------- / ! 4. Test output ! -!/T WRITE (NDST,9040) -!/T DO I=UNITLW, UNITHG -!/T WRITE (NDST,9041) I,U_USED(I),U_TYPE(I),U_NAME(I),U_DESC(I) -!/T END DO +#ifdef W3_T + WRITE (NDST,9040) + DO I=UNITLW, UNITHG + WRITE (NDST,9041) I,U_USED(I),U_TYPE(I),U_NAME(I),U_DESC(I) + END DO +#endif ! RETURN ! @@ -268,12 +284,14 @@ SUBROUTINE WMUINI ( NDSE, NDST ) 1020 FORMAT (/' *** WARNING WMUINI: UNIT',I4,' ALREADY ASSIGNED [', & A,'] ***') ! -!/T 9000 FORMAT ( ' TEST WMUNINI: STARTING ROUTINE') -!/T 9010 FORMAT ( ' TEST WMUNINI: ALLOCATING ARRAYS ',2I6) -!/T 9020 FORMAT ( ' TEST WMUNINI: INITALIZING ARRAYS') -!/T 9030 FORMAT ( ' TEST WMUNINI: SETTING FLAGS') -!/T 9040 FORMAT ( ' TEST WMUNINI: DATA STRUCTURE AFTER INITIALIZATION') -!/T 9041 FORMAT ( 5X,I4,L4,3(2X,A)) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUNINI: STARTING ROUTINE') + 9010 FORMAT ( ' TEST WMUNINI: ALLOCATING ARRAYS ',2I6) + 9020 FORMAT ( ' TEST WMUNINI: INITALIZING ARRAYS') + 9030 FORMAT ( ' TEST WMUNINI: SETTING FLAGS') + 9040 FORMAT ( ' TEST WMUNINI: DATA STRUCTURE AFTER INITIALIZATION') + 9041 FORMAT ( 5X,I4,L4,3(2X,A)) +#endif !/ !/ End of WMUINI ----------------------------------------------------- / !/ @@ -332,7 +350,9 @@ SUBROUTINE WMUDMP ( NDS, IREQ ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -345,9 +365,13 @@ SUBROUTINE WMUDMP ( NDS, IREQ ) !/ Local parameters !/ INTEGER :: I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMUDMP') +#ifdef W3_S + CALL STRACE (IENT, 'WMUDMP') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test request and intialization @@ -473,7 +497,9 @@ SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -490,9 +516,13 @@ SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMUSET') +#ifdef W3_S + CALL STRACE (IENT, 'WMUSET') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input @@ -507,8 +537,10 @@ SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) CALL EXTCDE ( 1001 ) END IF ! -!/T WRITE (NDST,9000) NDS, U_USED(NDS), U_TYPE(NDS), & -!/T U_NAME(NDS), U_DESC(NDS) +#ifdef W3_T + WRITE (NDST,9000) NDS, U_USED(NDS), U_TYPE(NDS), & + U_NAME(NDS), U_DESC(NDS) +#endif ! ! -------------------------------------------------------------------- / ! 2. Set data @@ -536,8 +568,10 @@ SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) U_DESC(NDS) = 'unknown' END IF ! -!/T WRITE (NDST,9001) NDS, U_USED(NDS), U_TYPE(NDS), & -!/T U_NAME(NDS), U_DESC(NDS) +#ifdef W3_T + WRITE (NDST,9001) NDS, U_USED(NDS), U_TYPE(NDS), & + U_NAME(NDS), U_DESC(NDS) +#endif ! RETURN ! @@ -547,16 +581,18 @@ SUBROUTINE WMUSET ( NDSE, NDST, NDS, FLAG, TYPE, NAME, DESC ) 1001 FORMAT (/' *** ERROR WMUSET: UNIT NUMBER OUT OF RANGE ***' & /' REQ/RANG :',3I6/) ! -!/T 9000 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE ENTRY :'/ & -!/T ' FLAG : ',L4/ & -!/T ' TYPE : ',A/ & -!/T ' NAME : ',A/ & -!/T ' DESC : ' A) -!/T 9001 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE EXIT :'/ & -!/T ' FLAG : ',L4/ & -!/T ' TYPE : ',A/ & -!/T ' NAME : ',A/ & -!/T ' DESC : ' A) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE ENTRY :'/ & + ' FLAG : ',L4/ & + ' TYPE : ',A/ & + ' NAME : ',A/ & + ' DESC : ' A) + 9001 FORMAT ( ' TEST WMUSET: UNIT ',I4', ON SUBROUTINE EXIT :'/ & + ' FLAG : ',L4/ & + ' TYPE : ',A/ & + ' NAME : ',A/ & + ' DESC : ' A) +#endif !/ !/ End of WMUSET ----------------------------------------------------- / !/ @@ -620,7 +656,9 @@ SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -636,11 +674,15 @@ SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) !/ Local parameters !/ INTEGER :: NRC, I, J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: OK LOGICAL :: OPND !/ -!/S CALL STRACE (IENT, 'WMUGET') +#ifdef W3_S + CALL STRACE (IENT, 'WMUGET') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input / output @@ -656,7 +698,9 @@ SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) NRC = 1 END IF ! -!/T WRITE (NDST,9010) TYPE, NRC +#ifdef W3_T + WRITE (NDST,9010) TYPE, NRC +#endif ! ! -------------------------------------------------------------------- / ! 2. Find first free unit number and reset flag @@ -693,7 +737,9 @@ SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) CALL EXTCDE ( 1020 ) END IF ! -!/T WRITE (NDST,9020) NDS +#ifdef W3_T + WRITE (NDST,9020) NDS +#endif ! RETURN ! @@ -703,9 +749,11 @@ SUBROUTINE WMUGET ( NDSE, NDST, NDS, TYPE, NR ) 1020 FORMAT (/' *** ERROR WMUGET: CANNOT FIND FREE UNIT FOR TYPE ', & A,' ***'/) ! -!/T 9010 FORMAT ( ' TEST WMUGET: LOOKING FOR UNIT FOR TYPE ',A,' [', & -!/T I2,']') -!/T 9020 FORMAT ( ' TEST WMUGET: UNIT NUMBER SET TO',I4) +#ifdef W3_T + 9010 FORMAT ( ' TEST WMUGET: LOOKING FOR UNIT FOR TYPE ',A,' [', & + I2,']') + 9020 FORMAT ( ' TEST WMUGET: UNIT NUMBER SET TO',I4) +#endif !/ !/ End of WMUGET ----------------------------------------------------- / !/ @@ -764,7 +812,9 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE !/ @@ -776,10 +826,14 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: CHECK !/ -!/S CALL STRACE (IENT, 'WMUINQ') +#ifdef W3_S + CALL STRACE (IENT, 'WMUINQ') +#endif ! ! -------------------------------------------------------------------- / ! 1. Test input / output @@ -794,7 +848,9 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) CALL EXTCDE ( 1011 ) END IF ! -!/T WRITE (NDST,9010) NDS +#ifdef W3_T + WRITE (NDST,9010) NDS +#endif ! ! -------------------------------------------------------------------- / ! 2. Check out file @@ -802,7 +858,9 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) ! INQUIRE (NDS,OPENED=CHECK) ! -!/T WRITE (NDST,9020) CHECK +#ifdef W3_T + WRITE (NDST,9020) CHECK +#endif ! ! 2.b File not opened, release to pool ! @@ -814,7 +872,9 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) ! INQUIRE (NDS,NAME=U_NAME(NDS)) ! -!/T WRITE (NDST,9021) U_NAME(NDS) +#ifdef W3_T + WRITE (NDST,9021) U_NAME(NDS) +#endif ! END IF ! @@ -829,9 +889,11 @@ SUBROUTINE WMUINQ ( NDSE, NDST, NDS ) 1011 FORMAT (/' *** ERROR WMUINQ: UNIT NUMBER OUT OF RANGE ***' & /' REQ/RANG :',3I6/) ! -!/T 9010 FORMAT ( ' TEST WMUINQ: TESTING UNIT NUMBER',I4) -!/T 9020 FORMAT ( ' INQUIRE ON OPENED : ',L2) -!/T 9021 FORMAT ( ' NAME OF FILE : ',A) +#ifdef W3_T + 9010 FORMAT ( ' TEST WMUINQ: TESTING UNIT NUMBER',I4) + 9020 FORMAT ( ' INQUIRE ON OPENED : ',L2) + 9021 FORMAT ( ' NAME OF FILE : ',A) +#endif !/ !/ End of WMUINQ ----------------------------------------------------- / !/ diff --git a/model/ftn/wmupdtmd.ftn b/model/src/wmupdtmd.F90 similarity index 87% rename from model/ftn/wmupdtmd.ftn rename to model/src/wmupdtmd.F90 index ecc1d7542..f849174f7 100644 --- a/model/ftn/wmupdtmd.ftn +++ b/model/src/wmupdtmd.F90 @@ -158,7 +158,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) USE W3IDATMD, ONLY: W3SETI USE WMMDATMD, ONLY: WMSETM USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 !/ USE W3GDATMD, ONLY: NX, NY, FILEXT @@ -185,7 +187,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) !/ Local parameters !/ INTEGER :: MDSEN, J, DTIME(2), IERR, NDTNEW, JJ -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTTST LOGICAL :: FIRST CHARACTER(LEN=13) :: IDFLDS(-7:10) @@ -206,8 +210,12 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! 0. Initialization ! 0.a Subroutine tracing and echo of input ! -!/S CALL STRACE (IENT, 'WMUPDT') -!/T WRITE (MDST,9000) IMOD, TDATA +#ifdef W3_S + CALL STRACE (IENT, 'WMUPDT') +#endif +#ifdef W3_T + WRITE (MDST,9000) IMOD, TDATA +#endif ! IF ( IMPROC .EQ. NMPERR ) THEN MDSEN = MDSE @@ -234,26 +242,28 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) WRITE (MDSS,900) IMOD, DTME21 END IF ! -!/T WRITE (MDST,9001) ' J', '0-N', TIME, ETIME -!/T IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9002) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 -!/T IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9002) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 -!/T IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9002) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 -!/T IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9002) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 -!/T IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9002) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 -!/T IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9002) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN -!/T IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9002) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN -!/T IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9002) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN -!/T WRITE (MDST,9002) 1, IDINP(IMOD,1), INFLAGS1(1), TLN -!/T WRITE (MDST,9003) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN -!/T WRITE (MDST,9003) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN -!/T WRITE (MDST,9002) 4, IDINP(IMOD,4), INFLAGS1(4), TIN -!/T WRITE (MDST,9003) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN -!/T WRITE (MDST,9003) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN -!/T WRITE (MDST,9002) 7, IDINP(IMOD,7), INFLAGS1(7), T0N -!/T WRITE (MDST,9002) 8, IDINP(IMOD,8), INFLAGS1(8), T1N -!/T WRITE (MDST,9002) 9, IDINP(IMOD,9), INFLAGS1(9), T2N -!/T WRITE (MDST,9003) 10, 'MOV' , INFLAGS1(10), TG0, TGN -!/T WRITE (MDST,9004) 'GRD', NX, NY +#ifdef W3_T + WRITE (MDST,9001) ' J', '0-N', TIME, ETIME + IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9002) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 + IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9002) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 + IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9002) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 + IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9002) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 + IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9002) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 + IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9002) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN + IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9002) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN + IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9002) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN + WRITE (MDST,9002) 1, IDINP(IMOD,1), INFLAGS1(1), TLN + WRITE (MDST,9003) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN + WRITE (MDST,9003) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN + WRITE (MDST,9002) 4, IDINP(IMOD,4), INFLAGS1(4), TIN + WRITE (MDST,9003) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN + WRITE (MDST,9003) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN + WRITE (MDST,9002) 7, IDINP(IMOD,7), INFLAGS1(7), T0N + WRITE (MDST,9002) 8, IDINP(IMOD,8), INFLAGS1(8), T1N + WRITE (MDST,9002) 9, IDINP(IMOD,9), INFLAGS1(9), T2N + WRITE (MDST,9003) 10, 'MOV' , INFLAGS1(10), TG0, TGN + WRITE (MDST,9004) 'GRD', NX, NY +#endif ! ! 1. Loop over input types ------------------------------------------ / ! @@ -263,7 +273,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! IF ( .NOT. INFLAGS1(J) ) CYCLE ! -!/T WRITE (MDST,9010) J, INFLAGS1(J), INPMAP(IMOD,J) +#ifdef W3_T + WRITE (MDST,9010) J, INFLAGS1(J), INPMAP(IMOD,J) +#endif ! ! 1.b Test time ! @@ -275,7 +287,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) DTTST = DSEC21 ( TIME , TFN(:,J) ) END IF ! -!/T WRITE (MDST,9011) IDINP(IMOD,J), DTTST, TFN(:,J) +#ifdef W3_T + WRITE (MDST,9011) IDINP(IMOD,J), DTTST, TFN(:,J) +#endif ! IF ( DTTST .GT. 0. ) CYCLE IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & @@ -285,7 +299,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! IF ( INPMAP(IMOD,J) .EQ. 0 ) THEN ! -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! CALL WMUPD1 ( IMOD, IDINP(IMOD,J), J, IERR ) ! @@ -293,7 +309,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! ELSE IF ( INPMAP(IMOD,J) .GT. 0 ) THEN ! -!/T WRITE (MDST,9030) INPMAP(IMOD,J) +#ifdef W3_T + WRITE (MDST,9030) INPMAP(IMOD,J) +#endif ! ! 3.a Check if input grid is available ! @@ -317,7 +335,9 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) IF ( J .EQ. 4 ) FLLSTI = IFLSTI(-JJ) IF ( J .EQ. 6 ) FLLSTR = IFLSTR(-JJ) ! -!/T WRITE (MDST,9031) J, IDINP(JJ,J), DTTST, TFN(:,J) +#ifdef W3_T + WRITE (MDST,9031) J, IDINP(JJ,J), DTTST, TFN(:,J) +#endif ! ! 3.b If needed, update input grid ! Note: flags in WMMDATMD set for grid IMOD ! @@ -348,13 +368,15 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! Data input and time stamp settings for forcing input from ! CPL are handled in wmesmfmd.ftn:GetImport ! -!/T IF ( INPMAP(IMOD,J) .EQ. -999 ) THEN -!/T ! *** Forcing input from CPL & defined on native grid *** -!/T WRITE (MDST,9040) -!/T ELSE -!/T ! *** Forcing input from CPL & defined on an input grid *** -!/T WRITE (MDST,9050) -INPMAP(IMOD,J) -!/T END IF +#ifdef W3_T + IF ( INPMAP(IMOD,J) .EQ. -999 ) THEN + ! *** Forcing input from CPL & defined on native grid *** + WRITE (MDST,9040) + ELSE + ! *** Forcing input from CPL & defined on an input grid *** + WRITE (MDST,9050) -INPMAP(IMOD,J) + END IF +#endif ! END IF ! @@ -396,25 +418,27 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) ! ! 7. Final test output ---------------------------------------------- / ! -!/T WRITE (MDST,9070) ' J', '0-N', TIME, ETIME, TDATA -!/T IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9071) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 -!/T IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9071) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 -!/T IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9071) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 -!/T IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9071) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 -!/T IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9071) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 -!/T IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9071) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN -!/T IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9071) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN -!/T IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9071) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN -!/T WRITE (MDST,9071) 1, IDINP(IMOD,1), INFLAGS1(1), TLN -!/T WRITE (MDST,9072) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN -!/T WRITE (MDST,9072) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN -!/T WRITE (MDST,9071) 4, IDINP(IMOD,4), INFLAGS1(4), TIN -!/T WRITE (MDST,9072) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN -!/T WRITE (MDST,9072) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN -!/T WRITE (MDST,9071) 7, IDINP(IMOD,7), INFLAGS1(7), T0N -!/T WRITE (MDST,9071) 8, IDINP(IMOD,8), INFLAGS1(8), T1N -!/T WRITE (MDST,9073) 9, IDINP(IMOD,9), INFLAGS1(9), T2N, TDN -!/T WRITE (MDST,9072) 10, 'MOV' , INFLAGS1(10), TG0, TGN +#ifdef W3_T + WRITE (MDST,9070) ' J', '0-N', TIME, ETIME, TDATA + IF (LBOUND(IDINP,2).LE.-7) WRITE (MDST,9071) -7, IDINP(IMOD,-7), INFLAGS1(-7), TI1 + IF (LBOUND(IDINP,2).LE.-6) WRITE (MDST,9071) -6, IDINP(IMOD,-6), INFLAGS1(-6), TI2 + IF (LBOUND(IDINP,2).LE.-5) WRITE (MDST,9071) -5, IDINP(IMOD,-5), INFLAGS1(-5), TI3 + IF (LBOUND(IDINP,2).LE.-4) WRITE (MDST,9071) -4, IDINP(IMOD,-4), INFLAGS1(-4), TI4 + IF (LBOUND(IDINP,2).LE.-3) WRITE (MDST,9071) -3, IDINP(IMOD,-3), INFLAGS1(-3), TI5 + IF (LBOUND(IDINP,2).LE.-2) WRITE (MDST,9071) -2, IDINP(IMOD,-2), INFLAGS1(-2), TZN + IF (LBOUND(IDINP,2).LE.-1) WRITE (MDST,9071) -1, IDINP(IMOD,-1), INFLAGS1(-1), TTN + IF (LBOUND(IDINP,2).LE. 0) WRITE (MDST,9071) 0, IDINP(IMOD, 0), INFLAGS1( 0), TVN + WRITE (MDST,9071) 1, IDINP(IMOD,1), INFLAGS1(1), TLN + WRITE (MDST,9072) 2, IDINP(IMOD,2), INFLAGS1(2), TC0, TCN + WRITE (MDST,9072) 3, IDINP(IMOD,3), INFLAGS1(3), TW0, TWN + WRITE (MDST,9071) 4, IDINP(IMOD,4), INFLAGS1(4), TIN + WRITE (MDST,9072) 5, IDINP(IMOD,5), INFLAGS1(5), TU0, TUN + WRITE (MDST,9072) 6, IDINP(IMOD,6), INFLAGS1(6), TR0, TRN + WRITE (MDST,9071) 7, IDINP(IMOD,7), INFLAGS1(7), T0N + WRITE (MDST,9071) 8, IDINP(IMOD,8), INFLAGS1(8), T1N + WRITE (MDST,9073) 9, IDINP(IMOD,9), INFLAGS1(9), T2N, TDN + WRITE (MDST,9072) 10, 'MOV' , INFLAGS1(10), TG0, TGN +#endif ! RETURN ! @@ -431,24 +455,26 @@ SUBROUTINE WMUPDT ( IMOD ,TDATA ) 930 FORMAT ( ' First updating ',A) 950 FORMAT ( ' Past last ',A) ! -!/T 9000 FORMAT ( ' TEST WMUPDT : INPUT : ',I4,I10.8,I7.6, & -!/T ' <============================') -!/T 9001 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 2(I10.8,I7.6)) -!/T 9002 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) -!/T 9003 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) -!/T 9004 FORMAT ( ' ',2X,1X,A3,3X,2I10 ) -!/T 9010 FORMAT ( ' TEST WMUPDT : J, FLAG, INPMAP : ',I2,L2,I4) -!/T 9011 FORMAT ( ' TEST WMUPDT : ',A,', DTTST = ',E10.3,2X,I9.8,I7.6) -!/T 9020 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON THE NATIVE GRID') -!/T 9030 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON INPUT GRID',I4) -!/T 9031 FORMAT ( ' TEST WMUPDT : J =',I4,3XA,', DTTST = ', & -!/T E10.3,2X,I9.8,I7.6) -!/T 9040 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON THE NATIVE GRID') -!/T 9050 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON INPUT GRID',I4) -!/T 9070 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 3(I10.8,I7.6)) -!/T 9071 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) -!/T 9072 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) -!/T 9073 FORMAT ( ' ',I2,1X,A3,L3,17X,2(I10.8,I7.6)) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUPDT : INPUT : ',I4,I10.8,I7.6, & + ' <============================') + 9001 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 2(I10.8,I7.6)) + 9002 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) + 9003 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) + 9004 FORMAT ( ' ',2X,1X,A3,3X,2I10 ) + 9010 FORMAT ( ' TEST WMUPDT : J, FLAG, INPMAP : ',I2,L2,I4) + 9011 FORMAT ( ' TEST WMUPDT : ',A,', DTTST = ',E10.3,2X,I9.8,I7.6) + 9020 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON THE NATIVE GRID') + 9030 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM FILE & DEFINED ON INPUT GRID',I4) + 9031 FORMAT ( ' TEST WMUPDT : J =',I4,3XA,', DTTST = ', & + E10.3,2X,I9.8,I7.6) + 9040 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON THE NATIVE GRID') + 9050 FORMAT ( ' TEST WMUPDT : FORCING INPUT FROM CPL & DEFINED ON INPUT GRID',I4) + 9070 FORMAT ( ' TEST WMUPDT : ',A2,1X,A3,3X, 3(I10.8,I7.6)) + 9071 FORMAT ( ' ',I2,1X,A3,L3,17X,1(I10.8,I7.6)) + 9072 FORMAT ( ' ',I2,1X,A3,L3, 2(I10.8,I7.6)) + 9073 FORMAT ( ' ',I2,1X,A3,L3,17X,2(I10.8,I7.6)) +#endif !/ !/ End of WMUPDT ----------------------------------------------------- / !/ @@ -523,10 +549,14 @@ SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) !/ USE WMMDATMD, ONLY: WMDIMD USE W3FLDSMD, ONLY: W3FLDG, W3FLDD, W3FLDM -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: NX, NY -!/SMC USE W3GDATMD, ONLY: FSWND, NSEA +#ifdef W3_SMC + USE W3GDATMD, ONLY: FSWND, NSEA +#endif USE W3WDATMD, ONLY: TIME USE W3IDATMD, ONLY: TLN, WLEV, TC0, TCN, CX0, CXN, CY0, CYN, & TW0, TWN, TU0, TUN, TR0, TRN, WX0, WXN, & @@ -554,14 +584,20 @@ SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) !/ INTEGER :: MDSEN, DTIME(2), NDTNEW REAL :: XXX(NY,NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / ! 0. Initialization ! 0.a Subroutine tracing and echo of input ! -!/S CALL STRACE (IENT, 'WMUPD1') -!/T WRITE (MDST,9000) IMOD, J +#ifdef W3_S + CALL STRACE (IENT, 'WMUPD1') +#endif +#ifdef W3_T + WRITE (MDST,9000) IMOD, J +#endif ! IF ( IMPROC .EQ. NMPERR ) THEN MDSEN = MDSE @@ -640,30 +676,38 @@ SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) ! 2. Currents ------------------------------------------------------- / ! CASE (2) -!/SMC !!Li For sea point current option FSWND. JGLi08Feb2021 -!/SMC IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & -!/SMC NSEA, 1, NSEA, 1, TIME, ETIME, TC0, & -!/SMC CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea point current option FSWND. JGLi08Feb2021 + IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NSEA, 1, NSEA, 1, TIME, ETIME, TC0, & + CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + ELSE +#endif CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & NX, NY, NX, NY, TIME, ETIME, TC0, & CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) -!/SMC END IF +#ifdef W3_SMC + END IF +#endif ! ! 3. Winds ---------------------------------------------------------- / ! CASE (3) -!/SMC !!Li For sea point wind option FSWND. JGLi08Feb2021 -!/SMC IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & -!/SMC NSEA, 1, NSEA, 1, TIME, ETIME, TW0, & -!/SMC WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) -!/SMC ELSE +#ifdef W3_SMC + !!Li For sea point wind option FSWND. JGLi08Feb2021 + IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & + NSEA, 1, NSEA, 1, TIME, ETIME, TW0, & + WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + ELSE +#endif CALL W3FLDG ('READ', IDSTR, MDSF(IMOD,J), MDST, MDSEN, & NX, NY, NX, NY, TIME, ETIME, TW0, & WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) -!/SMC END IF +#ifdef W3_SMC + END IF +#endif ! ! 4. Ice ------------------------------------------------------------ / ! @@ -770,7 +814,9 @@ SUBROUTINE WMUPD1 ( IMOD, IDSTR, J, IERR ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMUPD1 : INPUT : ',2I4) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUPD1 : INPUT : ',2I4) +#endif !/ !/ End of WMUPD1 ----------------------------------------------------- / !/ @@ -850,7 +896,9 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) !/ ------------------------------------------------------------------- / !/ USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3WDATMD, ONLY: TIME USE W3IDATMD, ONLY: INPUTS @@ -870,28 +918,52 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) !/ Local parameters !/ INTEGER :: ICONSC, ICONSW, ICONSU -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / ! 0. Initialization ! 0.a Subroutine tracing and echo of input ! -!/S CALL STRACE (IENT, 'WMUPD2') +#ifdef W3_S + CALL STRACE (IENT, 'WMUPD2') +#endif ! -!/T WRITE (MDST,9000) IMOD, J, JMOD -!/T WRITE (MDST,9001) INPUTS(IMOD)%TFN(:,J), & -!/T INPUTS(JMOD)%TFN(:,J), ETIME +#ifdef W3_T + WRITE (MDST,9000) IMOD, J, JMOD + WRITE (MDST,9001) INPUTS(IMOD)%TFN(:,J), & + INPUTS(JMOD)%TFN(:,J), ETIME +#endif ! IERR = 0 -!/CRX0 ICONSC = 0 -!/CRX1 ICONSC = 1 -!/CRX2 ICONSC = 2 -!/WNX0 ICONSW = 0 -!/WNX1 ICONSW = 1 -!/WNX2 ICONSW = 2 -!/WNX0 ICONSU = 0 -!/WNX1 ICONSU = 1 -!/WNX2 ICONSU = 2 +#ifdef W3_CRX0 + ICONSC = 0 +#endif +#ifdef W3_CRX1 + ICONSC = 1 +#endif +#ifdef W3_CRX2 + ICONSC = 2 +#endif +#ifdef W3_WNX0 + ICONSW = 0 +#endif +#ifdef W3_WNX1 + ICONSW = 1 +#endif +#ifdef W3_WNX2 + ICONSW = 2 +#endif +#ifdef W3_WNX0 + ICONSU = 0 +#endif +#ifdef W3_WNX1 + ICONSU = 1 +#endif +#ifdef W3_WNX2 + ICONSU = 2 +#endif ! ! 1. Shift fields ( currents and winds only ) ------------------------ / ! @@ -904,9 +976,11 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) INPUTS(IMOD)%TC0(:) = INPUTS(IMOD)%TFN(:,J) INPUTS(IMOD)%CX0 = INPUTS(IMOD)%CXN INPUTS(IMOD)%CY0 = INPUTS(IMOD)%CYN -!/T WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) -!/T ELSE -!/T WRITE (MDST,9011) J +#ifdef W3_T + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J +#endif END IF ! ! 1.b Winds @@ -917,9 +991,11 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) INPUTS(IMOD)%WX0 = INPUTS(IMOD)%WXN INPUTS(IMOD)%WY0 = INPUTS(IMOD)%WYN INPUTS(IMOD)%DT0 = INPUTS(IMOD)%DTN -!/T WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) -!/T ELSE -!/T WRITE (MDST,9011) J +#ifdef W3_T + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J +#endif END IF ! ! 1.c Momentum @@ -929,16 +1005,20 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) INPUTS(IMOD)%TU0(:) = INPUTS(IMOD)%TFN(:,J) INPUTS(IMOD)%UX0 = INPUTS(IMOD)%UXN INPUTS(IMOD)%UY0 = INPUTS(IMOD)%UYN -!/T WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) -!/T ELSE -!/T WRITE (MDST,9011) J +#ifdef W3_T + WRITE (MDST,9010) J, INPUTS(IMOD)%TFN(:,J) + ELSE + WRITE (MDST,9011) J +#endif END IF ! END SELECT ! ! 2. Process fields at ending time ----------------------------------- / ! -!/T WRITE (MDST,9020) J, INPUTS(JMOD)%TFN(:,J) +#ifdef W3_T + WRITE (MDST,9020) J, INPUTS(JMOD)%TFN(:,J) +#endif INPUTS(IMOD)%TFN(:,J) = INPUTS(JMOD)%TFN(:,J) ! SELECT CASE (J) @@ -1064,10 +1144,18 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) CASE (2) IF ( INPUTS(IMOD)%TC0(1) .LT. 0 ) THEN INPUTS(IMOD)%TC0(:) = INPUTS(JMOD)%TC0(:) -!/T WRITE (MDST,9030) J, INPUTS(IMOD)%TC0(:) -!/CRX0 ICONSC = 0 -!/CRX1 ICONSC = 1 -!/CRX2 ICONSC = 2 +#ifdef W3_T + WRITE (MDST,9030) J, INPUTS(IMOD)%TC0(:) +#endif +#ifdef W3_CRX0 + ICONSC = 0 +#endif +#ifdef W3_CRX1 + ICONSC = 1 +#endif +#ifdef W3_CRX2 + ICONSC = 2 +#endif CALL WMUPDV ( IMOD, INPUTS(IMOD)%CX0, INPUTS(IMOD)%CY0, & JMOD, INPUTS(JMOD)%CX0, INPUTS(JMOD)%CY0, & 0., ICONSC ) @@ -1078,10 +1166,18 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) CASE (3) IF ( INPUTS(IMOD)%TW0(1) .LT. 0 ) THEN INPUTS(IMOD)%TW0(:) = INPUTS(JMOD)%TW0(:) -!/T WRITE (MDST,9030) J, INPUTS(IMOD)%TW0(:) -!/WNX0 ICONSW = 0 -!/WNX1 ICONSW = 1 -!/WNX2 ICONSW = 2 +#ifdef W3_T + WRITE (MDST,9030) J, INPUTS(IMOD)%TW0(:) +#endif +#ifdef W3_WNX0 + ICONSW = 0 +#endif +#ifdef W3_WNX1 + ICONSW = 1 +#endif +#ifdef W3_WNX2 + ICONSW = 2 +#endif CALL WMUPDV ( IMOD, INPUTS(IMOD)%WX0, INPUTS(IMOD)%WY0, & JMOD, INPUTS(JMOD)%WX0, INPUTS(JMOD)%WY0, & 0., ICONSW ) @@ -1095,10 +1191,18 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) CASE (5) IF ( INPUTS(IMOD)%TU0(1) .LT. 0 ) THEN INPUTS(IMOD)%TU0(:) = INPUTS(JMOD)%TU0(:) -!/T WRITE (MDST,9030) J, INPUTS(IMOD)%TU0(:) -!/WNX0 ICONSU = 0 -!/WNX1 ICONSU = 1 -!/WNX2 ICONSU = 2 +#ifdef W3_T + WRITE (MDST,9030) J, INPUTS(IMOD)%TU0(:) +#endif +#ifdef W3_WNX0 + ICONSU = 0 +#endif +#ifdef W3_WNX1 + ICONSU = 1 +#endif +#ifdef W3_WNX2 + ICONSU = 2 +#endif CALL WMUPDV ( IMOD, INPUTS(IMOD)%UX0, INPUTS(IMOD)%UY0, & JMOD, INPUTS(JMOD)%UX0, INPUTS(JMOD)%UY0, & 0., ICONSU ) @@ -1121,15 +1225,17 @@ SUBROUTINE WMUPD2 ( IMOD, J, JMOD, IERR ) ! 1999 FORMAT (/' *** ERROR WMUPD2: OPTION NOT YET IMPLEMENTED ***'/) ! -!/T 9000 FORMAT ( ' TEST WMUPD2 : INPUT : ',3I4) -!/T 9001 FORMAT ( ' TEST WMUPD2 : TIME OF IMOD : ',I9.8,1X,I6.6/ & -!/T ' TIME OF JMOD : ',I9.8,1X,I6.6/ & -!/T ' ENDING TIME : ',I9.8,1X,I6.6) -!/T 9010 FORMAT ( ' TEST WMUPD2 : SHIFTING ',I1,' TIME = ',I8.8,I7.6) -!/T 9011 FORMAT ( ' TEST WMUPD2 : NO DATA FOR ',I1,' TO SHIFT') -!/T 9020 FORMAT ( ' TEST WMUPD2 : PROCESSING ',I1,' TIME = ',I8.8,I7.6) -!/T 9030 FORMAT ( ' TEST WMUPD2 : INITIAL FIELD FOR ',I1, & -!/T ' TIME = ',I8.8,I7.6) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUPD2 : INPUT : ',3I4) + 9001 FORMAT ( ' TEST WMUPD2 : TIME OF IMOD : ',I9.8,1X,I6.6/ & + ' TIME OF JMOD : ',I9.8,1X,I6.6/ & + ' ENDING TIME : ',I9.8,1X,I6.6) + 9010 FORMAT ( ' TEST WMUPD2 : SHIFTING ',I1,' TIME = ',I8.8,I7.6) + 9011 FORMAT ( ' TEST WMUPD2 : NO DATA FOR ',I1,' TO SHIFT') + 9020 FORMAT ( ' TEST WMUPD2 : PROCESSING ',I1,' TIME = ',I8.8,I7.6) + 9030 FORMAT ( ' TEST WMUPD2 : INITIAL FIELD FOR ',I1, & + ' TIME = ',I8.8,I7.6) +#endif !/ !/ End of WMUPD2 ----------------------------------------------------- / !/ @@ -1216,7 +1322,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) !/ ------------------------------------------------------------------- / !/ USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & @@ -1245,7 +1353,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) JX, JY INTEGER :: NPOIX, NPOIY, I, IFIELDS,CURVI !RP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & XSR, YFL, YFR, YSL, YSR @@ -1270,13 +1380,17 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) INTEGER, POINTER :: ICLOSE REAL, ALLOCATABLE :: XGRTMP(:),YGRTMP(:) -!/T1 CHARACTER(LEN=17) :: FORMAT1 +#ifdef W3_T1 + CHARACTER(LEN=17) :: FORMAT1 +#endif !/ !/ ------------------------------------------------------------------- / ! 0. Initialization ! 0.a Subroutine tracing and test output ! -!/S CALL STRACE (IENT, 'WMUPDV') +#ifdef W3_S + CALL STRACE (IENT, 'WMUPDV') +#endif ! IF ( GRIDS(IMOD)%GTYPE .EQ. UNGTYPE .OR. & GRIDS(JMOD)%GTYPE .EQ. UNGTYPE ) THEN @@ -1304,8 +1418,10 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) END IF ! -!/T WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & -!/T JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#ifdef W3_T + WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & + JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#endif ! ! 0.b Initialize fields ! @@ -1350,8 +1466,10 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) IYS0 = MAX ( 1 , 1+IYO ) IYSN = IYS0 + IYFN - IYF0 ! -!/T WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & -!/T IXS0, IXSN, IYS0, IYSN +#ifdef W3_T + WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & + IXS0, IXSN, IYS0, IYSN +#endif ! ! 1.b Fill arrays for sea points only ! @@ -1408,7 +1526,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) ALLOCATE (XGRTMP(NXI),YGRTMP(NYI)) XGRTMP=XGRDI(1,:) YGRTMP=YGRDI(:,1) -!/OMPH!$OMP PARALLEL DO PRIVATE(J,I,LONC,LATC,VALUEX,VALUEY) +#ifdef W3_OMPH +!$OMP PARALLEL DO PRIVATE(J,I,LONC,LATC,VALUEX,VALUEY) +#endif DO J=1,NY DO I=1,NX LONC=XGRDC(J,I) !LON FOR EVERY CURVL GRID POINT @@ -1421,7 +1541,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) END DO !END I END DO !END J -!/OMPH/!$OMP END PARALLEL DO +#ifdef W3_OMPH +!$OMP END PARALLEL DO +#endif DEALLOCATE (XGRTMP, YGRTMP) ELSE @@ -1436,9 +1558,13 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) MXA = 2 + INT(SX/SXI) END IF ! -!/T WRITE (MDST,9020) 'X' -!/T1 WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" -!/T1 WRITE (MDST,9021) NX, MXA +#ifdef W3_T + WRITE (MDST,9020) 'X' +#endif +#ifdef W3_T1 + WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" + WRITE (MDST,9021) NX, MXA +#endif ! ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) NXA = 0 @@ -1531,10 +1657,12 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) ! END IF ! -!/T1 DO, IX=1, NX -!/T1 IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & -!/T1 IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) -!/T1 END DO +#ifdef W3_T1 + DO, IX=1, NX + IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) + END DO +#endif ! ! 2.b.2 Interpolation / averaging data for Y axis ! @@ -1544,10 +1672,14 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) MYA = 2 + INT(SY/SYI) END IF ! -!/T WRITE (MDST,9020) 'Y' -!/T1 FORMAT1 = '(10X, I5, F6.2)' -!/T1 WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" -!/T1 WRITE (MDST,9021) NY, MYA +#ifdef W3_T + WRITE (MDST,9020) 'Y' +#endif +#ifdef W3_T1 + FORMAT1 = '(10X, I5, F6.2)' + WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" + WRITE (MDST,9021) NY, MYA +#endif ! ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) NYA = 0 @@ -1614,10 +1746,12 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) END IF ! -!/T1 DO, IY=1, NY -!/T1 IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & -!/T1 IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) -!/T1 END DO +#ifdef W3_T1 + DO, IY=1, NY + IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) + END DO +#endif ! ! 2.c Process grid ! @@ -1676,7 +1810,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) ! ! 2.d Reconcile mask differences ! -!/T WRITE (MDST,9022) +#ifdef W3_T + WRITE (MDST,9022) +#endif ! JJ = 0 ICLOSE => GRIDS(IMOD)%ICLOSE @@ -1686,7 +1822,9 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) FLAGUP = .FALSE. MAP3 = .FALSE. JJ = JJ + 1 -!/T WRITE (MDST,9023) JJ +#ifdef W3_T + WRITE (MDST,9023) JJ +#endif DO IX=1, NX DO IY=1, NY IF ( MAP1(IX,IY) ) THEN @@ -1749,17 +1887,23 @@ SUBROUTINE WMUPDV ( IMOD, VX, VY, JMOD, VXI, VYI, UNDEF, CONSTP ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMUPDV : GRID INFORMATION : '/ & -!/T ' ',3I5,4E11.3/ & -!/T ' ',3I5,4E11.3/ & -!/T ' UNDEFINED = ',E10.3) -!/T 9010 FORMAT ( ' TEST WMUPDV : COINCIDING GRIDS, OFFSETS :',2I6/ & -!/T ' TARGET GRID RANGES :',4I6/ & -!/T ' SOURCE GRID RANGES :',4I6) -!/T 9020 FORMAT ( ' TEST WMUPDV : WEIGHTS FOR ',A,' INTERPOATION') -!/T1 9021 FORMAT ( ' TEST WMUPDV : ARAY DIMENSIONED AS : ',2I6) -!/T 9022 FORMAT ( ' TEST WMUPDV : RECONCILING MASKS') -!/T 9023 FORMAT ( ' SWEEP NR ',I4) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUPDV : GRID INFORMATION : '/ & + ' ',3I5,4E11.3/ & + ' ',3I5,4E11.3/ & + ' UNDEFINED = ',E10.3) + 9010 FORMAT ( ' TEST WMUPDV : COINCIDING GRIDS, OFFSETS :',2I6/ & + ' TARGET GRID RANGES :',4I6/ & + ' SOURCE GRID RANGES :',4I6) + 9020 FORMAT ( ' TEST WMUPDV : WEIGHTS FOR ',A,' INTERPOATION') +#endif +#ifdef W3_T1 + 9021 FORMAT ( ' TEST WMUPDV : ARAY DIMENSIONED AS : ',2I6) +#endif +#ifdef W3_T + 9022 FORMAT ( ' TEST WMUPDV : RECONCILING MASKS') + 9023 FORMAT ( ' SWEEP NR ',I4) +#endif !/ !/ End of WMUPDV ----------------------------------------------------- / !/ @@ -1843,7 +1987,9 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) !/ ------------------------------------------------------------------- / !/ USE W3SERVMD, ONLY: EXTCDE -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif !/ USE W3GDATMD, ONLY: NX, NY, X0, Y0, SX, SY, GRIDS, FLAGLL, & GTYPE, RLGTYPE, CLGTYPE, UNGTYPE, & @@ -1872,7 +2018,9 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) INTEGER :: NPOIX, NPOIY, I, CURVI !RP -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, ALLOCATABLE :: NXA(:,:), NYA(:,:) REAL :: XR, YR, R1, R2, RT, XFL, XFR, XSL, & XSR, YFL, YFR, YSL, YSR @@ -1894,13 +2042,17 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) REAL, POINTER :: X0I, Y0I, SXI, SYI !RPXXX , HPFACI, HQFACI INTEGER, POINTER :: ICLOSE -!/T1 CHARACTER(LEN=17) :: FORMAT1 +#ifdef W3_T1 + CHARACTER(LEN=17) :: FORMAT1 +#endif !/ !/ ------------------------------------------------------------------- / ! 0. Initialization ! 0.a Subroutine tracing and test output ! -!/S CALL STRACE (IENT, 'WMUPDS') +#ifdef W3_S + CALL STRACE (IENT, 'WMUPDS') +#endif ! NXI => GRIDS(JMOD)%NX NYI => GRIDS(JMOD)%NY @@ -1920,8 +2072,10 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) CALL EXTCDE ( 1 ) END IF ! -!/T WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & -!/T JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#ifdef W3_T + WRITE (MDST,9000) IMOD, NX, NY, X0, Y0, SX, SY, & + JMOD, NXI, NYI, X0I, Y0I, SXI, SYI, UNDEF +#endif ! ! 0.b Initialize fields ! @@ -1964,8 +2118,10 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) IYS0 = MAX ( 1 , 1+IYO ) IYSN = IYS0 + IYFN - IYF0 ! -!/T WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & -!/T IXS0, IXSN, IYS0, IYSN +#ifdef W3_T + WRITE (MDST,9010) IXO, IYO, IXF0, IXFN, IYF0, IYFN, & + IXS0, IXSN, IYS0, IYSN +#endif ! ! 1.b Fill arrays for sea points only ! @@ -2046,10 +2202,14 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) MXA = 2 + INT(SX/SXI) END IF ! -!/T WRITE (MDST,9020) 'X' -!/T1 FORMAT1 = '(10X, I5, F6.2)' -!/T1 WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" -!/T1 WRITE (MDST,9021) NX, MXA +#ifdef W3_T + WRITE (MDST,9020) 'X' +#endif +#ifdef W3_T1 + FORMAT1 = '(10X, I5, F6.2)' + WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MXA+1,'I5,',MXA+1,"F6.2)'" + WRITE (MDST,9021) NX, MXA +#endif ! ALLOCATE ( NXA(NX,0:MXA) , RXA(NX,MXA) ) NXA = 0 @@ -2142,10 +2302,12 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) ! END IF ! -!/T1 DO, IX=1, NX -!/T1 IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & -!/T1 IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) -!/T1 END DO +#ifdef W3_T1 + DO, IX=1, NX + IF ( NXA(IX,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IX, NXA(IX,1:MXA), RXA(IX,1:MXA), SUM(RXA(IX,1:MXA)) + END DO +#endif ! ! 2.b.2 Interpolation / averaging data for Y axis ! @@ -2155,9 +2317,13 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) MYA = 2 + INT(SY/SYI) END IF ! -!/T WRITE (MDST,9020) 'Y' -!/T1 WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" -!/T1 WRITE (MDST,9021) NY, MYA +#ifdef W3_T + WRITE (MDST,9020) 'Y' +#endif +#ifdef W3_T1 + WRITE (FORMAT1,'(A,I2,A,I2,A)') "'(10X,",MYA+1,'I5,',MYA+1,"F6.2)'" + WRITE (MDST,9021) NY, MYA +#endif ! ALLOCATE ( NYA(NY,0:MYA) , RYA(NY,MYA) ) NYA = 0 @@ -2224,10 +2390,12 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) ! END IF ! -!/T1 DO, IY=1, NY -!/T1 IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & -!/T1 IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) -!/T1 END DO +#ifdef W3_T1 + DO, IY=1, NY + IF ( NYA(IY,0) .GT. 0 ) WRITE (MDST,FORMAT1) & + IY, NYA(IY,1:MYA), RYA(IY,1:MYA), SUM(RYA(IY,1:MYA)) + END DO +#endif ! ! 2.c Process grid ! @@ -2265,7 +2433,9 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) ! ! 2.d Reconcile mask differences ! -!/T WRITE (MDST,9022) +#ifdef W3_T + WRITE (MDST,9022) +#endif ! JJ = 0 ICLOSE => GRIDS(IMOD)%ICLOSE @@ -2275,7 +2445,9 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) FLAGUP = .FALSE. MAP3 = .FALSE. JJ = JJ + 1 -!/T WRITE (MDST,9023) JJ +#ifdef W3_T + WRITE (MDST,9023) JJ +#endif DO IX=1, NX DO IY=1, NY IF ( MAP1(IX,IY) ) THEN @@ -2333,17 +2505,23 @@ SUBROUTINE WMUPDS ( IMOD, FD, JMOD, FDI, UNDEF ) ! ! Formats ! -!/T 9000 FORMAT ( ' TEST WMUPDS : GRID INFORMATION : '/ & -!/T ' ',3I5,4E11.3/ & -!/T ' ',3I5,4E11.3/ & -!/T ' UNDEFINED = ',E10.3) -!/T 9010 FORMAT ( ' TEST WMUPDS : COINCIDING GRIDS, OFFSETS :',2I6/ & -!/T ' TARGET GRID RANGES :',4I6/ & -!/T ' SOURCE GRID RANGES :',4I6) -!/T 9020 FORMAT ( ' TEST WMUPDS : WEIGHTS FOR ',A,' INTERPOATION') -!/T1 9021 FORMAT ( ' TEST WMUPDS : ARAY DIMENSIONED AS : ',2I6) -!/T 9022 FORMAT ( ' TEST WMUPDS : RECONCILING MASKS') -!/T 9023 FORMAT ( ' SWEEP NR ',I4) +#ifdef W3_T + 9000 FORMAT ( ' TEST WMUPDS : GRID INFORMATION : '/ & + ' ',3I5,4E11.3/ & + ' ',3I5,4E11.3/ & + ' UNDEFINED = ',E10.3) + 9010 FORMAT ( ' TEST WMUPDS : COINCIDING GRIDS, OFFSETS :',2I6/ & + ' TARGET GRID RANGES :',4I6/ & + ' SOURCE GRID RANGES :',4I6) + 9020 FORMAT ( ' TEST WMUPDS : WEIGHTS FOR ',A,' INTERPOATION') +#endif +#ifdef W3_T1 + 9021 FORMAT ( ' TEST WMUPDS : ARAY DIMENSIONED AS : ',2I6) +#endif +#ifdef W3_T + 9022 FORMAT ( ' TEST WMUPDS : RECONCILING MASKS') + 9023 FORMAT ( ' SWEEP NR ',I4) +#endif !/ !/ End of WMUPDS ----------------------------------------------------- / !/ diff --git a/model/ftn/wmwavemd.ftn b/model/src/wmwavemd.F90 similarity index 66% rename from model/ftn/wmwavemd.ftn rename to model/src/wmwavemd.F90 index 794fcd030..3c33878d7 100644 --- a/model/ftn/wmwavemd.ftn +++ b/model/src/wmwavemd.F90 @@ -197,8 +197,12 @@ SUBROUTINE WMWAVE ( TEND ) USE W3IOPOMD, ONLY: W3IOPE USE W3WAVEMD, ONLY: W3WAVE USE W3SERVMD, ONLY: EXTCDE, WWTIME -!/S USE W3SERVMD, ONLY: STRACE -!/MPRF USE W3TIMEMD, ONLY: PRTIME +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif +#ifdef W3_MPRF + USE W3TIMEMD, ONLY: PRTIME +#endif USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 USE WMMDATMD, ONLY: WMSETM USE WMUPDTMD, ONLY: WMUPDT @@ -210,7 +214,9 @@ SUBROUTINE WMWAVE ( TEND ) USE W3WDATMD, ONLY: TIME, VA USE W3ODATMD, ONLY: FLOUT, TONEXT, DTOUT, TOLAST, IAPROC, & NAPPNT, NOPTS, UNIPTS -!/MPI USE W3ODATMD, ONLY: NRQPO, IRQPO1 +#ifdef W3_MPI + USE W3ODATMD, ONLY: NRQPO, IRQPO1 +#endif USE W3IDATMD, ONLY: INFLAGS1 USE WMMDATMD, ONLY: MDSO, MDSS, MDST, MDSE, IMPROC, & NMPROC, NMPSCR, NMPERR, NMPTST, NMPLOG, & @@ -219,13 +225,19 @@ SUBROUTINE WMWAVE ( TEND ) GRDLOW, TSYNC, TMAX, TOUTP, TDATA, GRSTAT, & FLLSTL, FLLSTI, FLLSTR, DTRES, FLGHG1, & FLGHG2, MAPMSK -!/MPI USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & -!/MPI MPI_COMM_BCT, CROOT, FBCAST -!/MPRF USE WMMDATMD, ONLY: MDSP +#ifdef W3_MPI + USE WMMDATMD, ONLY: MPI_COMM_MWAVE, MPI_COMM_GRD, & + MPI_COMM_BCT, CROOT, FBCAST +#endif +#ifdef W3_MPRF + USE WMMDATMD, ONLY: MDSP +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -238,29 +250,47 @@ SUBROUTINE WMWAVE ( TEND ) INTEGER :: J, JJ, I, JO, TPRNT(2), TAUX(2), & II, JJJ, IX, IY, UPNEXT(2), UPLAST(2) INTEGER :: DUMMY2(35)=0 -!/T INTEGER :: ILOOP -!/S INTEGER, SAVE :: IENT = 0 -!/MPI INTEGER :: IERR_MPI, NMPSCS -!/MPI INTEGER, ALLOCATABLE :: STATUS(:,:) +#ifdef W3_T + INTEGER :: ILOOP +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + INTEGER :: IERR_MPI, NMPSCS + INTEGER, ALLOCATABLE :: STATUS(:,:) +#endif REAL :: DTTST, DTMAXI -!/MPRF REAL :: PRFT0, PRFTN, PRFTS -!/MPRF REAL(KIND=8) :: get_memory +#ifdef W3_MPRF + REAL :: PRFT0, PRFTN, PRFTS + REAL(KIND=8) :: get_memory +#endif CHARACTER(LEN=8) :: WTIME CHARACTER(LEN=23) :: MTIME LOGICAL :: DONE, TSTAMP, FLAGOK, DO_UPT, & FLG_O1, FLG_O2 -!/MPI LOGICAL :: FLAG +#ifdef W3_MPI + LOGICAL :: FLAG +#endif LOGICAL, ALLOCATABLE :: FLSYNC(:), GRSYNC(:), TMSYNC(:), & FLEQOK(:) -!/MPI LOGICAL, ALLOCATABLE :: PREGTB(:), PREGTH(:), PREGTE(:) +#ifdef W3_MPI + LOGICAL, ALLOCATABLE :: PREGTB(:), PREGTH(:), PREGTE(:) +#endif !/ !/ ------------------------------------------------------------------- / ! -!/S CALL STRACE (IENT, 'WMWAVE') +#ifdef W3_S + CALL STRACE (IENT, 'WMWAVE') +#endif ! -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,900) +#endif ! ! 0. Initializations ------------------------------------------------ / ! 0.a Initial testing @@ -295,14 +325,18 @@ SUBROUTINE WMWAVE ( TEND ) IF ( .NOT. ALLOCATED(FLSYNC) ) THEN ALLOCATE ( FLSYNC(NRGRD), GRSYNC(NRGRP), TMSYNC(NRGRD), & FLEQOK(NRGRD) ) -!/MPI ALLOCATE ( PREGTB(NRGRD), PREGTH(NRGRD), PREGTE(NRGRD) ) +#ifdef W3_MPI + ALLOCATE ( PREGTB(NRGRD), PREGTH(NRGRD), PREGTE(NRGRD) ) +#endif FLSYNC = .FALSE. GRSYNC = .FALSE. TMSYNC = .TRUE. FLEQOK = .FALSE. -!/MPI PREGTB = .FALSE. -!/MPI PREGTH = .FALSE. -!/MPI PREGTE = .FALSE. +#ifdef W3_MPI + PREGTB = .FALSE. + PREGTH = .FALSE. + PREGTE = .FALSE. +#endif END IF ! ! 0.b Reset GRSTAT as needed @@ -316,7 +350,9 @@ SUBROUTINE WMWAVE ( TEND ) ! 0.c Other initializations ! DTRES = 0. -!/MPI NMPSCS = NMPSCR +#ifdef W3_MPI + NMPSCS = NMPSCR +#endif ! IF ( UNIPTS ) THEN CALL W3SETO ( 0, MDSE, MDST ) @@ -340,14 +376,20 @@ SUBROUTINE WMWAVE ( TEND ) TSTAMP = .TRUE. ENDIF ! -!/MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) +#endif ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,990) PRFT0, PRFTN, get_memory() +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,990) PRFT0, PRFTN, get_memory() +#endif ! ! 1. Setting up loop structure -------------------------------------- / ! -!/T ILOOP = 0 +#ifdef W3_T + ILOOP = 0 +#endif ! LOOP_OUTER: DO ! @@ -364,46 +406,58 @@ SUBROUTINE WMWAVE ( TEND ) TSTAMP = .TRUE. ENDIF ! -!/T ILOOP = ILOOP + 1 -!/T WRITE (MDST,9000) ILOOP, TSYNC(:,0) -!/T DO I=1, NRGRD -!/T CALL W3SETW ( I, MDSE, MDST ) -!/T WRITE (MDST,9001) I, GRSTAT(I), TIME, TSYNC(:,I), TEND(:,I) -!/T END DO -!/T IF ( ILOOP .EQ. -1 ) CALL EXTCDE ( 508 ) +#ifdef W3_T + ILOOP = ILOOP + 1 + WRITE (MDST,9000) ILOOP, TSYNC(:,0) + DO I=1, NRGRD + CALL W3SETW ( I, MDSE, MDST ) + WRITE (MDST,9001) I, GRSTAT(I), TIME, TSYNC(:,I), TEND(:,I) + END DO + IF ( ILOOP .EQ. -1 ) CALL EXTCDE ( 508 ) +#endif ! DONE = .FALSE. TPRNT = TSYNC(:,0) ! LOOP_J: DO J=1, NRGRP ! -!/MPI GRSYNC(J) = .FALSE. -!/MPI DO JJ=1, INGRP(J,0) -!/MPI I = INGRP(J,JJ) -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI GRSYNC(J) = GRSYNC(J) .OR. FBCAST -!/MPI END DO +#ifdef W3_MPI + GRSYNC(J) = .FALSE. + DO JJ=1, INGRP(J,0) + I = INGRP(J,JJ) + CALL WMSETM ( I, MDSE, MDST ) + GRSYNC(J) = GRSYNC(J) .OR. FBCAST + END DO +#endif ! LOOP_JJ: DO JJ=1, INGRP(J,0) I = INGRP(J,JJ) CALL WMSETM ( I, MDSE, MDST ) ! -!/MPI IF ( GRSTAT(I).EQ.0 ) TMSYNC(I) = .NOT. FBCAST -!/MPI IF ( FBCAST ) THEN -!/MPI NMPSCR = CROOT -!/MPI ELSE -!/MPI NMPSCR = NMPSCS -!/MPI END IF +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.0 ) TMSYNC(I) = .NOT. FBCAST + IF ( FBCAST ) THEN + NMPSCR = CROOT + ELSE + NMPSCR = NMPSCS + END IF +#endif ! ! 2. Update input fields -------------------------------------------- / ! ( GRSTAT = 0 ) ! ! 2.a Check TDATA and finish step if data is still OK ! -!/SHRD IF ( GRSTAT(I) .EQ. 0 ) THEN -!/MPI IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) ) THEN +#ifdef W3_SHRD + IF ( GRSTAT(I) .EQ. 0 ) THEN +#endif +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) ) THEN +#endif ! -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif ! IF ( TDATA(1,I) .EQ. -1 ) THEN DTTST = 0. @@ -411,11 +465,15 @@ SUBROUTINE WMWAVE ( TEND ) CALL W3SETW ( I, MDSE, MDST ) DTTST = DSEC21 ( TIME , TDATA(:,I) ) END IF -!/T WRITE (MDST,9020) DTTST +#ifdef W3_T + WRITE (MDST,9020) DTTST +#endif ! IF ( DTTST .GT. 0. ) THEN GRSTAT(I) = 1 -!/T WRITE (MDST,9003) I, GRSTAT(I) +#ifdef W3_T + WRITE (MDST,9003) I, GRSTAT(I) +#endif DONE = .TRUE. END IF ! @@ -423,63 +481,103 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 2.b Update input and TDATA ! -!/SHRD IF ( GRSTAT(I) .EQ. 0 ) THEN -!/MPI IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. & -!/MPI MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -! -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_SHRD + IF ( GRSTAT(I) .EQ. 0 ) THEN +#endif +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#endif +! +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif IF ( DTTST .LE. 0 ) THEN IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & WRITE (MDSS,*) TSTAMP = .FALSE. CALL WMUPDT ( I, TDATA(:,I) ) -!/T WRITE (MDST,9021) TIME, TDATA(:,I), TEND(:,I) +#ifdef W3_T + WRITE (MDST,9021) TIME, TDATA(:,I), TEND(:,I) +#endif END IF ! ! 2.c Finish up if possible ( !/SHRD or .NOT. FBCAST or no update ) ! -!/SHRD GRSTAT(I) = 1 -!/SHRD DONE = .TRUE. -! -!/MPI IF ( .NOT. GRSYNC(J) ) THEN -!/MPIT WRITE (MDST,9902) I, GRSTAT(I), & -!/MPIT 'NO SYNC FOR TDATA NEEDED' -!/MPI GRSTAT(I) = 1 -!/MPI DONE = .TRUE. -!/MPI END IF +#ifdef W3_SHRD + GRSTAT(I) = 1 + DONE = .TRUE. +#endif +! +#ifdef W3_MPI + IF ( .NOT. GRSYNC(J) ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9902) I, GRSTAT(I), & + 'NO SYNC FOR TDATA NEEDED' +#endif +#ifdef W3_MPI + GRSTAT(I) = 1 + DONE = .TRUE. + END IF +#endif ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & -!/MPRF 'ST00', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST00', I +#endif ! END IF ! ! 2.d Synchronize in parts ( !/MPI ) ! -!/MPI IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) ) THEN -!/MPI DONE = .TRUE. -! -!/MPI IF ( FLSYNC(I) ) THEN -!/MPIT WRITE (MDST,9902) I, GRSTAT(I), & -!/MPIT 'SYNCING TDATA' -!/MPRF IF (FLSYNC(I)) CALL PRTIME ( PRFT0 ) -!/MPI IF ( FBCAST ) CALL WMBCST & -!/MPI ( TDATA(1,I), 2, I, NRGRD, 1 ) -!/MPRF IF (FLSYNC(I)) CALL PRTIME ( PRFTN ) -!/MPRF IF (FLSYNC(I)) WRITE (MDSP,991) & -!/MPRF PRFT0, PRFTN, get_memory(), 'BCST',I -!/MPIT WRITE (MDST,9902) I, GRSTAT(I), 'SYNCING DONE' -!/MPI GRSTAT(I) = 1 -!/MPI FLSYNC(I) = .FALSE. -!/MPI IF ( GRSYNC(J) ) CYCLE LOOP_JJ -!/MPI ELSE -!/MPIT WRITE (MDST,9902) I, GRSTAT(I), & -!/MPIT 'CYCLE BEFORE SYNCING TDATA' -!/MPI FLSYNC(I) = .TRUE. -!/MPI CYCLE LOOP_JJ -!/MPI END IF -! -!/MPI END IF +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) ) THEN + DONE = .TRUE. +#endif +! +#ifdef W3_MPI + IF ( FLSYNC(I) ) THEN +#endif +#ifdef W3_MPIT + WRITE (MDST,9902) I, GRSTAT(I), & + 'SYNCING TDATA' +#endif +#ifdef W3_MPRF + IF (FLSYNC(I)) CALL PRTIME ( PRFT0 ) +#endif +#ifdef W3_MPI + IF ( FBCAST ) CALL WMBCST & + ( TDATA(1,I), 2, I, NRGRD, 1 ) +#endif +#ifdef W3_MPRF + IF (FLSYNC(I)) CALL PRTIME ( PRFTN ) + IF (FLSYNC(I)) WRITE (MDSP,991) & + PRFT0, PRFTN, get_memory(), 'BCST',I +#endif +#ifdef W3_MPIT + WRITE (MDST,9902) I, GRSTAT(I), 'SYNCING DONE' +#endif +#ifdef W3_MPI + GRSTAT(I) = 1 + FLSYNC(I) = .FALSE. + IF ( GRSYNC(J) ) CYCLE LOOP_JJ + ELSE +#endif +#ifdef W3_MPIT + WRITE (MDST,9902) I, GRSTAT(I), & + 'CYCLE BEFORE SYNCING TDATA' +#endif +#ifdef W3_MPI + FLSYNC(I) = .TRUE. + CYCLE LOOP_JJ + END IF +#endif +! +#ifdef W3_MPI + END IF +#endif ! ! 3. Update data from lower ranked grids ---------------------------- / ! ( GRSTAT = 1 ) @@ -487,12 +585,16 @@ SUBROUTINE WMWAVE ( TEND ) ! 3.a Skip for initial output only ! IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) THEN -!/T WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' +#endif CALL W3SETW ( I, MDSE, MDST ) DTTST = DSEC21 ( TIME, TSYNC(:,I) ) IF ( DTTST .EQ. 0. ) THEN GRSTAT(I) = 7 -!/T WRITE (MDST,9003) I, GRSTAT(I) +#ifdef W3_T + WRITE (MDST,9003) I, GRSTAT(I) +#endif DONE = .TRUE. END IF END IF @@ -501,8 +603,12 @@ SUBROUTINE WMWAVE ( TEND ) ! IF ( GRSTAT(I) .EQ. 1 ) THEN -!/T WRITE (MDST,9002) I, GRSTAT(I), 'SECOND PART' -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), 'SECOND PART' +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! ! 3.b.1 Test if data is there ! @@ -516,36 +622,50 @@ SUBROUTINE WMWAVE ( TEND ) END DO CALL W3SETW ( I, MDSE, MDST ) ! -!/T WRITE (MDST,9004) FLAGOK +#ifdef W3_T + WRITE (MDST,9004) FLAGOK +#endif ! ! 3.b.1 Get the data ! -!/MPI IF ( .NOT.FLAGOK .AND. .NOT.PREGTB(I) ) THEN -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOBG (I,FLAG) -!/MPI PREGTB(I) = .TRUE. -!/MPI END IF +#ifdef W3_MPI + IF ( .NOT.FLAGOK .AND. .NOT.PREGTB(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOBG (I,FLAG) + PREGTB(I) = .TRUE. + END IF +#endif ! IF ( FLAGOK ) THEN -!/SHRD CALL WMIOBG ( I, FLAGOK ) -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOBG ( I ) -!/MPI PREGTB(I) = .FALSE. +#ifdef W3_SHRD + CALL WMIOBG ( I, FLAGOK ) +#endif +#ifdef W3_MPI + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOBG ( I ) + PREGTB(I) = .FALSE. +#endif GRSTAT(I) = 2 DONE = .TRUE. END IF ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & -!/MPRF 'ST01', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST01', I +#endif END IF ! ! 4. Update model time step ----------------------------------------- / ! ( GRSTAT = 2 ) ! IF ( GRSTAT(I) .EQ. 2 ) THEN -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! ! 4.a Check TMAX and update as necessary ( needs !/MPI synchronizaion ) ! @@ -577,17 +697,23 @@ SUBROUTINE WMWAVE ( TEND ) IF ( DSEC21(UPNEXT,TMAX(:,I)) .GT. 0 ) & TMAX(:,I) = UPNEXT(:) END IF -!/T WRITE (MDST,9040) TMAX(:,I), DTRES(I), TAUX, & -!/T TDATA(:,I), TOUTP(:,I), UPNEXT +#ifdef W3_T + WRITE (MDST,9040) TMAX(:,I), DTRES(I), TAUX, & + TDATA(:,I), TOUTP(:,I), UPNEXT +#endif DONE = .TRUE. CYCLE LOOP_JJ -!/T ELSE -!/T WRITE (MDST,9041) TMAX(:,I) +#ifdef W3_T + ELSE + WRITE (MDST,9041) TMAX(:,I) +#endif END IF ! ! 4.b Lowest ranked grids, minimum of all TMAXes ! -!/T WRITE (MDST,9042) GRANK(I) +#ifdef W3_T + WRITE (MDST,9042) GRANK(I) +#endif ! IF ( GRANK(I) .EQ. 1 ) THEN ! @@ -598,9 +724,13 @@ SUBROUTINE WMWAVE ( TEND ) ! DO II=1, NRGRD CALL W3SETW ( II, MDSE, MDST ) -!/SHRD IF ( TIME(1) .NE. -1 ) THEN -!/MPI IF ( TIME(1).NE.-1 .AND. & -!/MPI MPI_COMM_GRD.NE.MPI_COMM_NULL ) THEN +#ifdef W3_SHRD + IF ( TIME(1) .NE. -1 ) THEN +#endif +#ifdef W3_MPI + IF ( TIME(1).NE.-1 .AND. & + MPI_COMM_GRD.NE.MPI_COMM_NULL ) THEN +#endif IF ( DSEC21(TIME,TSYNC(:,0)) .NE. 0 ) THEN FLAGOK = .FALSE. EXIT @@ -635,28 +765,38 @@ SUBROUTINE WMWAVE ( TEND ) IF ( GRANK(II) .EQ. 1 ) THEN TSYNC(:,II) = TAUX IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 -!/T IF ( GRSTAT(II) .EQ. 3 ) & -!/T WRITE (MDST,9003) II, GRSTAT(II) +#ifdef W3_T + IF ( GRSTAT(II) .EQ. 3 ) & + WRITE (MDST,9003) II, GRSTAT(II) +#endif END IF END DO DONE = .TRUE. -!/MPRF CALL PRTIME ( PRFTS ) -!/MPRF WRITE (MDSP,992) PRFTS, PRFTS, & -!/MPRF get_memory(), 'TIME', TSYNC(:,0) +#ifdef W3_MPRF + CALL PRTIME ( PRFTS ) + WRITE (MDSP,992) PRFTS, PRFTS, & + get_memory(), 'TIME', TSYNC(:,0) +#endif ! ! 4.b.4 Output ! -!/T WRITE (MDST,9043) TSYNC(:,0) -!/T WRITE (MDST,9045) -!/T WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) +#ifdef W3_T + WRITE (MDST,9043) TSYNC(:,0) + WRITE (MDST,9045) + WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) +#endif ! ! 4.b.5 Skip computations so that all grids start processing ! simultaneously. ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'ST02', I -!/T IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST02', I +#endif +#ifdef W3_T + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 ! END IF @@ -711,23 +851,31 @@ SUBROUTINE WMWAVE ( TEND ) II = INGRP(J,JJJ) TSYNC(:,II) = TAUX IF ( GRSTAT(II) .EQ. 2 ) GRSTAT(II) = 3 -!/T IF ( GRSTAT(II) .EQ. 3 ) & -!/T WRITE (MDST,9003) II, GRSTAT(II) +#ifdef W3_T + IF ( GRSTAT(II) .EQ. 3 ) & + WRITE (MDST,9003) II, GRSTAT(II) +#endif END DO DONE = .TRUE. ! -!/T WRITE (MDST,9044) TSYNC(:,I), TAUX -!/T WRITE (MDST,9045) -!/T WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) +#ifdef W3_T + WRITE (MDST,9044) TSYNC(:,I), TAUX + WRITE (MDST,9045) + WRITE (MDST,9046) (II,TSYNC(:,II),II=0,NRGRD) +#endif ! ! 4.c.6 Skip computations so that all grids in group are advanced ! simultaneously. -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'ST02', I -!/T IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST02', I +#endif +#ifdef W3_T + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 ! END IF @@ -741,19 +889,27 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 5.a Run model ! -!/SHRD IF ( GRSTAT(I) .EQ. 3 ) THEN +#ifdef W3_SHRD + IF ( GRSTAT(I) .EQ. 3 ) THEN +#endif ! -!/MPI IF ( GRSTAT(I).EQ.3 .AND. & -!/MPI MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN -!/MPI CALL W3SETW ( I, MDSE, MDST ) -!/MPI TIME = TSYNC(:,I) -!/MPI GRSTAT(I) = 4 -!/MPI DONE = .TRUE. -!/MPI ELSE IF ( GRSTAT(I).EQ.3 .AND. & -!/MPI MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.3 .AND. & + MPI_COMM_GRD .EQ. MPI_COMM_NULL ) THEN + CALL W3SETW ( I, MDSE, MDST ) + TIME = TSYNC(:,I) + GRSTAT(I) = 4 + DONE = .TRUE. + ELSE IF ( GRSTAT(I).EQ.3 .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#endif ! -!/T WRITE (MDST,9002) I, GRSTAT(I), 'RUNNING MODEL' -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), 'RUNNING MODEL' +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! CALL WMSETM ( I, MDSE, MDST ) CALL W3WAVE ( I, DUMMY2, TSYNC(:,I), .FALSE., .TRUE. ) @@ -763,7 +919,9 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 5.b Stage data for grids with equal rank ! -!/MPI CALL WMIOEF ( I ) +#ifdef W3_MPI + CALL WMIOEF ( I ) +#endif CALL WMIOES ( I ) ! ! 5.c Finish up @@ -771,9 +929,11 @@ SUBROUTINE WMWAVE ( TEND ) GRSTAT(I) = 4 DONE = .TRUE. ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & -!/MPRF 'ST03', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST03', I +#endif ! END IF ! @@ -782,7 +942,9 @@ SUBROUTINE WMWAVE ( TEND ) ! ( GRSTAT = 4 ) ! IF ( GRSTAT(I) .EQ. 4 ) THEN -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! ! 6.a Test against times and statuses of dependent grids ! Note: This is done per GROUP, not per local equal grid dependence @@ -790,8 +952,10 @@ SUBROUTINE WMWAVE ( TEND ) ! equal (4.c.1) and that all equal grid dependences are a ! subset of groups (WMGEQL 5.d) ! -!/T WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' -!/T WRITE (MDST,9005) FLEQOK(I) +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), 'FIRST PART' + WRITE (MDST,9005) FLEQOK(I) +#endif ! ! 6.a.1 Check if sync point is reached ! @@ -806,22 +970,30 @@ SUBROUTINE WMWAVE ( TEND ) .AND. GRSTAT(INGRP(J,JJJ)).EQ.4 END DO CALL W3SETW ( I, MDSE, MDST ) -!/T WRITE (MDST,9004) FLAGOK +#ifdef W3_T + WRITE (MDST,9004) FLAGOK +#endif ! ! 6.a.2 Point reached, set flag for all in group and cycle ! IF ( FLAGOK ) THEN DO JJJ=1, INGRP(J,0) FLEQOK(INGRP(J,JJJ)) = .TRUE. -!/T WRITE (MDST,9061) INGRP(J,JJJ), & -!/T FLEQOK(INGRP(J,JJJ)) +#ifdef W3_T + WRITE (MDST,9061) INGRP(J,JJJ), & + FLEQOK(INGRP(J,JJJ)) +#endif END DO DONE = .TRUE. -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'ST04', I -! -!/T IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I +#endif +! +#ifdef W3_T + IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) +#endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 END IF ! @@ -829,17 +1001,23 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 6.b Call gathering routine, reset FLEQOK and cycle ! -!/MPI IF ( .NOT.FLEQOK(I) .AND. .NOT.PREGTE(I) ) THEN -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOEG (I,FLAG) -!/MPI PREGTE(I) = .TRUE. -!/MPI END IF +#ifdef W3_MPI + IF ( .NOT.FLEQOK(I) .AND. .NOT.PREGTE(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOEG (I,FLAG) + PREGTE(I) = .TRUE. + END IF +#endif ! IF ( FLEQOK(I) ) THEN -!/SHRD CALL WMIOEG ( I ) -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOEG ( I ) -!/MPI PREGTE(I) = .FALSE. +#ifdef W3_SHRD + CALL WMIOEG ( I ) +#endif +#ifdef W3_MPI + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOEG ( I ) + PREGTE(I) = .FALSE. +#endif GRSTAT(I) = 5 FLEQOK(I) = .FALSE. DONE = .TRUE. @@ -849,25 +1027,35 @@ SUBROUTINE WMWAVE ( TEND ) ! IF ( GRSTAT(I) .EQ. 5 ) THEN ! -!/T WRITE (MDST,9002) I, GRSTAT(I)-1, 'SECOND PART' +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I)-1, 'SECOND PART' +#endif ! -!/SHRD CALL WMIOBS ( I ) +#ifdef W3_SHRD + CALL WMIOBS ( I ) +#endif ! -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -!/MPI CALL WMIOBF ( I ) -!/MPI CALL WMIOBS ( I ) -!/MPI END IF +#ifdef W3_MPI + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOBF ( I ) + CALL WMIOBS ( I ) + END IF +#endif ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'ST04', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I +#endif CYCLE LOOP_JJ ! END IF ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'ST04', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'ST04', I +#endif ! END IF ! @@ -880,8 +1068,12 @@ SUBROUTINE WMWAVE ( TEND ) ! in mww3_test_04) ! IF ( GRSTAT(I) .EQ. 5 ) THEN -!/MPRF CALL PRTIME ( PRFT0 ) -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif ! ! 7.a Test against times and statuses of dependent grids ! @@ -902,21 +1094,29 @@ SUBROUTINE WMWAVE ( TEND ) END DO CALL W3SETW ( I, MDSE, MDST ) ! -!/T WRITE (MDST,9004) FLAGOK +#ifdef W3_T + WRITE (MDST,9004) FLAGOK +#endif ! ! 7.b Call gathering routine ! -!/MPI IF ( .NOT.FLAGOK .AND. .NOT.PREGTH(I) ) THEN -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOHG ( I, FLAG ) -!/MPI PREGTH(I) = .TRUE. -!/MPI END IF +#ifdef W3_MPI + IF ( .NOT.FLAGOK .AND. .NOT.PREGTH(I) ) THEN + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOHG ( I, FLAG ) + PREGTH(I) = .TRUE. + END IF +#endif ! IF ( FLAGOK ) THEN -!/SHRD CALL WMIOHG ( I, FLAGOK ) -!/MPI IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & -!/MPI CALL WMIOHG ( I ) -!/MPI PREGTH(I) = .FALSE. +#ifdef W3_SHRD + CALL WMIOHG ( I, FLAGOK ) +#endif +#ifdef W3_MPI + IF ( MPI_COMM_GRD.NE.MPI_COMM_NULL ) & + CALL WMIOHG ( I ) + PREGTH(I) = .FALSE. +#endif GRSTAT(I) = 6 DONE = .TRUE. END IF @@ -926,30 +1126,44 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 7.c Stage data ! -!/SHRD IF ( GRSTAT(I) .EQ. 6 ) CALL WMIOHS ( I ) +#ifdef W3_SHRD + IF ( GRSTAT(I) .EQ. 6 ) CALL WMIOHS ( I ) +#endif ! -!/MPI IF ( GRSTAT(I) .EQ. 6 .AND. & -!/MPI MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -!/MPI CALL WMIOHF ( I ) -!/MPI CALL WMIOHS ( I ) -!/MPI END IF -! -!/T IF (GRSTAT(I).EQ.6) WRITE(MDST,9003) I, GRSTAT(I) -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & -!/MPRF 'ST05', I +#ifdef W3_MPI + IF ( GRSTAT(I) .EQ. 6 .AND. & + MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOHF ( I ) + CALL WMIOHS ( I ) + END IF +#endif +! +#ifdef W3_T + IF (GRSTAT(I).EQ.6) WRITE(MDST,9003) I, GRSTAT(I) +#endif +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST05', I +#endif END IF ! ! 8. Perform data assimmilation ------------------------------------- / ! ( GRSTAT = 6 ) Placeholder only ..... ! IF ( GRSTAT(I) .EQ. 6 ) THEN -!/MPRF CALL PRTIME ( PRFT0 ) -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif GRSTAT(I) = 7 -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & -!/MPRF 'ST06', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & + 'ST06', I +#endif DONE = .TRUE. END IF ! @@ -959,10 +1173,16 @@ SUBROUTINE WMWAVE ( TEND ) ! ! 9.a Check times and finish step if no output to be made ! -!/SHRD IF ( GRSTAT(I) .EQ. 7 ) THEN -!/MPI IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) THEN +#ifdef W3_SHRD + IF ( GRSTAT(I) .EQ. 7 ) THEN +#endif +#ifdef W3_MPI + IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) THEN +#endif ! -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif ! IF ( TOUTP(1,I) .EQ. -1 ) THEN DTTST = 1. @@ -970,7 +1190,9 @@ SUBROUTINE WMWAVE ( TEND ) CALL W3SETW ( I, MDSE, MDST ) DTTST = DSEC21 ( TIME , TOUTP(:,I) ) END IF -!/T WRITE (MDST,9090) DTTST +#ifdef W3_T + WRITE (MDST,9090) DTTST +#endif FLG_O1 = DTTST .EQ. 0. ! IF ( UNIPTS ) THEN @@ -983,7 +1205,9 @@ SUBROUTINE WMWAVE ( TEND ) ! IF ( .NOT.FLG_O1 .AND. .NOT.FLG_O2 ) THEN GRSTAT(I) = 8 -!/T WRITE (MDST,9003) I, GRSTAT(I) +#ifdef W3_T + WRITE (MDST,9003) I, GRSTAT(I) +#endif DONE = .TRUE. END IF ! @@ -992,7 +1216,9 @@ SUBROUTINE WMWAVE ( TEND ) ! 9.b Perform output ! IF ( GRSTAT(I) .EQ. 7 ) THEN -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#ifdef W3_MPI + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN +#endif ! !!/MPRF CALL PRTIME ( PRFT0 ) !!/MPRF CALL WMWOUT ( I, NRGRD, 3 ) @@ -1000,7 +1226,9 @@ SUBROUTINE WMWAVE ( TEND ) !!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & !!/MPRF 'BCST',I ! -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif ! IF ( FLG_O1 ) THEN CALL W3SETG ( I, MDSE, MDST ) @@ -1062,7 +1290,9 @@ SUBROUTINE WMWAVE ( TEND ) ENDIF ! END CHECKPOINT ! -!/T WRITE (MDST,9091) TOUTP(:,I) +#ifdef W3_T + WRITE (MDST,9091) TOUTP(:,I) +#endif ! END IF @@ -1073,8 +1303,10 @@ SUBROUTINE WMWAVE ( TEND ) IF ( FLG_O2 ) THEN CALL W3SETO ( I, MDSE, MDST ) ! -!/MPI IF ( NRQPO.NE.0 ) CALL MPI_STARTALL & -!/MPI ( NRQPO, IRQPO1, IERR_MPI ) +#ifdef W3_MPI + IF ( NRQPO.NE.0 ) CALL MPI_STARTALL & + ( NRQPO, IRQPO1, IERR_MPI ) +#endif ! IF ( NOPTS.NE.0 .AND. IAPROC.EQ.NAPPNT ) THEN CALL W3SETG ( I, MDSE, MDST ) @@ -1082,94 +1314,124 @@ SUBROUTINE WMWAVE ( TEND ) CALL W3IOPE ( VA ) END IF ! -!/MPI IF ( NRQPO .NE. 0 ) THEN -!/MPI ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQPO) ) -!/MPI CALL MPI_WAITALL & -!/MPI ( NRQPO, IRQPO1, STATUS, IERR_MPI ) -!/MPI DEALLOCATE ( STATUS ) -!/MPI END IF +#ifdef W3_MPI + IF ( NRQPO .NE. 0 ) THEN + ALLOCATE ( STATUS(MPI_STATUS_SIZE,NRQPO) ) + CALL MPI_WAITALL & + ( NRQPO, IRQPO1, STATUS, IERR_MPI ) + DEALLOCATE ( STATUS ) + END IF +#endif ! -!/T WRITE (MDST,9092) NOPTS +#ifdef W3_T + WRITE (MDST,9092) NOPTS +#endif ! END IF ! END IF ! -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN,get_memory(), & -!/MPRF 'ST07', I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN,get_memory(), & + 'ST07', I +#endif ! ! 9.e Update TOUPT outside communicator ! -!/MPI ELSE IF ( FLG_O1 ) THEN +#ifdef W3_MPI + ELSE IF ( FLG_O1 ) THEN +#endif ! -!/MPI CALL W3SETO ( I, MDSE, MDST ) -!/MPI CALL W3SETW ( I, MDSE, MDST ) +#ifdef W3_MPI + CALL W3SETO ( I, MDSE, MDST ) + CALL W3SETW ( I, MDSE, MDST ) +#endif ! -!/MPI TIME = TOUTP(:,I) -!/MPI TOUTP(1,I) = -1 -!/MPI TOUTP(2,I) = 0 +#ifdef W3_MPI + TIME = TOUTP(:,I) + TOUTP(1,I) = -1 + TOUTP(2,I) = 0 +#endif ! -!/MPI DO JO=1, NOTYPE -! -!/MPI IF ( FLOUT(JO) ) THEN -!/MPI DO -!/MPI DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) -!/MPI IF ( DTTST .LE. 0. ) THEN -!/MPI CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) -!/MPI DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) -!/MPI IF ( DTTST .LT. 0. ) THEN -!/MPI FLOUT(JO) = .FALSE. -!/MPI EXIT -!/MPI END IF -!/MPI ELSE -!/MPI EXIT -!/MPI END IF -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( .NOT.FLOUT(JO) ) CYCLE -!/MPI IF ( TOUTP(1,I) .EQ. -1 ) THEN -!/MPI TOUTP(:,I) = TONEXT(:,JO) -!/MPI ELSE -!/MPI DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) -!/MPI IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) -!/MPI ENDIF -! -!/MPI END DO +#ifdef W3_MPI + DO JO=1, NOTYPE +#endif +! +#ifdef W3_MPI + IF ( FLOUT(JO) ) THEN + DO + DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) + IF ( DTTST .LE. 0. ) THEN + CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) + DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) + IF ( DTTST .LT. 0. ) THEN + FLOUT(JO) = .FALSE. + EXIT + END IF + ELSE + EXIT + END IF + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF +#endif +! +#ifdef W3_MPI + END DO +#endif ! ! Checkpoint ! -!/MPI JO=8 -! -!/MPI IF ( FLOUT(JO) ) THEN -!/MPI DO -!/MPI DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) -!/MPI IF ( DTTST .LE. 0. ) THEN -!/MPI CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) -!/MPI DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) -!/MPI IF ( DTTST .LT. 0. ) THEN -!/MPI FLOUT(JO) = .FALSE. -!/MPI EXIT -!/MPI END IF -!/MPI ELSE -!/MPI EXIT -!/MPI END IF -!/MPI END DO -!/MPI END IF -! -!/MPI IF ( .NOT.FLOUT(JO) ) CYCLE -!/MPI IF ( TOUTP(1,I) .EQ. -1 ) THEN -!/MPI TOUTP(:,I) = TONEXT(:,JO) -!/MPI ELSE -!/MPI DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) -!/MPI IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) -!/MPI ENDIF +#ifdef W3_MPI + JO=8 +#endif +! +#ifdef W3_MPI + IF ( FLOUT(JO) ) THEN + DO + DTTST = DSEC21 ( TIME, TONEXT(:,JO) ) + IF ( DTTST .LE. 0. ) THEN + CALL TICK21 ( TONEXT(:,JO), DTOUT(JO) ) + DTTST = DSEC21 ( TONEXT(:,JO), TOLAST(:,JO) ) + IF ( DTTST .LT. 0. ) THEN + FLOUT(JO) = .FALSE. + EXIT + END IF + ELSE + EXIT + END IF + END DO + END IF +#endif +! +#ifdef W3_MPI + IF ( .NOT.FLOUT(JO) ) CYCLE + IF ( TOUTP(1,I) .EQ. -1 ) THEN + TOUTP(:,I) = TONEXT(:,JO) + ELSE + DTTST = DSEC21 ( TOUTP(:,I) , TONEXT(:,JO) ) + IF (DTTST.LT.0.) TOUTP(:,I) = TONEXT(:,JO) + ENDIF +#endif ! ! End Checkpoint -!/MPIT WRITE (MDST,9991) TOUTP(:,I) -!/MPI END IF +#ifdef W3_MPIT + WRITE (MDST,9991) TOUTP(:,I) +#endif +#ifdef W3_MPI + END IF +#endif ! ! 9.f Finish up ! @@ -1184,14 +1446,18 @@ SUBROUTINE WMWAVE ( TEND ) ! IF ( GRSTAT(I) .EQ. 8 ) THEN ! -!/T WRITE (MDST,9002) I, GRSTAT(I), ' ' +#ifdef W3_T + WRITE (MDST,9002) I, GRSTAT(I), ' ' +#endif ! ! 10.a Processing unified point output ! IF ( UNIPTS .AND. DO_UPT ) THEN CALL W3SETW ( I, MDSE, MDST ) FLAGOK = DSEC21 ( TIME, UPNEXT ) .EQ. 0. -!/T WRITE (MDST,9095) FLAGOK +#ifdef W3_T + WRITE (MDST,9095) FLAGOK +#endif ELSE FLAGOK = .FALSE. END IF @@ -1203,11 +1469,15 @@ SUBROUTINE WMWAVE ( TEND ) FLAGOK = FLAGOK .AND. GRSTAT(II).EQ.8 .AND. & DSEC21(TIME,UPNEXT).EQ.0. END DO -!/T WRITE (MDST,9096) FLAGOK +#ifdef W3_T + WRITE (MDST,9096) FLAGOK +#endif ! IF ( FLAGOK ) THEN ! -!/MPRF CALL PRTIME ( PRFT0 ) +#ifdef W3_MPRF + CALL PRTIME ( PRFT0 ) +#endif CALL WMIOPO ( UPNEXT ) DO_UPT = .FALSE. ! @@ -1231,14 +1501,18 @@ SUBROUTINE WMWAVE ( TEND ) END IF TSYNC(1,II) = -1 TSYNC(2,II) = 0 -!/T IF ( I .NE. II ) & -!/T WRITE (MDST,9003) II, GRSTAT(II) +#ifdef W3_T + IF ( I .NE. II ) & + WRITE (MDST,9003) II, GRSTAT(II) +#endif END DO ! DONE = .TRUE. -!/MPRF CALL PRTIME ( PRFTN ) -!/MPRF WRITE (MDSP,991) PRFT0, PRFTN, & -!/MPRF get_memory(), 'UPTS',I +#ifdef W3_MPRF + CALL PRTIME ( PRFTN ) + WRITE (MDSP,991) PRFT0, PRFTN, & + get_memory(), 'UPTS',I +#endif END IF ! ELSE @@ -1257,7 +1531,9 @@ SUBROUTINE WMWAVE ( TEND ) GRSTAT(I) = 99 DONE = .TRUE. END IF -!/T WRITE (MDST,9003) I, GRSTAT(I) +#ifdef W3_T + WRITE (MDST,9003) I, GRSTAT(I) +#endif END IF ! IF ( GRSTAT(I).EQ.9 .OR. GRSTAT(I).EQ.99 ) THEN @@ -1275,7 +1551,9 @@ SUBROUTINE WMWAVE ( TEND ) ! END DO LOOP_J ! -!/MPI NMPSCR = NMPSCS +#ifdef W3_MPI + NMPSCR = NMPSCS +#endif IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & CALL WMPRNT ( MDSO, NRGRD, TSYNC(:,0), GRSTAT ) ! @@ -1294,18 +1572,24 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDSS,902) WTIME ENDIF ! -!/MPI DO I=1, NRGRD -!/MPI CALL WMSETM ( I, MDSE, MDST ) -!/MPI IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN -!/MPI CALL WMIOBF ( I ) -!/MPI CALL WMIOHF ( I ) -!/MPI CALL WMIOEF ( I ) -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + DO I=1, NRGRD + CALL WMSETM ( I, MDSE, MDST ) + IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) THEN + CALL WMIOBF ( I ) + CALL WMIOHF ( I ) + CALL WMIOEF ( I ) + END IF + END DO +#endif ! -!/O10 IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#ifdef W3_O10 + IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) WRITE (MDSS,999) +#endif ! -!/T WRITE (MDST,9100) +#ifdef W3_T + WRITE (MDST,9100) +#endif ! RETURN ! @@ -1341,9 +1625,11 @@ SUBROUTINE WMWAVE ( TEND ) 901 FORMAT (' MWW3 calculating for ',A,' at ',A,' status [', & I2,'-',I2,']') 902 FORMAT (' MWW3 reached the end of the computation loop at ',A) -!/MPRF 990 FORMAT (1X,3F12.3,' WMWAVE INIT') -!/MPRF 991 FORMAT (1X,3F12.3,' WMWAVE ',A4,I6) -!/MPRF 992 FORMAT (1X,3F12.3,' WMWAVE ',A4,I9.8,I7.6) +#ifdef W3_MPRF + 990 FORMAT (1X,3F12.3,' WMWAVE INIT') + 991 FORMAT (1X,3F12.3,' WMWAVE ',A4,I6) + 992 FORMAT (1X,3F12.3,' WMWAVE ',A4,I9.8,I7.6) +#endif 999 FORMAT (/' ========== END OF WAVE MODEL (WMWAVE) ============', & '============================'/) ! @@ -1366,50 +1652,76 @@ SUBROUTINE WMWAVE ( TEND ) 1099 FORMAT (/' *** WAVEWATCH III ERROR IN WMWAVE : *** '/ & ' ABORT FOR POSSIBLE ENDLESS LOOP '/) ! -!/T 9000 FORMAT ( ' TEST WMWAVE : LOOP',I8,' ======================', & -!/T '===== (',I9.8,I7.6,' ) =='/ & -!/T ' GRID, GRSTAT, TIME, TSYNC, TEND') -!/T 9001 FORMAT ( ' ',I3,I3,3(I10.8,I7.6)) -!/T 9002 FORMAT ( ' TEST WMWAVE : PROCESSING GRID',I3, & -!/T ' STATUS',I3,' ',A) -!/MPIT 9902 FORMAT ( ' MPIT WMWAVE : PROCESSING GRID',I3, & -!/MPIT ' STATUS',I3,' ',A) -!/T 9003 FORMAT ( ' TEST WMWAVE : GRID',I3,' STATUS RESET TO',I3) -!/T 9004 FORMAT ( ' TEST WMWAVE : FLAGOK = ',L1) -!/T 9005 FORMAT ( ' TEST WMWAVE : FLEQOK = ',L1) -!/T 9006 FORMAT ( ' TEST WMWAVE : CYCLE GROUP') -! -!/T 9020 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) -!/T 9021 FORMAT ( ' TEST WMWAVE : TIME :',I10.8,I7.6/ & -!/T ' TDATA :',I10.8,I7.6/ & -!/T ' TEND :',I10.8,I7.6) -! -!/T 9040 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6,F8.2/ & -!/T ' DTMAX :',I10.8,I7.6/ & -!/T ' TDATA :',I10.8,I7.6/ & -!/T ' TOUTP :',I10.8,I7.6/ & -!/T ' UPNEXT:',I10.8,I7.6) -!/T 9041 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6) -!/MPIT 9941 FORMAT ( ' MPIT WMWAVE : TMAX :',I10.8,I7.6) -!/T 9042 FORMAT ( ' TEST WMWAVE : GRANK :',I4,' FOR GRSTAT = 2') -!/T 9043 FORMAT ( ' TEST WMWAVE : GLOBAL TSYNC :',I10.8,I7.6) -!/T 9044 FORMAT ( ' TEST WMWAVE : LOCAL TSYNC :',I10.8,I7.6, & -!/T ' (',I8.8,I7.6,')') -!/T 9045 FORMAT ( ' TEST WMWAVE : GRID TSYNC') -!/T 9046 FORMAT ( ' ',I5,I10.8,I7.6) -! -!/T 9061 FORMAT ( ' GRID',I4,', FLEQOK = ',L1) -! -!/T 9090 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) -!/T 9091 FORMAT ( ' TEST WMWAVE : NEXT TOUTP :',I10.8,I7.6) -!/MPIT 9991 FORMAT ( ' MPIT WMWAVE : NEXT TOUTP :',I10.8,I7.6) -!/T 9092 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT PREP DONE',I6) -! -!/T 9095 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT, FLAGOK = ',L1) -!/T 9096 FORMAT ( ' ALL GRIDS, FLAGOK = ',L1) -! -!/T 9100 FORMAT ( ' TEST WMWAVE : LOOP DONE ======================', & -!/T '==============================') +#ifdef W3_T + 9000 FORMAT ( ' TEST WMWAVE : LOOP',I8,' ======================', & + '===== (',I9.8,I7.6,' ) =='/ & + ' GRID, GRSTAT, TIME, TSYNC, TEND') + 9001 FORMAT ( ' ',I3,I3,3(I10.8,I7.6)) + 9002 FORMAT ( ' TEST WMWAVE : PROCESSING GRID',I3, & + ' STATUS',I3,' ',A) +#endif +#ifdef W3_MPIT + 9902 FORMAT ( ' MPIT WMWAVE : PROCESSING GRID',I3, & + ' STATUS',I3,' ',A) +#endif +#ifdef W3_T + 9003 FORMAT ( ' TEST WMWAVE : GRID',I3,' STATUS RESET TO',I3) + 9004 FORMAT ( ' TEST WMWAVE : FLAGOK = ',L1) + 9005 FORMAT ( ' TEST WMWAVE : FLEQOK = ',L1) + 9006 FORMAT ( ' TEST WMWAVE : CYCLE GROUP') +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) + 9021 FORMAT ( ' TEST WMWAVE : TIME :',I10.8,I7.6/ & + ' TDATA :',I10.8,I7.6/ & + ' TEND :',I10.8,I7.6) +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6,F8.2/ & + ' DTMAX :',I10.8,I7.6/ & + ' TDATA :',I10.8,I7.6/ & + ' TOUTP :',I10.8,I7.6/ & + ' UPNEXT:',I10.8,I7.6) + 9041 FORMAT ( ' TEST WMWAVE : TMAX :',I10.8,I7.6) +#endif +#ifdef W3_MPIT + 9941 FORMAT ( ' MPIT WMWAVE : TMAX :',I10.8,I7.6) +#endif +#ifdef W3_T + 9042 FORMAT ( ' TEST WMWAVE : GRANK :',I4,' FOR GRSTAT = 2') + 9043 FORMAT ( ' TEST WMWAVE : GLOBAL TSYNC :',I10.8,I7.6) + 9044 FORMAT ( ' TEST WMWAVE : LOCAL TSYNC :',I10.8,I7.6, & + ' (',I8.8,I7.6,')') + 9045 FORMAT ( ' TEST WMWAVE : GRID TSYNC') + 9046 FORMAT ( ' ',I5,I10.8,I7.6) +#endif +! +#ifdef W3_T + 9061 FORMAT ( ' GRID',I4,', FLEQOK = ',L1) +#endif +! +#ifdef W3_T + 9090 FORMAT ( ' TEST WMWAVE : DTTST ',E10.3) + 9091 FORMAT ( ' TEST WMWAVE : NEXT TOUTP :',I10.8,I7.6) +#endif +#ifdef W3_MPIT + 9991 FORMAT ( ' MPIT WMWAVE : NEXT TOUTP :',I10.8,I7.6) +#endif +#ifdef W3_T + 9092 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT PREP DONE',I6) +#endif +! +#ifdef W3_T + 9095 FORMAT ( ' TEST WMWAVE : UNIFIED POINT OUTPUT, FLAGOK = ',L1) + 9096 FORMAT ( ' ALL GRIDS, FLAGOK = ',L1) +#endif +! +#ifdef W3_T + 9100 FORMAT ( ' TEST WMWAVE : LOOP DONE ======================', & + '==============================') +#endif !/ !/ End of WMWAVE ----------------------------------------------------- / !/ @@ -1474,7 +1786,9 @@ SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif USE W3TIMEMD, ONLY: STME21 !/ IMPLICIT NONE @@ -1489,7 +1803,9 @@ SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) !/ INTEGER, PARAMETER :: IW = 15 INTEGER :: I, I0, IN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER, SAVE :: IDLAST(2) LOGICAL, SAVE :: FIRST = .TRUE. CHARACTER(LEN=23) :: IDTIME @@ -1497,7 +1813,9 @@ SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'WMPRNT') +#ifdef W3_S + CALL STRACE (IENT, 'WMPRNT') +#endif ! DO I=1, IW LNE(I) = '---' @@ -1522,7 +1840,9 @@ SUBROUTINE WMPRNT ( MDSO, NRGRD, TSYNC, GRSTAT ) END DO ! IF ( IDLAST(1).EQ.TSYNC(1) .AND. IDLAST(2).EQ.TSYNC(2) ) THEN -!/O11 WRITE (MDSO,903) STR, ' |' +#ifdef W3_O11 + WRITE (MDSO,903) STR, ' |' +#endif ELSE IF ( IDLAST(1) .EQ. TSYNC(1) ) THEN WRITE (MDSO,902) IDTIME(12:19), STR, ' |' ELSE @@ -1627,14 +1947,20 @@ SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) ! !/ ------------------------------------------------------------------- / ! -!/MPI USE WMMDATMD, ONLY: MDST, MTAGB, IMPROC, NMPROC, ALLPRC, & -!/MPI CROOT, MPI_COMM_MWAVE +#ifdef W3_MPI + USE WMMDATMD, ONLY: MDST, MTAGB, IMPROC, NMPROC, ALLPRC, & + CROOT, MPI_COMM_MWAVE +#endif ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1645,16 +1971,24 @@ SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/MPI INTEGER :: ITAG, IP, IERR_MPI, & -!/MPI STATUS(MPI_STATUS_SIZE) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_MPI + INTEGER :: ITAG, IP, IERR_MPI, & + STATUS(MPI_STATUS_SIZE) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ -!/S CALL STRACE (IENT, 'WMBCST') +#ifdef W3_S + CALL STRACE (IENT, 'WMBCST') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/MPI ITAG = MTAGB + IMOD + ID*NMOD +#ifdef W3_MPI + ITAG = MTAGB + IMOD + ID*NMOD +#endif ! !!/MPIT WRITE (MDST,9000) IMOD, NMOD, ID, ITAG-MTAGB !!/MPIT WRITE (MDST,9001) IMPROC, NMPROC @@ -1663,22 +1997,30 @@ SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) ! -------------------------------------------------------------------- / ! 1. Processor to send data from ! -!/MPI IF ( ALLPRC(IMPROC,IMOD) .EQ. 1 ) THEN -!/MPI DO IP=1, NMPROC -!/MPI IF ( ALLPRC(IP,IMOD) .EQ. 0 ) THEN +#ifdef W3_MPI + IF ( ALLPRC(IMPROC,IMOD) .EQ. 1 ) THEN + DO IP=1, NMPROC + IF ( ALLPRC(IP,IMOD) .EQ. 0 ) THEN +#endif !!/MPIT WRITE (MDST,9010) ALLPRC(IMPROC,IMOD), IP -!/MPI CALL MPI_SEND ( DATA, NR, MPI_INTEGER, IP-1, & -!/MPI ITAG, MPI_COMM_MWAVE, IERR_MPI ) -!/MPI END IF -!/MPI END DO +#ifdef W3_MPI + CALL MPI_SEND ( DATA, NR, MPI_INTEGER, IP-1, & + ITAG, MPI_COMM_MWAVE, IERR_MPI ) + END IF + END DO +#endif ! ! -------------------------------------------------------------------- / ! 2. Processor to receive data at ! -!/MPI ELSE IF ( ALLPRC(IMPROC,IMOD) .EQ. 0 ) THEN +#ifdef W3_MPI + ELSE IF ( ALLPRC(IMPROC,IMOD) .EQ. 0 ) THEN +#endif !!/MPIT WRITE (MDST,9020) ALLPRC(IMPROC,IMOD), CROOT -!/MPI CALL MPI_RECV ( DATA, NR, MPI_INTEGER, CROOT-1, ITAG, & -!/MPI MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_RECV ( DATA, NR, MPI_INTEGER, CROOT-1, ITAG, & + MPI_COMM_MWAVE, STATUS, IERR_MPI ) +#endif ! ! -------------------------------------------------------------------- / @@ -1686,22 +2028,32 @@ SUBROUTINE WMBCST ( DATA, NR, IMOD, NMOD, ID ) ! !!/MPIT ELSE !!/MPIT WRITE (MDST,9030) ALLPRC(IMPROC,IMOD) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! RETURN ! ! Formats ! -!/MPIT 9000 FORMAT ( ' TEST WMBCST : INPUTS :',4I4) -!/MPIT 9001 FORMAT ( ' TEST WMBCST : IMPROC, NMPROC:',2I5,' ALLPRC :') -!/MPIT 9002 FORMAT (14X,13I5) +#ifdef W3_MPIT + 9000 FORMAT ( ' TEST WMBCST : INPUTS :',4I4) + 9001 FORMAT ( ' TEST WMBCST : IMPROC, NMPROC:',2I5,' ALLPRC :') + 9002 FORMAT (14X,13I5) +#endif ! -!/MPIT 9010 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' SENDING TO ',I5) +#ifdef W3_MPIT + 9010 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' SENDING TO ',I5) +#endif ! -!/MPIT 9020 FORMAT ( ' TEST WMBCST : IAPROC =',I5, & -!/MPIT ' RECEIVING FROM ',I5) +#ifdef W3_MPIT + 9020 FORMAT ( ' TEST WMBCST : IAPROC =',I5, & + ' RECEIVING FROM ',I5) +#endif ! -!/MPIT 9030 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' NO ACTION') +#ifdef W3_MPIT + 9030 FORMAT ( ' TEST WMBCST : IAPROC =',I5,' NO ACTION') +#endif !/ !/ End of WMBCST ----------------------------------------------------- / !/ @@ -1769,18 +2121,26 @@ SUBROUTINE WMWOUT ( IMOD, NMOD, ID ) ! !/ ------------------------------------------------------------------- / ! -!/MPI USE W3ODATMD, ONLY: W3SETO -!/MPI USE W3ADATMD, ONLY: W3SETA +#ifdef W3_MPI + USE W3ODATMD, ONLY: W3SETO + USE W3ADATMD, ONLY: W3SETA +#endif ! -!/MPI USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC -!/MPI USE W3ADATMD, ONLY: MPI_COMM_WAVE -!/MPI USE WMMDATMD, ONLY: MDST, MDSE, MTAGB +#ifdef W3_MPI + USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC + USE W3ADATMD, ONLY: MPI_COMM_WAVE + USE WMMDATMD, ONLY: MDST, MDSE, MTAGB +#endif ! -!/S USE W3SERVMD, ONLY: STRACE +#ifdef W3_S + USE W3SERVMD, ONLY: STRACE +#endif ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1790,66 +2150,98 @@ SUBROUTINE WMWOUT ( IMOD, NMOD, ID ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/MPI INTEGER :: ITAG, IP, IERR_MPI, & -!/MPI STATUS(MPI_STATUS_SIZE) -!/S INTEGER, SAVE :: IENT = 0 -!/MPI REAL, SAVE :: DUMMY = 999. +#ifdef W3_MPI + INTEGER :: ITAG, IP, IERR_MPI, & + STATUS(MPI_STATUS_SIZE) +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_MPI + REAL, SAVE :: DUMMY = 999. +#endif !/ -!/S CALL STRACE (IENT, 'WMWOUT') +#ifdef W3_S + CALL STRACE (IENT, 'WMWOUT') +#endif ! ! -------------------------------------------------------------------- / ! 0. Initializations ! -!/MPI CALL W3SETO ( IMOD, MDSE, MDST ) -!/MPI CALL W3SETA ( IMOD, MDSE, MDST ) -!/MPI ITAG = MTAGB + IMOD + ID*NMOD +#ifdef W3_MPI + CALL W3SETO ( IMOD, MDSE, MDST ) + CALL W3SETA ( IMOD, MDSE, MDST ) + ITAG = MTAGB + IMOD + ID*NMOD +#endif ! !!/MPIT WRITE (MDST,9000) IMOD, NMOD, ID, ITAG-MTAGB !!/MPIT WRITE (MDST,9001) IAPROC, NAPROC, NTPROC -!/MPI IF ( IAPROC .LT. 1 ) THEN +#ifdef W3_MPI + IF ( IAPROC .LT. 1 ) THEN +#endif !!/MPIT WRITE (MDST,9002) -!/MPI RETURN -!/MPI END IF +#ifdef W3_MPI + RETURN + END IF +#endif ! ! -------------------------------------------------------------------- / ! 1. Processor to send data from ! -!/MPI IF ( IAPROC .EQ. 1 ) THEN -!/MPI DO IP=NAPROC+1, NTPROC +#ifdef W3_MPI + IF ( IAPROC .EQ. 1 ) THEN + DO IP=NAPROC+1, NTPROC +#endif !!/MPIT WRITE (MDST,9010) IAPROC, IP -!/MPI CALL MPI_SEND ( DUMMY, 1, MPI_INTEGER, IP-1, & -!/MPI ITAG, MPI_COMM_WAVE, IERR_MPI ) -!/MPI END DO +#ifdef W3_MPI + CALL MPI_SEND ( DUMMY, 1, MPI_INTEGER, IP-1, & + ITAG, MPI_COMM_WAVE, IERR_MPI ) + END DO +#endif ! ! -------------------------------------------------------------------- / ! 2. Processor to receive data at ! -!/MPI ELSE IF ( IAPROC .GT. NAPROC ) THEN +#ifdef W3_MPI + ELSE IF ( IAPROC .GT. NAPROC ) THEN +#endif !!/MPIT WRITE (MDST,9020) IAPROC, 1 -!/MPI CALL MPI_RECV ( DUMMY, 1, MPI_INTEGER, 0, ITAG, & -!/MPI MPI_COMM_WAVE, STATUS, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_RECV ( DUMMY, 1, MPI_INTEGER, 0, ITAG, & + MPI_COMM_WAVE, STATUS, IERR_MPI ) +#endif ! ! -------------------------------------------------------------------- / ! 3. Processor with no action ! !!/MPIT ELSE !!/MPIT WRITE (MDST,9030) IAPROC -!/MPI END IF +#ifdef W3_MPI + END IF +#endif ! RETURN ! ! Formats ! -!/MPIT 9000 FORMAT ( ' TEST WMWOUT : INPUTS :',4I4) -!/MPIT 9001 FORMAT ( ' TEST WMWOUT : IAPROC, NAPROC, NTPROC :',3I5) -!/MPIT 9002 FORMAT ( ' TEST WMWOUT : NOT IN COMMUNICATOR') +#ifdef W3_MPIT + 9000 FORMAT ( ' TEST WMWOUT : INPUTS :',4I4) + 9001 FORMAT ( ' TEST WMWOUT : IAPROC, NAPROC, NTPROC :',3I5) + 9002 FORMAT ( ' TEST WMWOUT : NOT IN COMMUNICATOR') +#endif ! -!/MPIT 9010 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' SENDING TO ',I5) +#ifdef W3_MPIT + 9010 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' SENDING TO ',I5) +#endif ! -!/MPIT 9020 FORMAT ( ' TEST WMWOUT : IAPROC =',I5, & -!/MPIT ' RECEIVING FROM ',I5) +#ifdef W3_MPIT + 9020 FORMAT ( ' TEST WMWOUT : IAPROC =',I5, & + ' RECEIVING FROM ',I5) +#endif ! -!/MPIT 9030 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' NO ACTION') +#ifdef W3_MPIT + 9030 FORMAT ( ' TEST WMWOUT : IAPROC =',I5,' NO ACTION') +#endif !/ !/ End of WMWOUT ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_bounc.ftn b/model/src/ww3_bounc.F90 similarity index 96% rename from model/ftn/ww3_bounc.ftn rename to model/src/ww3_bounc.F90 index dcf9bdb34..f4e384113 100644 --- a/model/ftn/ww3_bounc.ftn +++ b/model/src/ww3_bounc.F90 @@ -112,21 +112,29 @@ PROGRAM W3BOUNC GNAME, W3NMOD, W3SETG,& NSEA, MAPSTA, XYB, GTYPE, XGRD, YGRD, X0, Y0, & SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE, FLAGLL -!/RTD USE W3GDATMD, ONLY : POLAT, POLON +#ifdef W3_RTD + USE W3GDATMD, ONLY : POLAT, POLON +#endif USE W3ODATMD, ONLY: NDSO, NDSE USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC USE W3IOGRMD, ONLY: W3IOGR USE W3TIMEMD USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE, DIST_SPHERE -!/RTD USE W3SERVMD, ONLY: W3EQTOLL +#ifdef W3_RTD + USE W3SERVMD, ONLY: W3EQTOLL +#endif USE W3NMLBOUNCMD USE NETCDF -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -142,7 +150,9 @@ PROGRAM W3BOUNC IRET, ICODE, NDSL INTEGER :: TIME(2), TIME2(2), VARID(12), & REFDATE(8), CURDATE(8), VARTYPE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! INTEGER, ALLOCATABLE :: IPBPI(:,:), IPBPO(:,:), NCID(:), & DIMID(:,:), DIMLN(:,:) @@ -156,8 +166,10 @@ PROGRAM W3BOUNC XBPI(:), YBPI(:), RDBPI(:,:), & XBPO(:), YBPO(:), RDBPO(:,:), & ABPIN(:,:), ABPIN2(:,:,:) -!/RTD REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) -!/RTD LOGICAL :: ISRTD +#ifdef W3_RTD + REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) + LOGICAL :: ISRTD +#endif ! REAL, ALLOCATABLE :: TMPSPCI(:,:),TMPSPCO(:,:) @@ -204,7 +216,9 @@ PROGRAM W3BOUNC NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3BOUNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3BOUNC') +#endif ! WRITE (NDSO,900) ! @@ -215,9 +229,11 @@ PROGRAM W3BOUNC ! CALL W3IOGR ( 'READ', NDSM ) WRITE (NDSO,920) GNAME -!/RTD! -!/RTD ISRTD = POLAT .LT. 90.0 -!/RTD! +#ifdef W3_RTD +! + ISRTD = POLAT .LT. 90.0 +! +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Read requests from input file. @@ -373,7 +389,9 @@ PROGRAM W3BOUNC END IF END DO ALLOCATE(XBPO(NBO),YBPO(NBO)) -!/RTD IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) +#ifdef W3_RTD + IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) +#endif ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) IBO=0 DO ISEA=1,NSEA @@ -394,15 +412,17 @@ PROGRAM W3BOUNC END SELECT !GTYPE END IF END DO -!/RTD! -!/RTD IF (ISRTD) THEN -!/RTD ! Convert grid boundary cell locations to standard pole -!/RTD XTMP = XBPO -!/RTD YTMP = YBPO -!/RTD CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) -!/RTD DEALLOCATE(XTMP, YTMP, ANGTMP) -!/RTD ENDIF -!/RTD! +#ifdef W3_RTD +! + IF (ISRTD) THEN + ! Convert grid boundary cell locations to standard pole + XTMP = XBPO + YTMP = YBPO + CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) + DEALLOCATE(XTMP, YTMP, ANGTMP) + ENDIF +! +#endif ! OPEN(NDSB,FILE='nest.ww3',FORM='UNFORMATTED',status='unknown') ALLOCATE(DIMID(NBO2,3),DIMLN(NBO2,3),NCID(NBO2)) diff --git a/model/ftn/ww3_bound.ftn b/model/src/ww3_bound.F90 similarity index 94% rename from model/ftn/ww3_bound.ftn rename to model/src/ww3_bound.F90 index dce46f186..e1c6d654a 100644 --- a/model/ftn/ww3_bound.ftn +++ b/model/src/ww3_bound.F90 @@ -103,18 +103,26 @@ PROGRAM W3BOUND USE W3GDATMD, ONLY: NK, NTH, XFR, FR1, GNAME, W3NMOD, W3SETG, & NSEA, MAPSTA, XYB, GTYPE, XGRD, YGRD, X0, Y0, & SX, SY, MAPSF, UNGTYPE, CLGTYPE, RLGTYPE -!/RTD USE W3GDATMD, ONLY : POLAT, POLON +#ifdef W3_RTD + USE W3GDATMD, ONLY : POLAT, POLON +#endif USE W3ODATMD, ONLY: NDSO, NDSE USE W3IOBCMD, ONLY: VERBPTBC, IDSTRBC USE W3IOGRMD, ONLY: W3IOGR USE W3TIMEMD USE W3SERVMD, ONLY: ITRACE, NEXTLN, EXTCDE -!/RTD USE W3SERVMD, ONLY: W3EQTOLL -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_RTD + USE W3SERVMD, ONLY: W3EQTOLL +#endif +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -132,7 +140,9 @@ PROGRAM W3BOUND NK1,NTH1,NSPEC1, NBI, NBI2, & NKI, NTHI, NBO, NBO2, IERR, INTERP, ILOOP, & IFMIN, IFMIN2, IFMAX, VERBOSE -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER IBO !REAL , DIMENSION(:), ALLOCATABLE :: SPEC REAL , DIMENSION(:), ALLOCATABLE :: LATS, LONS @@ -142,8 +152,10 @@ PROGRAM W3BOUND REAL, ALLOCATABLE :: XBPI(:), YBPI(:), RDBPI(:,:), & XBPO(:), YBPO(:), RDBPO(:,:), & ABPIN(:,:) -!/RTD REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) -!/RTD LOGICAL :: ISRTD +#ifdef W3_RTD + REAL, ALLOCATABLE :: XTMP(:), YTMP(:), ANGTMP(:) + LOGICAL :: ISRTD +#endif INTEGER, ALLOCATABLE :: IPBPI(:,:), IPBPO(:,:) @@ -175,7 +187,9 @@ PROGRAM W3BOUND NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3BOUND') +#ifdef W3_S + CALL STRACE (IENT, 'W3BOUND') +#endif ! ! @@ -184,9 +198,11 @@ PROGRAM W3BOUND ! CALL W3IOGR ( 'READ', NDSM ) WRITE (NDSO,920) GNAME -!/RTD! -!/RTD ISRTD = POLAT .LT. 90.0 -!/RTD! +#ifdef W3_RTD +! + ISRTD = POLAT .LT. 90.0 +! +#endif ! ! 3. Read input file ! @@ -301,7 +317,9 @@ PROGRAM W3BOUND END IF END DO ALLOCATE(XBPO(NBO),YBPO(NBO)) -!/RTD IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) +#ifdef W3_RTD + IF (ISRTD) ALLOCATE(XTMP(NBO), YTMP(NBO), ANGTMP(NBO)) +#endif ALLOCATE (IPBPO(NBO,4),RDBPO(NBO,4)) IBO=0 DO ISEA=1,NSEA @@ -322,15 +340,17 @@ PROGRAM W3BOUND END SELECT !GTYPE END IF END DO -!/RTD! -!/RTD ! Convert grid boundary cell locations to standard pole -!/RTD IF( ISRTD ) THEN -!/RTD XTMP = XBPO -!/RTD YTMP = YBPO -!/RTD CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) -!/RTD DEALLOCATE(XTMP, YTMP, ANGTMP) -!/RTD ENDIF -!/RTD! +#ifdef W3_RTD +! + ! Convert grid boundary cell locations to standard pole + IF( ISRTD ) THEN + XTMP = XBPO + YTMP = YBPO + CALL W3EQTOLL(YTMP, XTMP, YBPO, XBPO, ANGTMP, POLAT, POLON, NBO) + DEALLOCATE(XTMP, YTMP, ANGTMP) + ENDIF +! +#endif OPEN(NDSB,FILE='nest.ww3',FORM='UNFORMATTED',status='unknown') ALLOCATE(LATS(NBO2),LONS(NBO2)) DO IP=1,NBO2 @@ -433,13 +453,15 @@ PROGRAM W3BOUND ! READ(200+IP,'(A1,A10,A1,2F7.2,F10.1,F7.2,F6.1,F7.2,F6.1)') & space,buoyname,space,LATS(IP),LONS(IP),depth,U10,Udir,Curr,Currdir -!/RTD! -!/RTD IF (ISRTD) THEN -!/RTD ! Rotated coordinates are scaled in range 0 - 360 -!/RTD IF(LONS(IP) .LT. 0) LONS(IP) = LONS(IP) + 360.0 -!/RTD IF(LONS(IP) .GT. 360) LONS(IP) = LONS(IP) - 360.0 -!/RTD ENDIF -!/RTD! +#ifdef W3_RTD +! + IF (ISRTD) THEN + ! Rotated coordinates are scaled in range 0 - 360 + IF(LONS(IP) .LT. 0) LONS(IP) = LONS(IP) + 360.0 + IF(LONS(IP) .GT. 360) LONS(IP) = LONS(IP) - 360.0 + ENDIF +! +#endif READ(200+IP,*,IOSTAT=IERR) SPEC2D IF (IFMIN2.GT.1) THEN ! diff --git a/model/ftn/ww3_gint.ftn b/model/src/ww3_gint.F90 similarity index 97% rename from model/ftn/ww3_gint.ftn rename to model/src/ww3_gint.F90 index 81c92bcc5..4db6b8e17 100644 --- a/model/ftn/ww3_gint.ftn +++ b/model/src/ww3_gint.F90 @@ -100,7 +100,9 @@ PROGRAM W3GRID_INTERP USE W3WDATMD, ONLY : WDATAS, TIME, WLV, ICE, ICEH, ICEF, & UST, USTDIR, ASF, RHOAIR USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3ARRYMD, ONLY : PRTBLK USE W3GSRUMD USE W3TRIAMD @@ -140,7 +142,9 @@ PROGRAM W3GRID_INTERP INTEGER :: IS(4), JS(4) INTEGER :: MAPINT REAL :: RW(4), SUMWT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL, ALLOCATABLE :: INT_MAP(:,:) LOGICAL :: L360=.FALSE., LPLC, INGRD, BRNCHCL, BRNCHCR, INGRID CHARACTER :: COMSTR*1, IDTIME*23, FNAMEWHT*32 @@ -167,7 +171,9 @@ PROGRAM W3GRID_INTERP WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) -!/S CALL STRACE (IENT, 'W3GRIDINT') +#ifdef W3_S + CALL STRACE (IENT, 'W3GRIDINT') +#endif !--------------------------------------------------------------------------- ! 3. Read and process input file upto number of grids ! 3.a Get comment character @@ -695,7 +701,9 @@ PROGRAM W3GRID_INTERP ! using the next available bit ! IF ( GR_INTS(ISEA)%NGRDS .EQ. 0 ) THEN -!/T WRITE (NDSO,909)IX, IY +#ifdef W3_T + WRITE (NDSO,909)IX, IY +#endif MAPINT = 1 MAPST2(IY,IX) = MAPST2(IY,IX) + MAPINT*16 MAPSTA(IY,IX) = -ABS ( MAPSTA(IY,IX) ) @@ -1051,9 +1059,13 @@ SUBROUTINE W3EXGI ( NGRD, NSEA, NOSWLL_MIN, INTMETHOD ) RHOAIR = UNDEF TAUA = UNDEF TAUADIR = UNDEF -!/BT4 SED_D50 = UNDEF -!/IS2 ICEH = UNDEF -!/IS2 ICEF = UNDEF +#ifdef W3_BT4 + SED_D50 = UNDEF +#endif +#ifdef W3_IS2 + ICEH = UNDEF + ICEF = UNDEF +#endif ! ! Group 2 variables ! @@ -1537,38 +1549,44 @@ SUBROUTINE W3EXGI ( NGRD, NSEA, NOSWLL_MIN, INTMETHOD ) END IF END IF ! -!/BT4 IF ( FLOGRD(1,10) ) THEN -!/BT4 IF ( GRIDS(IGRID)%SED_D50(GSEA) .NE. UNDEF ) THEN -!/BT4 SUMWT1(10) = SUMWT1(10) + WT -!/BT4 IF ( SED_D50AUX .EQ. UNDEF ) THEN -!/BT4 SED_D50AUX = GRIDS(IGRID)%SED_D50(GSEA)*WT -!/BT4 ELSE -!/BT4 SED_D50AUX = SED_D50AUX + GRIDS(IGRID)%SED_D50(GSEA)*WT -!/BT4 END IF -!/BT4 END IF -!/BT4 END IF -! -!/IS2 IF ( FLOGRD(1,11) ) THEN -!/IS2 IF ( WDATAS(IGRID)%ICEH(GSEA) .NE. UNDEF ) THEN -!/IS2 SUMWT1(11) = SUMWT1(11) + WT -!/IS2 IF (ICEHAUX .EQ. UNDEF) THEN -!/IS2 ICEHAUX = WDATAS(IGRID)%ICEH(GSEA)*WT -!/IS2 ELSE -!/IS2 ICEHAUX = ICEHAUX + WDATAS(IGRID)%ICEH(GSEA)*WT -!/IS2 END IF -!/IS2 END IF -!/IS2 END IF -! -!/IS2 IF ( FLOGRD(1,12) ) THEN -!/IS2 IF ( WDATAS(IGRID)%ICEF(GSEA) .NE. UNDEF ) THEN -!/IS2 SUMWT1(12) = SUMWT1(12) + WT -!/IS2 IF (ICEFAUX .EQ. UNDEF) THEN -!/IS2 ICEFAUX = WDATAS(IGRID)%ICEF(GSEA)*WT -!/IS2 ELSE -!/IS2 ICEFAUX = ICEFAUX + WDATAS(IGRID)%ICEF(GSEA)*WT -!/IS2 END IF -!/IS2 END IF -!/IS2 END IF +#ifdef W3_BT4 + IF ( FLOGRD(1,10) ) THEN + IF ( GRIDS(IGRID)%SED_D50(GSEA) .NE. UNDEF ) THEN + SUMWT1(10) = SUMWT1(10) + WT + IF ( SED_D50AUX .EQ. UNDEF ) THEN + SED_D50AUX = GRIDS(IGRID)%SED_D50(GSEA)*WT + ELSE + SED_D50AUX = SED_D50AUX + GRIDS(IGRID)%SED_D50(GSEA)*WT + END IF + END IF + END IF +#endif +! +#ifdef W3_IS2 + IF ( FLOGRD(1,11) ) THEN + IF ( WDATAS(IGRID)%ICEH(GSEA) .NE. UNDEF ) THEN + SUMWT1(11) = SUMWT1(11) + WT + IF (ICEHAUX .EQ. UNDEF) THEN + ICEHAUX = WDATAS(IGRID)%ICEH(GSEA)*WT + ELSE + ICEHAUX = ICEHAUX + WDATAS(IGRID)%ICEH(GSEA)*WT + END IF + END IF + END IF +#endif +! +#ifdef W3_IS2 + IF ( FLOGRD(1,12) ) THEN + IF ( WDATAS(IGRID)%ICEF(GSEA) .NE. UNDEF ) THEN + SUMWT1(12) = SUMWT1(12) + WT + IF (ICEFAUX .EQ. UNDEF) THEN + ICEFAUX = WDATAS(IGRID)%ICEF(GSEA)*WT + ELSE + ICEFAUX = ICEFAUX + WDATAS(IGRID)%ICEF(GSEA)*WT + END IF + END IF + END IF +#endif ! ! Group 2 variables ! @@ -2496,32 +2514,38 @@ SUBROUTINE W3EXGI ( NGRD, NSEA, NOSWLL_MIN, INTMETHOD ) END IF END IF ! -!/BT4 IF ( SED_D50AUX .NE. UNDEF ) THEN -!/BT4 SED_D50AUX = SED_D50AUX / SUMWT1(10) -!/BT4 IF ( SED_D50(ISEA) .EQ. UNDEF ) THEN -!/BT4 SED_D50(ISEA) = SED_D50AUX / REAL( SUMGRD ) -!/BT4 ELSE -!/BT4 SED_D50(ISEA) = SED_D50(ISEA) + SED_D50AUX / REAL( SUMGRD ) -!/BT4 END IF -!/BT4 END IF -! -!/IS2 IF ( ICEHAUX .NE. UNDEF ) THEN -!/IS2 ICEHAUX = ICEHAUX / SUMWT1(11) -!/IS2 IF ( ICEH(ISEA) .EQ. UNDEF ) THEN -!/IS2 ICEH(ISEA) = ICEHAUX / REAL( SUMGRD ) -!/IS2 ELSE -!/IS2 ICEH(ISEA) = ICEH(ISEA) + ICEHAUX / REAL( SUMGRD ) -!/IS2 END IF -!/IS2 END IF -! -!/IS2 IF ( ICEFAUX .NE. UNDEF ) THEN -!/IS2 ICEFAUX = ICEFAUX / SUMWT1(12) -!/IS2 IF ( ICEF(ISEA) .EQ. UNDEF ) THEN -!/IS2 ICEF(ISEA) = ICEFAUX / REAL( SUMGRD ) -!/IS2 ELSE -!/IS2 ICEF(ISEA) = ICEF(ISEA) + ICEFAUX / REAL( SUMGRD ) -!/IS2 END IF -!/IS2 END IF +#ifdef W3_BT4 + IF ( SED_D50AUX .NE. UNDEF ) THEN + SED_D50AUX = SED_D50AUX / SUMWT1(10) + IF ( SED_D50(ISEA) .EQ. UNDEF ) THEN + SED_D50(ISEA) = SED_D50AUX / REAL( SUMGRD ) + ELSE + SED_D50(ISEA) = SED_D50(ISEA) + SED_D50AUX / REAL( SUMGRD ) + END IF + END IF +#endif +! +#ifdef W3_IS2 + IF ( ICEHAUX .NE. UNDEF ) THEN + ICEHAUX = ICEHAUX / SUMWT1(11) + IF ( ICEH(ISEA) .EQ. UNDEF ) THEN + ICEH(ISEA) = ICEHAUX / REAL( SUMGRD ) + ELSE + ICEH(ISEA) = ICEH(ISEA) + ICEHAUX / REAL( SUMGRD ) + END IF + END IF +#endif +! +#ifdef W3_IS2 + IF ( ICEFAUX .NE. UNDEF ) THEN + ICEFAUX = ICEFAUX / SUMWT1(12) + IF ( ICEF(ISEA) .EQ. UNDEF ) THEN + ICEF(ISEA) = ICEFAUX / REAL( SUMGRD ) + ELSE + ICEF(ISEA) = ICEF(ISEA) + ICEFAUX / REAL( SUMGRD ) + END IF + END IF +#endif ! ! Group 2 variables ! diff --git a/model/ftn/ww3_grib.ftn b/model/src/ww3_grib.F90 similarity index 67% rename from model/ftn/ww3_grib.ftn rename to model/src/ww3_grib.F90 index 675d0626e..690402e6c 100644 --- a/model/ftn/ww3_grib.ftn +++ b/model/src/ww3_grib.F90 @@ -120,7 +120,9 @@ PROGRAM W3GRIB USE W3IOGRMD, ONLY: W3IOGR USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 ! USE W3GDATMD @@ -140,19 +142,25 @@ PROGRAM W3GRIB FTIME(2), CID, PID, GID, GDS, IOUT, & GDTN INTEGER, ALLOCATABLE :: IFIA(:),IFJA(:) -!/NOGRB INTEGER :: KPDS(1), KGDS(1) +#ifdef W3_NOGRB + INTEGER :: KPDS(1), KGDS(1) +#endif ! GRIB2 specific variables -!/NCEP2 INTEGER :: KPDS(200), KGDS(200), IDRS(200) -!/NCEP2 INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) -!/NCEP2 INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD -!/NCEP2 INTEGER :: IBMP, LCGRIB, LENGRIB, IDRSNUM -!/NCEP2 REAL :: COORDLIST, XN -!/NCEP2 CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) -!/NCEP2 INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & -!/NCEP2 LATIN2, LATSP, LONSP -!/NCEP2 REAL :: DSX, DSY -!/NCEP2 REAL :: YN, X0N, Y0N -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_NCEP2 + INTEGER :: KPDS(200), KGDS(200), IDRS(200) + INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) + INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD + INTEGER :: IBMP, LCGRIB, LENGRIB, IDRSNUM + REAL :: COORDLIST, XN + CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) + INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & + LATIN2, LATSP, LONSP + REAL :: DSX, DSY + REAL :: YN, X0N, Y0N +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTREQ, DTEST, RFTIME LOGICAL :: FLREQ(NOGRP,NGRPP), FLGRIB(NOGRP,NGRPP) CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11 @@ -163,7 +171,9 @@ PROGRAM W3GRIB !/ !/ ------------------------------------------------------------------- / !/ -!/NCO/! CALL W3TAGB('WAVEGRIB',1998,0007,0050,'NP21 ') +#ifdef W3_NCO +! CALL W3TAGB('WAVEGRIB',1998,0007,0050,'NP21 ') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. IO set-up. @@ -185,30 +195,38 @@ PROGRAM W3GRIB NDSTRC = 6 NTRACE = 10 ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSOG = 13 -!/NCO NDSDAT = 51 -!/NCO NDSTRC = NDSO +#ifdef W3_NCO +! +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSOG = 13 + NDSDAT = 51 + NDSTRC = NDSO +#endif ! WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) -!/S CALL STRACE (IENT, 'W3GRIB') +#ifdef W3_S + CALL STRACE (IENT, 'W3GRIB') +#endif ! OPEN (NDSI,FILE='ww3_grib.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) READ (NDSI,'(A)',END=801,ERR=802) COMSTR IF (COMSTR.EQ.' ') COMSTR = '$' WRITE (NDSO,901) COMSTR ! -!/NOGRB WRITE (NDSE,902) -!/NCEP2 CALL BAOPENW (NDSDAT,'gribfile',IERR) +#ifdef W3_NOGRB + WRITE (NDSE,902) +#endif +#ifdef W3_NCEP2 + CALL BAOPENW (NDSDAT,'gribfile',IERR) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Read model definition file. @@ -353,29 +371,37 @@ PROGRAM W3GRIB ! or PolarStereo ! IF ( GTYPE .EQ. CLGTYPE ) THEN -!/NCEP2! Allowing code to work with Lambert conformal grids -!/NCEP2 IF ( GDTN .NE. 30 .AND. GDTN .NE. 20 ) THEN +#ifdef W3_NCEP2 +! Allowing code to work with Lambert conformal grids + IF ( GDTN .NE. 30 .AND. GDTN .NE. 20 ) THEN +#endif WRITE(NDSE,*)'PROGRAM W3GRIB: CURVILINEAR GRID SUPPORT '// & 'FOR GRIB OUTPUT IS NOT YET IMPLEMENTED. NOW STOPPING' CALL EXTCDE ( 1 ) -!/NCEP2 ENDIF +#ifdef W3_NCEP2 + ENDIF +#endif END IF ! ! ! Coded up to now only for Lamber conformal grids (GDTN=30) or ! PolarStereo (GDTN=20). For regular grids use GDTN=0 ! -!/NCEP2 IF ( GDTN .EQ. 30 ) THEN -!/NCEP2! This is a Lambert conformal grid, read projection parameters -!/NCEP2 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/NCEP2 READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & -!/NCEP2 SCNMOD, LATIN1, LATIN2, LATSP, LONSP -!/NCEP2 ELSEIF ( GDTN .EQ. 20 ) THEN -!/NCEP2 CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/NCEP2 READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & -!/NCEP2 SCNMOD +#ifdef W3_NCEP2 + IF ( GDTN .EQ. 30 ) THEN +! This is a Lambert conformal grid, read projection parameters + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & + SCNMOD, LATIN1, LATIN2, LATSP, LONSP + ELSEIF ( GDTN .EQ. 20 ) THEN + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & + SCNMOD +#endif -!/NCEP2 ENDIF +#ifdef W3_NCEP2 + ENDIF +#endif ! CALL STME21 ( FTIME , IDTIME ) WRITE (NDSO,948) IDTIME, CID, PID, GID, GDS @@ -397,9 +423,11 @@ PROGRAM W3GRIB END DO END DO ! -!/NCEP2! -!/NCEP2 IF ( GDTN .EQ. 0 ) THEN -!/NCEP2! +#ifdef W3_NCEP2 +! + IF ( GDTN .EQ. 0 ) THEN +! +#endif ! 4.c Flip MAPSF for REGULAR/RECTILINEAR grids ! DO ISEA=1, NSEA @@ -408,8 +436,10 @@ PROGRAM W3GRIB MAPSF(ISEA,2) = NY + 1 - IY MAPSF(ISEA,3) = IY +( IX-1)*NY END DO -!/NCEP2! -!/NCEP2 ENDIF +#ifdef W3_NCEP2 +! + ENDIF +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Set grib encoding parameter Sections @@ -421,17 +451,21 @@ PROGRAM W3GRIB ! ! ... Set GRIB2 packing arrays ! -!/NCEP2 LCGRIB = 4*NX*NY -!/NCEP2 ALLOCATE(CGRIB(LCGRIB)) +#ifdef W3_NCEP2 + LCGRIB = 4*NX*NY + ALLOCATE(CGRIB(LCGRIB)) +#endif ! ! ... Set GRIB2 Indicator Section ! ( 1) Discipline-GRIB Master Table Number (see Code Table 0.0) ! 0 = Metereological; 10 = Oceanographic ! ( 2) GRIB Edition Number ! ( 3) -!/NCEP2 LISTSEC0 = 0 -!/NCEP2 LISTSEC0(1) = 10 -!/NCEP2 LISTSEC0(2) = 2 +#ifdef W3_NCEP2 + LISTSEC0 = 0 + LISTSEC0(1) = 10 + LISTSEC0(2) = 2 +#endif ! ! ... Set GRIB2 Identification Section ! ( 1) ID OF CENTER @@ -448,12 +482,14 @@ PROGRAM W3GRIB ! (12) Production status of data (Code Table 1.3) ! (13) Type of processed data (Code Table 1.4) ! -!/NCEP2 LISTSEC1 = 0 -!/NCEP2 LISTSEC1(1) = CID -!/NCEP2 LISTSEC1(3) = 2 -!/NCEP2 LISTSEC1(4) = 1 -!/NCEP2 LISTSEC1(5) = 1 -!/NCEP2 LISTSEC1(13) = 1 +#ifdef W3_NCEP2 + LISTSEC1 = 0 + LISTSEC1(1) = CID + LISTSEC1(3) = 2 + LISTSEC1(4) = 1 + LISTSEC1(5) = 1 + LISTSEC1(13) = 1 +#endif ! ! ... Set GRIB2 IGDS elements ! ( 1) Source of grid definition (Code Table 3.0) @@ -462,23 +498,25 @@ PROGRAM W3GRIB ! ( 4) Interpretation of list for optional points definition (Code Table 3.11) ! ( 5) Grid definition template number (Code Table 3.1) ! -!/NCEP2 IGDS = 0 ! Defined in code -!/NCEP2 IGDS(2) = NX*NY -!/NCEP2 IDEFNUM = 0 -!/NCEP2 IDEFLIST = 0 -!/NCEP2 IGDS(5)=GDTN -!/NCEP2 IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN -!/NCEP2 IDEFNUM = 1 -!/NCEP2 WRITE (NDSO,1011) 'LAMBERTCONF' -!/NCEP2 ELSEIF ( GDTN .EQ. 20 .AND. GTYPE .EQ. CLGTYPE ) THEN -!/NCEP2 WRITE (NDSO,1011) 'POLARSTEREO' -!/NCEP2 ELSEIF ( GDTN .EQ. 0 ) THEN -!/NCEP2 WRITE (NDSO,1011) 'LLRECTILINEAR' -!/NCEP2 ELSE -!/NCEP2 WRITE(NDSE,*)'PROGRAM WAVEGRIB2: SUPPORT FOR CHOSEN '// & -!/NCEP2 'GRIB2 GRID DEFINITION TEMPLATE NOT YET IMPLEMENTED' -!/NCEP2 CALL EXTCDE ( 2 ) -!/NCEP2 ENDIF +#ifdef W3_NCEP2 + IGDS = 0 ! Defined in code + IGDS(2) = NX*NY + IDEFNUM = 0 + IDEFLIST = 0 + IGDS(5)=GDTN + IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN + IDEFNUM = 1 + WRITE (NDSO,1011) 'LAMBERTCONF' + ELSEIF ( GDTN .EQ. 20 .AND. GTYPE .EQ. CLGTYPE ) THEN + WRITE (NDSO,1011) 'POLARSTEREO' + ELSEIF ( GDTN .EQ. 0 ) THEN + WRITE (NDSO,1011) 'LLRECTILINEAR' + ELSE + WRITE(NDSE,*)'PROGRAM WAVEGRIB2: SUPPORT FOR CHOSEN '// & + 'GRIB2 GRID DEFINITION TEMPLATE NOT YET IMPLEMENTED' + CALL EXTCDE ( 2 ) + ENDIF +#endif ! ! ... Set GRIB2 KGDS elements ! @@ -492,11 +530,15 @@ PROGRAM W3GRIB ! ( 7) ! ( 8) Number of points along parallel ! ( 9) Number of points along meridian -!/NCEP2 KGDS( 1) = 6 -!/NCEP2 KGDS( 8) = NX -!/NCEP2 KGDS( 9) = NY +#ifdef W3_NCEP2 + KGDS( 1) = 6 + KGDS( 8) = NX + KGDS( 9) = NY +#endif ! -!/NCEP2 IF ( GDTN .EQ. 30 ) THEN +#ifdef W3_NCEP2 + IF ( GDTN .EQ. 30 ) THEN +#endif ! ! Lambert Conformal grid ! (10) Latitude of first grid point @@ -513,27 +555,31 @@ PROGRAM W3GRIB ! (21) Latitude of southern pole ! (22) Longitude of southern pole ! -!/NCEP2 X0 = MOD(XGRD(1,1) + 360.,360.) -!/NCEP2 XN = MOD(XGRD(NY,NX) + 360., 360.) -!/NCEP2 X0N = MOD(XGRD(NY,1) + 360., 360.) -!/NCEP2 KGDS(11)=KNINT(1000000.*X0) -!/NCEP2 Y0 = YGRD(1,1) -!/NCEP2 YN = YGRD(NY,NX) -!/NCEP2 Y0N = YGRD(NY,1) -!/NCEP2 KGDS(10)=KNINT(1000000.*Y0) -!/NCEP2 KGDS(12)=0 -!/NCEP2 KGDS(13)=DBLE(1000000.*LATAN1) -!/NCEP2 KGDS(14)=DBLE(1000000.*LONV) -!/NCEP2 KGDS(15)=KNINT(1000000*DSX) -!/NCEP2 KGDS(16)=KNINT(1000000*DSY) -!/NCEP2 KGDS(17)=0 -!/NCEP2 KGDS(18)=SCNMOD -!/NCEP2 KGDS(19)=DBLE(1000000.*LATIN1) -!/NCEP2 KGDS(20)=DBLE(1000000.*LATIN2) -!/NCEP2 KGDS(21)=DBLE(1000000.*LATSP) -!/NCEP2 KGDS(22)=DBLE(1000000.*LONSP) -! -!/NCEP2 ELSEIF (GDTN .EQ. 20 ) THEN +#ifdef W3_NCEP2 + X0 = MOD(XGRD(1,1) + 360.,360.) + XN = MOD(XGRD(NY,NX) + 360., 360.) + X0N = MOD(XGRD(NY,1) + 360., 360.) + KGDS(11)=KNINT(1000000.*X0) + Y0 = YGRD(1,1) + YN = YGRD(NY,NX) + Y0N = YGRD(NY,1) + KGDS(10)=KNINT(1000000.*Y0) + KGDS(12)=0 + KGDS(13)=DBLE(1000000.*LATAN1) + KGDS(14)=DBLE(1000000.*LONV) + KGDS(15)=KNINT(1000000*DSX) + KGDS(16)=KNINT(1000000*DSY) + KGDS(17)=0 + KGDS(18)=SCNMOD + KGDS(19)=DBLE(1000000.*LATIN1) + KGDS(20)=DBLE(1000000.*LATIN2) + KGDS(21)=DBLE(1000000.*LATSP) + KGDS(22)=DBLE(1000000.*LONSP) +#endif +! +#ifdef W3_NCEP2 + ELSEIF (GDTN .EQ. 20 ) THEN +#endif ! ! PolarStereo grid ! (10) Latitude of first grid point @@ -549,24 +595,28 @@ PROGRAM W3GRIB ! Projection for PolarStereo grid was changed from ! KGDS( 1) = 6 to KGDS( 1) = 5 (Earth assumed represented by WGS84 - ! Octet No 15 Table 3.2) -!/NCEP2 KGDS( 1) = 5 -!/NCEP2 X0 = MOD(XGRD(1,1) + 360.,360.) -!/NCEP2 XN = MOD(XGRD(NY,NX) + 360., 360.) -!/NCEP2 X0N = MOD(XGRD(NY,1) + 360., 360.) -!/NCEP2 KGDS(11)=KNINT(1000000.*X0) -!/NCEP2 Y0 = YGRD(1,1) -!/NCEP2 YN = YGRD(NY,NX) -!/NCEP2 Y0N = YGRD(NY,1) -!/NCEP2 KGDS(10)=KNINT(1000000.*Y0) -!/NCEP2 KGDS(12)=0 -!/NCEP2 KGDS(13)=DBLE(1000000.*LATAN1) -!/NCEP2 KGDS(14)=DBLE(1000000.*LONV) -!/NCEP2 KGDS(15)=KNINT(1000000*DSX) -!/NCEP2 KGDS(16)=KNINT(1000000*DSY) -!/NCEP2 KGDS(17)=0 -!/NCEP2 KGDS(18)=SCNMOD -! -!/NCEP2 ELSEIF (GDTN .EQ. 0 ) THEN +#ifdef W3_NCEP2 + KGDS( 1) = 5 + X0 = MOD(XGRD(1,1) + 360.,360.) + XN = MOD(XGRD(NY,NX) + 360., 360.) + X0N = MOD(XGRD(NY,1) + 360., 360.) + KGDS(11)=KNINT(1000000.*X0) + Y0 = YGRD(1,1) + YN = YGRD(NY,NX) + Y0N = YGRD(NY,1) + KGDS(10)=KNINT(1000000.*Y0) + KGDS(12)=0 + KGDS(13)=DBLE(1000000.*LATAN1) + KGDS(14)=DBLE(1000000.*LONV) + KGDS(15)=KNINT(1000000*DSX) + KGDS(16)=KNINT(1000000*DSY) + KGDS(17)=0 + KGDS(18)=SCNMOD +#endif +! +#ifdef W3_NCEP2 + ELSEIF (GDTN .EQ. 0 ) THEN +#endif ! ! Lat Lon rectilinear grid ! (10) @@ -580,16 +630,18 @@ PROGRAM W3GRIB ! (18) Increment of latitude ! (19) Scanning mode ! -!/NCEP2 KGDS(12) = KNINT(1000000.*(Y0+(REAL(NY-1)*SY))) -!/NCEP2 X0 = MOD(X0 + 360.,360.) -!/NCEP2 KGDS(13) = KNINT(1000000.*X0) -!/NCEP2 KGDS(14) = 48 -!/NCEP2 KGDS(15) = KNINT(1000000.*Y0) -!/NCEP2 XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) -!/NCEP2 KGDS(16) = KNINT(1000000.*XN) -!/NCEP2 KGDS(17) = KNINT(1000000.*SX) -!/NCEP2 KGDS(18) = KNINT(1000000.*SY) -!/NCEP2 ENDIF +#ifdef W3_NCEP2 + KGDS(12) = KNINT(1000000.*(Y0+(REAL(NY-1)*SY))) + X0 = MOD(X0 + 360.,360.) + KGDS(13) = KNINT(1000000.*X0) + KGDS(14) = 48 + KGDS(15) = KNINT(1000000.*Y0) + XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) + KGDS(16) = KNINT(1000000.*XN) + KGDS(17) = KNINT(1000000.*SX) + KGDS(18) = KNINT(1000000.*SY) + ENDIF +#endif ! ! ... Set GRIB2 PDS elements ! KPDSNUM (0 indicates forecast at a horizontal level) @@ -616,36 +668,46 @@ PROGRAM W3GRIB ! =2 deterministic forecast: ww3_grib.inp gen_pro set to 0 ! =2 legacy :with no gen_pro set in ww3_grib.inp ! (in the case of legacy the params revert back to old names) -!/NCEP2 KPDSNUM = 0 -!/NCEP2 if ( gen_pro.eq.1 ) then -!/NCEP2 KPDS( 3) = 4 -!/NCEP2 else -!/NCEP2 KPDS(3)=2 -!/NCEP2 endif -!/NCEP2 KPDS( 4) = 0 -!/NCEP2 KPDS( 5) = PID -!/NCEP2 KPDS( 8) = 1 -!/NCEP2 KPDS(10) = 1 -!/NCEP2 KPDS(12) = 1 -!/NCEP2 KPDS(13) = 255 +#ifdef W3_NCEP2 + KPDSNUM = 0 + if ( gen_pro.eq.1 ) then + KPDS( 3) = 4 + else + KPDS(3)=2 + endif + KPDS( 4) = 0 + KPDS( 5) = PID + KPDS( 8) = 1 + KPDS(10) = 1 + KPDS(12) = 1 + KPDS(13) = 255 +#endif ! ! ... Set GRIB2 vertical layer information ! -!/NCEP2 NUMCOORD = 0 -!/NCEP2 COORDLIST = 0.0 +#ifdef W3_NCEP2 + NUMCOORD = 0 + COORDLIST = 0.0 +#endif ! ! ... Set GRIB2 bitmap information ! 0 Bitmap is provided ! -!/NCEP2 IBMP = GDS +#ifdef W3_NCEP2 + IBMP = GDS +#endif ! ! ... Set GRIB2 Data Representation Template Number (Code Table 5.0) ! -!/NCEP2 IDRSNUM = 40 !jpeg2000 *** SEGFAULTS in some linux +#ifdef W3_NCEP2 + IDRSNUM = 40 !jpeg2000 *** SEGFAULTS in some linux +#endif ! clusters with Intel compiler *** -!/NCEP2 !IDRSNUM = 0 !simple packing -!/NCEP2 !IDRSNUM = 41 !png packing -!/NCEP2 !IDRSNUM = 2 !Complex Packing (Grid Point Data) +#ifdef W3_NCEP2 + !IDRSNUM = 0 !simple packing + !IDRSNUM = 41 !png packing + !IDRSNUM = 2 !Complex Packing (Grid Point Data) +#endif ! ! ... Set GRIB2 IDRS elements ! ( 1) Reference value (R) (IEEE 32-bit floating-point value) @@ -654,11 +716,15 @@ PROGRAM W3GRIB ! ( 4) Number of bits used for each packed value ! ( 5) Type of original field values (Code Table 5.1) ! -!/NCEP2 IDRS = 0 -!/NCEP2 IDRS(3) = 2 +#ifdef W3_NCEP2 + IDRS = 0 + IDRS(3) = 2 +#endif ! -!/T WRITE (NDST,9050) KPDS -!/T WRITE (NDST,9051) KGDS +#ifdef W3_T + WRITE (NDST,9050) KPDS + WRITE (NDST,9051) KGDS +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 6. Time management. @@ -686,18 +752,22 @@ PROGRAM W3GRIB ! RFTIME = DSEC21 ( FTIME , TIME ) / 3600. IF ( RFTIME .LT. 0. ) THEN -!/NCEP2 LISTSEC1( 6) = TIME(1)/10000 -!/NCEP2 LISTSEC1( 7) = MOD(TIME(1),10000) / 100 -!/NCEP2 LISTSEC1( 8) = MOD(TIME(1),100) -!/NCEP2 LISTSEC1( 9) = TIME(2) / 10000 -!/NCEP2 KPDS( 9) = 0 +#ifdef W3_NCEP2 + LISTSEC1( 6) = TIME(1)/10000 + LISTSEC1( 7) = MOD(TIME(1),10000) / 100 + LISTSEC1( 8) = MOD(TIME(1),100) + LISTSEC1( 9) = TIME(2) / 10000 + KPDS( 9) = 0 +#endif WRITE (NDSO,972) IDTIME ELSE -!/NCEP2 LISTSEC1( 6) = FTIME(1)/10000 -!/NCEP2 LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 -!/NCEP2 LISTSEC1( 8) = MOD(FTIME(1),100) -!/NCEP2 LISTSEC1( 9) = FTIME(2) / 10000 -!/NCEP2 KPDS( 9) = NINT(RFTIME) +#ifdef W3_NCEP2 + LISTSEC1( 6) = FTIME(1)/10000 + LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 + LISTSEC1( 8) = MOD(FTIME(1),100) + LISTSEC1( 9) = FTIME(2) / 10000 + KPDS( 9) = NINT(RFTIME) +#endif WRITE (NDSO,971) IDTIME, NINT(RFTIME) END IF ! @@ -731,7 +801,9 @@ PROGRAM W3GRIB 888 CONTINUE WRITE (NDSO,999) ! -!/NCO/! CALL W3TAGE('WAVEGRIB') +#ifdef W3_NCO +! CALL W3TAGE('WAVEGRIB') +#endif ! ! Formats ! @@ -777,11 +849,13 @@ PROGRAM W3GRIB ' ========================================='/ & ' WAVEWATCH III GRIB output '/) ! -!/T 9050 FORMAT ( ' TEST W3GRIB : KPDS : ',13I4/ & -!/T ' ',12I4) -!/T 9051 FORMAT ( ' TEST W3GRIB : KGDS : ',8I6/ & -!/T ' ',8I6/ & -!/T ' ',6I6) +#ifdef W3_T + 9050 FORMAT ( ' TEST W3GRIB : KPDS : ',13I4/ & + ' ',12I4) + 9051 FORMAT ( ' TEST W3GRIB : KGDS : ',8I6/ & + ' ',8I6/ & + ' ',6I6) +#endif ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & ' ERROR IN OPENING INPUT FILE'/ & @@ -796,7 +870,9 @@ PROGRAM W3GRIB ! 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRIB : '/ & ' GRIB REQUIRES SPHERICAL GRID'/) -!/NCEP2 1011 FORMAT (/' CHOSEN GRID TYPE: : ',A/) +#ifdef W3_NCEP2 + 1011 FORMAT (/' CHOSEN GRID TYPE: : ',A/) +#endif !/ !/ Internal subroutine W3EXGB ---------------------------------------- / !/ @@ -884,7 +960,9 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY : W3S2XY -!/RTD USE W3SERVMD, ONLY : W3THRTN, W3XYRTN +#ifdef W3_RTD + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN +#endif !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -896,7 +974,9 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) !/ INTEGER :: J, IXY, NDATA INTEGER :: IO -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: X1(NX*NY), X2(NX*NY), XX(NX*NY), & XY(NX*NY), CABS, UABS, & YY(NX*NY,0:NOSWLL), KPDS5A, KPDS5B, & @@ -906,10 +986,14 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3EXGB') +#ifdef W3_S + CALL STRACE (IENT, 'W3EXGB') +#endif ! -!/T WRITE (NDST,9000) ((FLREQ(IFI,IFJ),IFJ=1,NGRPP), IFI=1,NOGRP) -!/T WRITE (NDST,9001) NDSDAT, KPDS, KGDS +#ifdef W3_T + WRITE (NDST,9000) ((FLREQ(IFI,IFJ),IFJ=1,NGRPP), IFI=1,NOGRP) + WRITE (NDST,9001) NDSDAT, KPDS, KGDS +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. Preparations @@ -938,7 +1022,9 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) FLTRI = .FALSE. FLPRT = .FALSE. ! -!/T WRITE (NDST,9020) IDOUT(IFI,IFJ) +#ifdef W3_T + WRITE (NDST,9020) IDOUT(IFI,IFJ) +#endif ! ! 2.a Set output arrays and parameters ! @@ -946,8 +1032,10 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 14 -!/NCEP2 KPDS(1) = 4 +#ifdef W3_NCEP2 + KPDS(2) = 14 + KPDS(1) = 4 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & , MAPSF, X1 ) ! @@ -955,10 +1043,14 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN FLTWO = .TRUE. -!/NCEP2 KPDS(2) = 1 -!/NCEP2 KPDS(1) = 1 -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 1 +#endif +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & , MAPSF, XX ) CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & @@ -987,11 +1079,15 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN FLTWO = .TRUE. -!/NCEP2 KPDS(2) = 1 -!/NCEP2 KPDS(1) = 2 -!/NCEP2 LISTSEC0(1) = 0 -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 2 + LISTSEC0(1) = 0 +#endif +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & , MAPSF, XX ) CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & @@ -1020,8 +1116,10 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 -!/NCEP2 KPDS(1) = 3 +#ifdef W3_NCEP2 + KPDS(2) = 255 + KPDS(1) = 3 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & , MAPSF, X1 ) ! @@ -1029,27 +1127,35 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 1 -!/NCEP2 KPDS(1) = 3 +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 3 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) ! ! Ice concentration ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 0 -!/NCEP2 KPDS(1) = 2 +#ifdef W3_NCEP2 + KPDS(2) = 0 + KPDS(1) = 2 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) ! ! Atmospheric momentum ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN FLTWO = .TRUE. -!/NCEP2 KPDS(2) = 1 -!/NCEP2 KPDS(1) = 2 -!/NCEP2 LISTSEC0(1) = 0 -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA, TAUADIR, AnglD) +#ifdef W3_NCEP2 + KPDS(2) = 1 + KPDS(1) = 2 + LISTSEC0(1) = 0 +#endif +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA, TAUADIR, AnglD) +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUA(1:NSEA) & , MAPSF, XX ) CALL W3S2XY ( NSEA, NSEA, NX, NY, TAUADIR(1:NSEA) & @@ -1078,33 +1184,41 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 0 -!/NCEP2 KPDS(1) = 2 +#ifdef W3_NCEP2 + KPDS(2) = 0 + KPDS(1) = 2 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, RHOAIR, MAPSF, X1 ) ! ! Significant wave height ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 3 +#ifdef W3_NCEP2 + KPDS(2) = 3 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) ! ! Mean wave length ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 193 +#ifdef W3_NCEP2 + KPDS(2) = 193 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) ! ! Mean wave period (based on second moment) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN FLONE = .TRUE. -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS(2) = 28 -!/NCEP2 else -!/NCEP2 KPDS(2) = 25 -!/NCEP2 endif +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 28 + else + KPDS(2) = 25 + endif +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) ! @@ -1112,25 +1226,31 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 15 +#ifdef W3_NCEP2 + KPDS(2) = 15 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) ! ! Mean wave period (based on first inverse moment) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN FLONE = .TRUE. -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS(2) = 34 -!/NCEP2 else -!/NCEP2 KPDS(2) = 15 -!/NCEP2 endif +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 34 + else + KPDS(2) = 15 + endif +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) ! ! Peak frequency ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 11 +#ifdef W3_NCEP2 + KPDS(2) = 11 +#endif DO ISEA=1, NSEA IF ( FP0(ISEA) .NE. UNDEF .AND. FP0(ISEA) .NE. 0 ) THEN FP0(ISEA) = 1. / MAX(FR1,FP0(ISEA)) ! Limit FP to lowest discrete frequency @@ -1143,9 +1263,13 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 14 -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#ifdef W3_NCEP2 + KPDS(2) = 14 +#endif +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( THM(ISEA) .NE. UNDEF ) & THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) @@ -1156,20 +1280,26 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 31 +#ifdef W3_NCEP2 + KPDS(2) = 31 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) ! ! Peak direction ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN FLONE = .TRUE. -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS(2) = 46 -!/NCEP2 else -!/NCEP2 KPDS(2) = 10 -!/NCEP2 endif -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#ifdef W3_NCEP2 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS(2) = 46 + else + KPDS(2) = 10 + endif +#endif +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( THP0(ISEA) .NE. UNDEF ) THEN THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) @@ -1181,22 +1311,26 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, WNMEAN, MAPSF, X1 ) ! ! Partitioned wave height ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 5 -!/NCEP2 KPDS5B = 8 -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS5A1(1) =47 -!/NCEP2 KPDS5A1(2) =48 -!/NCEP2 KPDS5A1(3) =49 -!/NCEP2 else -!/NCEP2 KPDS5B = 8 -!/NCEP2 endif +#ifdef W3_NCEP2 + KPDS5A = 5 + KPDS5B = 8 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) =47 + KPDS5A1(2) =48 + KPDS5A1(3) =49 + else + KPDS5B = 8 + endif +#endif CALL W3S2XY & ( NSEA, NSEA, NX, NY, PHS(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL @@ -1208,15 +1342,17 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 6 -!/NCEP2 KPDS5B = 9 -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS5A1(1) = 50 -!/NCEP2 KPDS5A1(2) = 51 -!/NCEP2 KPDS5A1(3) = 52 -!/NCEP2 else -!/NCEP2 KPDS5B = 9 -!/NCEP2 endif +#ifdef W3_NCEP2 + KPDS5A = 6 + KPDS5B = 9 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) = 50 + KPDS5A1(2) = 51 + KPDS5A1(3) = 52 + else + KPDS5B = 9 + endif +#endif CALL W3S2XY & ( NSEA, NSEA, NX, NY, PTP(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL @@ -1228,8 +1364,10 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 193 -!/NCEP2 KPDS5B = 193 +#ifdef W3_NCEP2 + KPDS5A = 193 + KPDS5B = 193 +#endif CALL W3S2XY & ( NSEA, NSEA, NX, NY, PLP(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL @@ -1241,19 +1379,23 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 4 -!/NCEP2 KPDS5B = 7 -!/NCEP2 if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then -!/NCEP2 KPDS5A1(1) = 53 -!/NCEP2 KPDS5A1(2) = 54 -!/NCEP2 KPDS5A1(3) = 55 -!/NCEP2 else -!/NCEP2 KPDS5B = 7 -!/NCEP2 endif -!/RTD DO I = 0,NOSWLL -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,I), AnglD, .FALSE.) -!/RTD END DO +#ifdef W3_NCEP2 + KPDS5A = 4 + KPDS5B = 7 + if ((gen_pro.eq.1) .or. (gen_pro.eq.0)) then + KPDS5A1(1) = 53 + KPDS5A1(2) = 54 + KPDS5A1(3) = 55 + else + KPDS5B = 7 + endif +#endif +#ifdef W3_RTD + DO I = 0,NOSWLL + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,I), AnglD, .FALSE.) + END DO +#endif DO ISEA = 1,NSEA DO I = 0,NOSWLL IF ( PDIR(ISEA,I) .NE. UNDEF ) THEN @@ -1272,8 +1414,10 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 32 -!/NCEP2 KPDS5B = 33 +#ifdef W3_NCEP2 + KPDS5A = 32 + KPDS5B = 33 +#endif CALL W3S2XY & ( NSEA, NSEA, NX, NY, PSI(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL @@ -1285,8 +1429,10 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN FLPRT = .TRUE. -!/NCEP2 KPDS5A = 255 -!/NCEP2 KPDS5B = 255 +#ifdef W3_NCEP2 + KPDS5A = 255 + KPDS5B = 255 +#endif CALL W3S2XY & ( NSEA, NSEA, NX, NY, PWS(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL @@ -1298,24 +1444,32 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 16 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST , MAPSF, X1 ) ! ! Number of fields in partition ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 17 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) ! ! Friction velocity ! ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN FLTWO = .TRUE. -!/NCEP2 KPDS(2) = 17 -!/NCEP2 KPDS(1) = 1 -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) +#ifdef W3_NCEP2 + KPDS(2) = 17 + KPDS(1) = 1 +#endif +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, UST(1:NSEA) & , MAPSF, X1 ) CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & @@ -1325,7 +1479,9 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif DO ISEA=1, NSEA IF ( DTDYN(ISEA) .NE. UNDEF ) & DTDYN(ISEA) = DTDYN(ISEA) / 60. @@ -1336,21 +1492,27 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) ! ! CFL Maximum (in spatial space) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) ! ! CFL Maximum (in spectral space) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. -!/NCEP2 KPDS(2) = 255 +#ifdef W3_NCEP2 + KPDS(2) = 255 +#endif CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) ! ELSE @@ -1367,68 +1529,86 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! IF ( FLPRT ) THEN ! -!/NCEP2 KPDS(2) = KPDS5A +#ifdef W3_NCEP2 + KPDS(2) = KPDS5A +#endif DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,0) .NE. UNDEF END DO -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,YY(:,0), NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -! -!/NCEP2 if ((gen_pro.eq.0) .or. (gen_pro.eq.1)) then -!/NCEP2 KPDS(10) = 241 +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,0), NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif +! +#ifdef W3_NCEP2 + if ((gen_pro.eq.0) .or. (gen_pro.eq.1)) then + KPDS(10) = 241 +#endif DO I=1, NOSWLL -!/NCEP2 KPDS(2) = KPDS5A1(I) -!/NCEP2 KPDS(12) = I +#ifdef W3_NCEP2 + KPDS(2) = KPDS5A1(I) + KPDS(12) = I +#endif DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,I) .NE. UNDEF END DO -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,YY(:,I), NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,I), NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif END DO -!/NCEP2 ELSE -!/NCEP2 KPDS(2) = KPDS5B -!/NCEP2 KPDS(10) = 241 +#ifdef W3_NCEP2 + ELSE + KPDS(2) = KPDS5B + KPDS(10) = 241 +#endif DO I=1, NOSWLL -!/NCEP2 KPDS(12) = I +#ifdef W3_NCEP2 + KPDS(12) = I +#endif DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,I) .NE. UNDEF END DO -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,YY(:,I), NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,YY(:,I), NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif END DO -!/NCEP2 ENDIF -!/NCEP2 KPDS(10) = 1 -!/NCEP2 KPDS(12) = 1 +#ifdef W3_NCEP2 + ENDIF + KPDS(10) = 1 + KPDS(12) = 1 +#endif ! ! 3.b Other data ! @@ -1438,80 +1618,88 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) BITMAP(IXY) = X1(IXY) .NE. UNDEF END DO ! -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,X1, NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X1, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif ! ELSE IF ( FLTWO ) THEN ! DO IXY=1, NX*NY BITMAP(IXY) = X1(IXY) .NE. UNDEF END DO -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,X1, NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#ifdef W3_NCEP2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X1, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif -!/NCEP2 KPDS(2) = 0 -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,X2, NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -!/NCEP2 KPDS(2) = 2 -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,XX, NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) -!/NCEP2 KPDS(2) = 3 -!/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) -!/NCEP2 IF (IO .NE. 0) GOTO 810 -!/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & -!/NCEP2 IDEFNUM, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & -!/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & -!/NCEP2 200,XY, NDATA, IBMP, BITMAP, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 820 -!/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) -!/NCEP2 IF (IO .NE. 0) GOTO 830 -!/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#ifdef W3_NCEP2 + KPDS(2) = 0 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,X2, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) + KPDS(2) = 2 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,XX, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) + KPDS(2) = 3 + CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) + IF (IO .NE. 0) GOTO 810 + CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & + IDEFNUM, IO) + IF (IO .NE. 0) GOTO 820 + CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & + COORDLIST, NUMCOORD, IDRSNUM, IDRS, & + 200,XY, NDATA, IBMP, BITMAP, IO) + IF (IO .NE. 0) GOTO 820 + CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) + IF (IO .NE. 0) GOTO 830 + CALL WRYTE (NDSDAT, LENGRIB, CGRIB) +#endif ! END IF -!/NCEP2 LISTSEC0(1) = 10 -!/NCEP2 KPDS(1) = 0 +#ifdef W3_NCEP2 + LISTSEC0(1) = 10 + KPDS(1) = 0 +#endif ! ! ... End of fields loop ! @@ -1523,49 +1711,65 @@ SUBROUTINE W3EXGB ( NX, NY, NSEA ) ! ! Error escape locations ! -!/NCEP2 810 CONTINUE -!/NCEP2 WRITE (NDSE,1010) IO -!/NCEP2 CALL EXTCDE ( 20 ) -!/NCEP2 820 CONTINUE -!/NCEP2 WRITE (NDSE,1020) IO -!/NCEP2 CALL EXTCDE ( 30 ) -!/NCEP2 830 CONTINUE -!/NCEP2 WRITE (NDSE,1030) IO -!/NCEP2 CALL EXTCDE ( 40 ) +#ifdef W3_NCEP2 + 810 CONTINUE + WRITE (NDSE,1010) IO + CALL EXTCDE ( 20 ) + 820 CONTINUE + WRITE (NDSE,1020) IO + CALL EXTCDE ( 30 ) + 830 CONTINUE + WRITE (NDSE,1030) IO + CALL EXTCDE ( 40 ) +#endif ! ! Formats ! 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB :'/ & ' PLEASE UPDATE FIELDS !!! '/) ! -!/NCEP2 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & -!/NCEP2 ' ERROR IN OPENING OUTPUT FILE'/ & -!/NCEP2 ' IOSTAT =',I5/) -! -!/NCEP2 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & -!/NCEP2 ' ERROR CREATING NEW GRIB2 FIELD'/ & -!/NCEP2 ' IOSTAT =',I5/) -! -!/NCEP2 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & -!/NCEP2 ' ERROR ADDING GRIB2 FIELD'/ & -!/NCEP2 ' IOSTAT =',I5/) -! -!/NCEP2 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & -!/NCEP2 ' ERROR ENDING GRIB2 MESSAGE'/ & -!/NCEP2 ' IOSTAT =',I5/) +#ifdef W3_NCEP2 + 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) +#endif ! -!/T 9000 FORMAT (' TEST W3EXGB : FLAGS :',40L2) -!/T 9001 FORMAT (' TEST W3EXGB : NDSDAT :',I4/ & -!/T ' KPDS :',13I4/ & -!/T ' ',12I4/ & -!/T ' KGDS :',8I6/ & -!/T ' ',8I6/ & -!/T ' ',6I6) +#ifdef W3_NCEP2 + 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR CREATING NEW GRIB2 FIELD'/ & + ' IOSTAT =',I5/) +#endif ! -!/T 9012 FORMAT (' TEST W3EXGB : BLOK PARS : ',3I4) -!/T 9014 FORMAT (' BASE NAME : ',A) +#ifdef W3_NCEP2 + 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR ADDING GRIB2 FIELD'/ & + ' IOSTAT =',I5/) +#endif ! -!/T 9020 FORMAT (' TEST W3EXGB : OUTPUT FIELD : ',A) +#ifdef W3_NCEP2 + 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & + ' ERROR ENDING GRIB2 MESSAGE'/ & + ' IOSTAT =',I5/) +#endif +! +#ifdef W3_T + 9000 FORMAT (' TEST W3EXGB : FLAGS :',40L2) + 9001 FORMAT (' TEST W3EXGB : NDSDAT :',I4/ & + ' KPDS :',13I4/ & + ' ',12I4/ & + ' KGDS :',8I6/ & + ' ',8I6/ & + ' ',6I6) +#endif +! +#ifdef W3_T + 9012 FORMAT (' TEST W3EXGB : BLOK PARS : ',3I4) + 9014 FORMAT (' BASE NAME : ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3EXGB : OUTPUT FIELD : ',A) +#endif !/ !/ End of W3EXGB ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_grid.ftn b/model/src/ww3_grid.F90 similarity index 100% rename from model/ftn/ww3_grid.ftn rename to model/src/ww3_grid.F90 diff --git a/model/ftn/ww3_gspl.ftn b/model/src/ww3_gspl.F90 similarity index 88% rename from model/ftn/ww3_gspl.ftn rename to model/src/ww3_gspl.F90 index 9ffb0c4e8..8d6388ef9 100644 --- a/model/ftn/ww3_gspl.ftn +++ b/model/src/ww3_gspl.F90 @@ -161,7 +161,9 @@ PROGRAM W3GSPL USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE USE W3ARRYMD, ONLY : OUTA2I, OUTA2R -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3IOGRMD, ONLY: W3IOGR !/ USE W3GDATMD @@ -181,8 +183,12 @@ PROGRAM W3GSPL NSTDLG, MSTDLG = 5, NSEAT, J1, J2, & J3, J4, J5, IDFM1, IDFM2, IDFM3, & IDLA1, IDLA2, IDLA3, VSC3, NHEXT -!/S INTEGER, SAVE :: IENT = 0 -!/O16 INTEGER :: NDSG = 35, NTGRDS = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_O16 + INTEGER :: NDSG = 35, NTGRDS = 0 +#endif INTEGER, ALLOCATABLE :: MSPLIT(:,:), MTEMP(:,:), INGRD(:) REAL :: RATIO1, XMEAN, STARG, STDMIN, & ZBDUM, ZBMIN, VSC1, VSC2, FRACL, FRACH @@ -241,12 +247,16 @@ PROGRAM W3GSPL NTRACE = 100 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/O16 OPEN ( NDSG, FILE='./ww3.ww3_gspl', FORM='UNFORMATTED') +#ifdef W3_O16 + OPEN ( NDSG, FILE='./ww3.ww3_gspl', FORM='UNFORMATTED') +#endif ! ! 1.c Print header ! WRITE (NDSO,900) -!/S CALL STRACE (IENT, 'W3GSPL') +#ifdef W3_S + CALL STRACE (IENT, 'W3GSPL') +#endif ! J = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_gspl.inp',STATUS='OLD', & @@ -397,7 +407,9 @@ PROGRAM W3GSPL IF ( (NGX-1)*NGY .GE. NG ) NGX = NGX - 1 END IF ! -!/T WRITE (NDST,9040) NGX, NGY +#ifdef W3_T + WRITE (NDST,9040) NGX, NGY +#endif ! ! 4.b.2 Fill checkerboard ! @@ -411,7 +423,9 @@ PROGRAM W3GSPL ALLOCATE ( INGRD(NGX*NGY) ) INGRD = 0 ! -!/T WRITE (NDST,9041) J +#ifdef W3_T + WRITE (NDST,9041) J +#endif ! DO IGY=1, NGY ! @@ -442,12 +456,16 @@ PROGRAM W3GSPL END DO ! IF ( INGRD(IG) .GT. 0 ) THEN -!/T WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & -!/T INGRD(IG), 'OK' +#ifdef W3_T + WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & + INGRD(IG), 'OK' +#endif IG = IG + 1 -!/T ELSE -!/T WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & -!/T INGRD(IG), 'EMPTY (SKIPPED)' +#ifdef W3_T + ELSE + WRITE (NDST,9042) IG, IGX0, IGXN, IGY0, IGYN, & + INGRD(IG), 'EMPTY (SKIPPED)' +#endif END IF ! END DO @@ -462,7 +480,9 @@ PROGRAM W3GSPL NGX = NGX + 1 END IF DEALLOCATE ( INGRD ) -!/T WRITE (NDST,9040) NGX, NGY +#ifdef W3_T + WRITE (NDST,9040) NGX, NGY +#endif ELSE EXIT END IF @@ -475,7 +495,9 @@ PROGRAM W3GSPL END DO IF ( MINGRD .NE. NSEA ) GOTO 825 ! -!/T WRITE (NDST,9043) IG, NG +#ifdef W3_T + WRITE (NDST,9043) IG, NG +#endif ! ! 4.b.3 Merge smallest grids as necessary ! @@ -495,7 +517,9 @@ PROGRAM W3GSPL END DO INGRD(MINNR) = NSEA + 1 ! -!/T WRITE (NDST,9044) MINGRD, MINNR +#ifdef W3_T + WRITE (NDST,9044) MINGRD, MINNR +#endif ! ALLOCATE ( ISNEXT(0:IG) ) ISNEXT = .FALSE. @@ -537,7 +561,9 @@ PROGRAM W3GSPL END IF END DO ! -!/T WRITE (NDST,9045) MINNXT, MINNNR +#ifdef W3_T + WRITE (NDST,9045) MINNXT, MINNNR +#endif ! IF ( MINNNR .GT. 0 ) THEN DO IY=1, NY @@ -549,24 +575,32 @@ PROGRAM W3GSPL END DO END DO IGG = IGG - 1 -!/T WRITE (NDST,9046) MINNR, MINNNR -!/T DO J=1, IG -!/T WRITE (NDST,9047) J, INGRD(J) -!/T END DO -!/T ELSE -!/T WRITE (NDST,9048) MINNR +#ifdef W3_T + WRITE (NDST,9046) MINNR, MINNNR + DO J=1, IG + WRITE (NDST,9047) J, INGRD(J) + END DO + ELSE + WRITE (NDST,9048) MINNR +#endif END IF ! DEALLOCATE ( ISNEXT) -!/T WRITE (NDST,9043) IGG, NG +#ifdef W3_T + WRITE (NDST,9043) IGG, NG +#endif ! END DO ! -!/T WRITE (NDST,9049) NG +#ifdef W3_T + WRITE (NDST,9049) NG +#endif ! DO J=1, IG IF ( INGRD(J) .GT. NSEA ) INGRD(J) = 0 -!/T WRITE (NDSO,9047) J, INGRD(J) +#ifdef W3_T + WRITE (NDSO,9047) J, INGRD(J) +#endif END DO ! ! 4.b.4 Store first guess in MSPLT @@ -585,8 +619,10 @@ PROGRAM W3GSPL ! ! 5.b.5 Optional GrADS output ! -!/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) -!/O16 NTGRDS = NTGRDS + 1 +#ifdef W3_O16 + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Refine grids @@ -617,7 +653,9 @@ PROGRAM W3GSPL MSTOLD = MSTATS GSTOLD = GSTATS ! -!/T WRITE (NDST,9050) 'a', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#ifdef W3_T + WRITE (NDST,9050) 'a', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif ! ! 5.b Small grid attempt to merge ! @@ -631,8 +669,10 @@ PROGRAM W3GSPL WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 -!/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) -!/O16 NTGRDS = NTGRDS + 1 +#ifdef W3_O16 + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 +#endif CYCLE ELSE @@ -651,7 +691,9 @@ PROGRAM W3GSPL ! 5.d Attempt to quare-up grid ! CALL GRINFO ! call needed as GRSQRG uses grid ranges -!/T WRITE (NDST,9051) 'd', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#ifdef W3_T + WRITE (NDST,9051) 'd', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif CALL GRSQRG CALL GRFILL ( 1 ) ! @@ -678,15 +720,19 @@ PROGRAM W3GSPL CALL GRINFO WRITE (NDSO,951) IIT, MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN -!/T WRITE (NDST,9051) 'g', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#ifdef W3_T + WRITE (NDST,9051) 'g', MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif ! G0ID = '5.g' IF ( MSTATS%NMIN .EQ. 0 ) GOTO 850 ! ! 5.h Optional GrADS output ! -!/O16 WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) -!/O16 NTGRDS = NTGRDS + 1 +#ifdef W3_O16 + WRITE ( NDSG ) ((REAL(MSPLIT(IY,IX)),IX=1,NX),IY=1,NY) + NTGRDS = NTGRDS + 1 +#endif ! ! 5.i Convergence tests ! ... The quick one @@ -731,11 +777,15 @@ PROGRAM W3GSPL ! IF ( INGMNC .GE. INGLAG ) THEN ! -!/T WRITE (NDST,9052) 'MINIMUM' +#ifdef W3_T + WRITE (NDST,9052) 'MINIMUM' +#endif ! IF ( REAL(INGMIN) .LT. 0.85*XMEAN ) THEN ! -!/T WRITE (NDST,9053) 0.85*XMEAN / REAL(INGMIN) +#ifdef W3_T + WRITE (NDST,9053) 0.85*XMEAN / REAL(INGMIN) +#endif CALL GRFSML CALL GRINFO WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & @@ -746,9 +796,11 @@ PROGRAM W3GSPL INGMXC = 0 IF ( DONE ) EXIT ! -!/T ELSE -!/T WRITE (NDST,9054) -!/T +#ifdef W3_T + ELSE + WRITE (NDST,9054) + +#endif END IF ! END IF @@ -757,11 +809,15 @@ PROGRAM W3GSPL ! IF ( INGMXC .GE. INGLAG ) THEN ! -!/T WRITE (NDST,9052) 'MAXIMUM' +#ifdef W3_T + WRITE (NDST,9052) 'MAXIMUM' +#endif ! IF ( REAL(INGMAX) .GT. 1.075*XMEAN ) THEN ! -!/T WRITE (NDST,9053) REAL(INGMAX) / ( 1.075*XMEAN ) +#ifdef W3_T + WRITE (NDST,9053) REAL(INGMAX) / ( 1.075*XMEAN ) +#endif CALL GRINFO WRITE (NDSO,952) MSTATS%NMIN, MSTATS%NMAX, & 100.*MSTATS%RSTD/XMEAN @@ -771,9 +827,11 @@ PROGRAM W3GSPL INGMXC = 0 IF ( DONE ) EXIT ! -!/T ELSE -!/T WRITE (NDST,9054) -!/T +#ifdef W3_T + ELSE + WRITE (NDST,9054) + +#endif END IF ! END IF @@ -979,11 +1037,15 @@ PROGRAM W3GSPL WRITE (NDSM,980) MSPLIT(IY,:) END DO ! -!/O16 CLOSE ( NDSG ) +#ifdef W3_O16 + CLOSE ( NDSG ) +#endif ! -!/O16 OPEN ( NDSG,FILE='ww3.ctl') -!/O16 WRITE (NDSG,985) NX, X0, SX, NY, Y0, SY, NTGRDS -!/O16 CLOSE ( NDSG ) +#ifdef W3_O16 + OPEN ( NDSG,FILE='ww3.ctl') + WRITE (NDSG,985) NX, X0, SX, NY, Y0, SY, NTGRDS + CLOSE ( NDSG ) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 9. End of program @@ -1092,17 +1154,19 @@ PROGRAM W3GSPL ! 980 FORMAT (1X,360I2) ! -!/O16 985 FORMAT ( 'DSET ww3.ww3_gspl'/ & -!/O16 'TITLE WAVEWATCH III grid splitting data'/ & -!/O16 'OPTIONS sequential'/ & -!/O16 'UNDEF -999.9'/ & -!/O16 'XDEF ',I6,' LINEAR ',2F12.5/ & -!/O16 'YDEF ',I6,' LINEAR ',2F12.5/ & -!/O16 'ZDEF 1 LINEAR 1000.00000 1.00000'/ & -!/O16 'TDEF ',I6,' LINEAR 00:00 06JUN1968 1HR'/ & -!/O16 'VARS 1'/ & -!/O16 'MAP 0 99 grid use map '/ & -!/O16 'ENDVARS') +#ifdef W3_O16 + 985 FORMAT ( 'DSET ww3.ww3_gspl'/ & + 'TITLE WAVEWATCH III grid splitting data'/ & + 'OPTIONS sequential'/ & + 'UNDEF -999.9'/ & + 'XDEF ',I6,' LINEAR ',2F12.5/ & + 'YDEF ',I6,' LINEAR ',2F12.5/ & + 'ZDEF 1 LINEAR 1000.00000 1.00000'/ & + 'TDEF ',I6,' LINEAR 00:00 06JUN1968 1HR'/ & + 'VARS 1'/ & + 'MAP 0 99 grid use map '/ & + 'ENDVARS') +#endif ! 965 FORMAT ( '$ -------------------------------------', & '------------------------------- $'/ & @@ -1181,20 +1245,24 @@ PROGRAM W3GSPL ' ERROR IN OPENING FILE ',A/ & ' IOSTAT =',I5/) ! -!/T 9040 FORMAT ( 'TEST W3GSPL: CHECKERBOARD X-Y:',2I8) -!/T 9041 FORMAT ( 'TEST W3GSPL: FILLING CHECKERBOARD TRY:',I3/ & -!/T ' GRID, IGX0, IGXN, IGY0, IGYN, POINTS ') -!/T 9042 FORMAT ( ' ',I6,2(2I8), I8,2X,A) -!/T 9043 FORMAT ( 'TEST W3GSPL: CHECKERBOARD GRIDS:',I4,' (',I4,')') -!/T 9044 FORMAT ( ' SMALLEST SIZE/GRID:',I8,I4) -!/T 9045 FORMAT ( ' SMALLEST NEIGHBOR :',I8,I4) -!/T 9046 FORMAT ( ' GRID',I4', MERGED WITH GRID',I4) -!/T 9047 FORMAT ( ' ',I6,I8) -!/T 9048 FORMAT ( ' GRID',I4', IS ISOLATED, LEFT UNCHANGED') -!/T 9049 FORMAT ( 'TEST W3GSPL: CHECKERBOARD CONSOLIDATED ON',I4,' GRIDS') -! -!/T 9050 FORMAT ( 'TEST W3GSPL',A,': MIN, MAX, STD:',2I8,F10.2) -!/T 9051 FORMAT ( ' ',A,': MIN, MAX, STD:',2I8,F10.2) +#ifdef W3_T + 9040 FORMAT ( 'TEST W3GSPL: CHECKERBOARD X-Y:',2I8) + 9041 FORMAT ( 'TEST W3GSPL: FILLING CHECKERBOARD TRY:',I3/ & + ' GRID, IGX0, IGXN, IGY0, IGYN, POINTS ') + 9042 FORMAT ( ' ',I6,2(2I8), I8,2X,A) + 9043 FORMAT ( 'TEST W3GSPL: CHECKERBOARD GRIDS:',I4,' (',I4,')') + 9044 FORMAT ( ' SMALLEST SIZE/GRID:',I8,I4) + 9045 FORMAT ( ' SMALLEST NEIGHBOR :',I8,I4) + 9046 FORMAT ( ' GRID',I4', MERGED WITH GRID',I4) + 9047 FORMAT ( ' ',I6,I8) + 9048 FORMAT ( ' GRID',I4', IS ISOLATED, LEFT UNCHANGED') + 9049 FORMAT ( 'TEST W3GSPL: CHECKERBOARD CONSOLIDATED ON',I4,' GRIDS') +#endif +! +#ifdef W3_T + 9050 FORMAT ( 'TEST W3GSPL',A,': MIN, MAX, STD:',2I8,F10.2) + 9051 FORMAT ( ' ',A,': MIN, MAX, STD:',2I8,F10.2) +#endif 9052 FORMAT ( 'TEST W3GSPL: STUCK ON ',A,' GRID SIZE') 9053 FORMAT ( ' OUT OF RANGE, PROCESSING (',F6.3,')') 9054 FORMAT ( ' IN RANGE, NO ACTION') @@ -1232,13 +1300,17 @@ SUBROUTINE GRINFO !/ Local parameters !/ INTEGER :: NOCNT, NOCNTM, NOCNTL, NGC, NSEAC -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: SUMSQR LOGICAL :: LEFT, RIGHT, THERE !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRINFO') +#ifdef W3_S + CALL STRACE (IENT, 'GRINFO') +#endif ! ! 1. Initialization ------------------------------------------------- * ! @@ -1345,21 +1417,25 @@ SUBROUTINE GRINFO ! ! 5. Test output ---------------------------------------------------- * ! -!/T1 WRITE (NDST,9000) -!/T1 DO IG=1, NG -!/T1 WRITE (NDST,9001) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & -!/T1 GSTATS(IG)%NXL, GSTATS(IG)%NXH, & -!/T1 GSTATS(IG)%NYL, GSTATS(IG)%NYH -!/T1 END DO -!/T1 WRITE (NDST,9010) MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#ifdef W3_T1 + WRITE (NDST,9000) + DO IG=1, NG + WRITE (NDST,9001) IG, GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & + GSTATS(IG)%NXL, GSTATS(IG)%NXH, & + GSTATS(IG)%NYL, GSTATS(IG)%NYH + END DO + WRITE (NDST,9010) MSTATS%NMIN, MSTATS%NMAX, MSTATS%RSTD +#endif ! RETURN ! ! Formats ! -!/T1 9000 FORMAT ( 'TEST GRINFO: J, STRADLE, NPTS,NXL-H, NYL-H') -!/T1 9001 FORMAT ( ' ',I4,2X,L1,2X,I7,4I5) -!/T1 9010 FORMAT ( 'TEST GRINFO: MIN, MAX, STD:',2I8,F10.2) +#ifdef W3_T1 + 9000 FORMAT ( 'TEST GRINFO: J, STRADLE, NPTS,NXL-H, NYL-H') + 9001 FORMAT ( ' ',I4,2X,L1,2X,I7,4I5) + 9010 FORMAT ( 'TEST GRINFO: MIN, MAX, STD:',2I8,F10.2) +#endif ! !/ End of GRINFO ----------------------------------------------------- / !/ @@ -1397,12 +1473,16 @@ SUBROUTINE GRTRIM !/ Local parameters !/ INTEGER :: ITARG, ITL, IPTS, MX, MY, ICIRC, NWDTH -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: MASK(NY,NX) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRTRIM') +#ifdef W3_S + CALL STRACE (IENT, 'GRTRIM') +#endif ! ITARG = NSEA / NG ! @@ -1573,13 +1653,17 @@ SUBROUTINE GRFILL ( ND ) NLEFT, NRIGHT, NXL, NXH, NYL, NYH INTEGER :: NXYOFF = 3 INTEGER :: IIX(NSEA), IIY(NSEA), ISEA, NSEAL -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif LOGICAL :: DONE(NG), MASK(NY,NX), FLOST(NG), & XFL(NX), YFL(NY) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRFILL') +#ifdef W3_S + CALL STRACE (IENT, 'GRFILL') +#endif ! ! 1. Loop to assure all reassigned ---------------------------------- * ! @@ -1622,7 +1706,9 @@ SUBROUTINE GRFILL ( ND ) ! DONE(IG) = .TRUE. ! -!/T2 WRITE (NDST,9030) IG, J, NMIN +#ifdef W3_T2 + WRITE (NDST,9030) IG, J, NMIN +#endif ! ! 4. Loop for halos per grid ---------------------------------------- * ! @@ -1681,7 +1767,9 @@ SUBROUTINE GRFILL ( ND ) IF ( MSPLIT(IY,IX) .EQ. -1 ) NLEFT = NLEFT + 1 END DO ! -!/T2 WRITE (NDST,9070) NITT, NLEFT +#ifdef W3_T2 + WRITE (NDST,9070) NITT, NLEFT +#endif ! ! 7.b No point left, exit loop ! @@ -1764,9 +1852,11 @@ SUBROUTINE GRFILL ( ND ) 1001 FORMAT ( ' MAP OUTPUT FOR GRID',I3,' AND X AND Y RANGE :',4I6/) 1002 FORMAT ( ' ',60I2) ! -!/T2 9030 FORMAT ( 'TEST GRFILL: PROCESSING GRID',I5,' (',I5,')',I8) -!/T2 9060 FORMAT ( 'TEST GRFILL: GRID, HALO, NADD :',I5,I2,I8) -!/T2 9070 FORMAT ( 'TEST GRFILL: NITT, NLEFT :',2I6) +#ifdef W3_T2 + 9030 FORMAT ( 'TEST GRFILL: PROCESSING GRID',I5,' (',I5,')',I8) + 9060 FORMAT ( 'TEST GRFILL: GRID, HALO, NADD :',I5,I2,I8) + 9070 FORMAT ( 'TEST GRFILL: NITT, NLEFT :',2I6) +#endif ! !/ End of GRFILL ----------------------------------------------------- / !/ @@ -1798,12 +1888,16 @@ SUBROUTINE GRLOST !/ Local parameters !/ INTEGER :: IX, IY, IOFF, JJX, JX, JY, IG, I -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: IFOUND(-1:NG) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRLOST') +#ifdef W3_S + CALL STRACE (IENT, 'GRLOST') +#endif ! ! 1. Loop over all grid points -------------------------------------- * ! @@ -1894,11 +1988,15 @@ SUBROUTINE GRSQRG !/ Local parameters !/ INTEGER :: MX, MY -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRSQRG') +#ifdef W3_S + CALL STRACE (IENT, 'GRSQRG') +#endif ! ! 1. Loop over grids ------------------------------------------------ * ! @@ -1998,11 +2096,15 @@ SUBROUTINE GRSNGL ( OK ) !/ INTEGER :: NX0, NXN, IXL, IXH, COUNT(-1:NG), & INEW1, INEW2, INEW -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRSNGL') +#ifdef W3_S + CALL STRACE (IENT, 'GRSNGL') +#endif ! ! 1. Set up looping ------------------------------------------------- * ! @@ -2043,14 +2145,18 @@ SUBROUTINE GRSNGL ( OK ) ! IF ( COUNT(IG) .LE. 2 ) THEN ! -!/T3 WRITE (NDST,9040) IX, IY, IG +#ifdef W3_T3 + WRITE (NDST,9040) IX, IY, IG +#endif ! INEW1 = -1 INEW2 = -1 ! DO J=1, NG IF ( COUNT(J) .GE. 2 ) THEN -!/T3 WRITE (NDST,9041) J +#ifdef W3_T3 + WRITE (NDST,9041) J +#endif IF ( INEW1 .EQ. -1 ) THEN INEW1 = J ELSE @@ -2063,10 +2169,14 @@ SUBROUTINE GRSNGL ( OK ) IF ( INEW1 .EQ. -1 ) THEN INEW = -1 OK = .FALSE. -!/T3 WRITE (NDST,9043) +#ifdef W3_T3 + WRITE (NDST,9043) +#endif ELSE IF ( INEW2 .EQ. -1 ) THEN INEW = INEW1 -!/T3 WRITE (NDST,9042) INEW +#ifdef W3_T3 + WRITE (NDST,9042) INEW +#endif ELSE IF ( GSTATS(INEW1)%NPTS .GT. & GSTATS(INEW2)%NPTS ) THEN @@ -2074,7 +2184,9 @@ SUBROUTINE GRSNGL ( OK ) ELSE INEW = INEW1 END IF -!/T3 WRITE (NDST,9042) INEW +#ifdef W3_T3 + WRITE (NDST,9042) INEW +#endif END IF ! MSPLIT(IY,IX) = INEW @@ -2093,10 +2205,12 @@ SUBROUTINE GRSNGL ( OK ) ! ! Formats ! -!/T3 9040 FORMAT ( 'TEST GRSNGL: POINT FOUND, IX, IY, IG:',2I5,I4) -!/T3 9041 FORMAT ( ' CANDIDATE GRID :',10X,I4) -!/T3 9042 FORMAT ( ' GRID USED :',10X,I4) -!/T3 9043 FORMAT ( ' GRID LEFT UNDIFINED') +#ifdef W3_T3 + 9040 FORMAT ( 'TEST GRSNGL: POINT FOUND, IX, IY, IG:',2I5,I4) + 9041 FORMAT ( ' CANDIDATE GRID :',10X,I4) + 9042 FORMAT ( ' GRID USED :',10X,I4) + 9043 FORMAT ( ' GRID LEFT UNDIFINED') +#endif ! !/ End of GRSNGL ----------------------------------------------------- / !/ @@ -2148,7 +2262,9 @@ SUBROUTINE GRSEPA ( OK, FRAC ) INTEGER :: IPAVG, IPCHCK, ID, IPTOT, IX, IY, & IXL, IYL, IDL, JX, JY, KY, IPT, & IXH, IYH, I, J, K, L, IMIN, LMIN -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: GMASK(NY,NX), IIX(NSEA), IIY(NSEA) INTEGER, ALLOCATABLE :: PMAP(:), INGRD(:) LOGICAL :: PREV @@ -2156,12 +2272,16 @@ SUBROUTINE GRSEPA ( OK, FRAC ) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRSEPA') +#ifdef W3_S + CALL STRACE (IENT, 'GRSEPA') +#endif ! IPAVG = NINT ( REAL(NSEA) / REAL(NG) ) IPCHCK = NINT ( FRAC * REAL(NSEA) / REAL(NG) ) ! -!/T4 WRITE (NDST,9000) IPAVG, IPCHCK +#ifdef W3_T4 + WRITE (NDST,9000) IPAVG, IPCHCK +#endif ! ! 1. Loop over grids ------------------------------------------------ * ! @@ -2170,7 +2290,9 @@ SUBROUTINE GRSEPA ( OK, FRAC ) GMASK = 0 ID = 0 ! -!/T4 WRITE (NDST,9010) IG +#ifdef W3_T4 + WRITE (NDST,9010) IG +#endif ! ! 2. Find all parts ------------------------------------------------- * ! 2.a First loop, partial parts @@ -2214,7 +2336,9 @@ SUBROUTINE GRSEPA ( OK, FRAC ) ! 2.b Grid too small, do not cut ! IF ( IPTOT .LE. IPAVG ) THEN -!/T4 WRITE (NDST,9020) IPTOT, IPAVG +#ifdef W3_T4 + WRITE (NDST,9020) IPTOT, IPAVG +#endif CYCLE END IF ! @@ -2287,14 +2411,18 @@ SUBROUTINE GRSEPA ( OK, FRAC ) ! 3. Grid is contiguous --------------------------------------------- * ! IF ( ID .EQ. 1 ) THEN -!/T4 WRITE (NDST,9030) IG +#ifdef W3_T4 + WRITE (NDST,9030) IG +#endif DEALLOCATE ( PMAP ) CYCLE END IF ! ! 4. Grid is split, get stats --------------------------------------- * ! -!/T4 WRITE (NDST,9040) IG +#ifdef W3_T4 + WRITE (NDST,9040) IG +#endif ! ! 4.a Construct final map for grid ! @@ -2352,9 +2480,11 @@ SUBROUTINE GRSEPA ( OK, FRAC ) END IF END DO ! -!/T4 DO J=1, ID -!/T4 WRITE (NDST,9041) J, INGRD(J), FLNEXT(J) -!/T4 END DO +#ifdef W3_T4 + DO J=1, ID + WRITE (NDST,9041) J, INGRD(J), FLNEXT(J) + END DO +#endif ! ! 5. Grid large enough, find smallest part -------------------------- * ! @@ -2369,20 +2499,26 @@ SUBROUTINE GRSEPA ( OK, FRAC ) END DO ! IF ( LMIN .EQ. 0 ) THEN -!/T4 WRITE (NDST,9050) +#ifdef W3_T4 + WRITE (NDST,9050) +#endif DEALLOCATE ( INGRD, FLNEXT ) CYCLE END IF ! IF ( IMIN .GT. IPCHCK ) THEN -!/T4 WRITE (NDST,9051) +#ifdef W3_T4 + WRITE (NDST,9051) +#endif DEALLOCATE ( INGRD, FLNEXT ) CYCLE END IF ! ! 6. Part to cut has been identified -------------------------------- * ! -!/T4 WRITE (NDST,9060) LMIN +#ifdef W3_T4 + WRITE (NDST,9060) LMIN +#endif ! DO JX=1, NX DO JY=1, NY @@ -2401,15 +2537,17 @@ SUBROUTINE GRSEPA ( OK, FRAC ) ! ! Formats ! -!/T4 9000 FORMAT ( 'TEST GRSEPA: IPAVG/CHCK:',2I8) -!/T4 9010 FORMAT ( 'TEST GRSEPA: WORKING ON GRID'I4) -!/T4 9020 FORMAT ( ' GRID TOO SMALL TO CUT',2I8) -!/T4 9030 FORMAT ( 'TEST GRSEPA: GRID',I4,' IS CONTIGUOUS') -!/T4 9040 FORMAT ( 'TEST GRSEPA: GRID',I4,' CONTAINS PARTS') -!/T4 9041 FORMAT ( ' PART, SIZE, NEIGHBOUR:',I4,I8,L4) -!/T4 9050 FORMAT ( ' NO PART NEXT TO OTHER') -!/T4 9051 FORMAT ( ' NO PART SMALL ENOUGH') -!/T4 9060 FORMAT ( ' CUTTING PART',I4) +#ifdef W3_T4 + 9000 FORMAT ( 'TEST GRSEPA: IPAVG/CHCK:',2I8) + 9010 FORMAT ( 'TEST GRSEPA: WORKING ON GRID'I4) + 9020 FORMAT ( ' GRID TOO SMALL TO CUT',2I8) + 9030 FORMAT ( 'TEST GRSEPA: GRID',I4,' IS CONTIGUOUS') + 9040 FORMAT ( 'TEST GRSEPA: GRID',I4,' CONTAINS PARTS') + 9041 FORMAT ( ' PART, SIZE, NEIGHBOUR:',I4,I8,L4) + 9050 FORMAT ( ' NO PART NEXT TO OTHER') + 9051 FORMAT ( ' NO PART SMALL ENOUGH') + 9060 FORMAT ( ' CUTTING PART',I4) +#endif ! !/ End of GRSEPA ----------------------------------------------------- / !/ @@ -2451,13 +2589,19 @@ SUBROUTINE GRFSML INTEGER :: NSMALL, IGMIN(NG), NNEXT, JG, IGADD, & IGTEST, FREE(NG), NFREE, NBIG, IGB, & MX, MY, NX0, NXN, NY0, NYN, JX -!/T5 INTEGER :: NXNT -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_T5 + INTEGER :: NXNT +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif CHARACTER(LEN=1) :: NEXTTO(0:NG,0:NG), TEMP(NG) !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRFSML') +#ifdef W3_S + CALL STRACE (IENT, 'GRFSML') +#endif ! ! 1. Find small(s) -------------------------------------------------- * ! @@ -2472,7 +2616,9 @@ SUBROUTINE GRFSML END IF END DO ! -!/T5 WRITE (NDST,9010) NSMALL, IGMIN(:NSMALL) +#ifdef W3_T5 + WRITE (NDST,9010) NSMALL, IGMIN(:NSMALL) +#endif ! ! 2. Find neighbours ------------------------------------------------ * ! @@ -2500,11 +2646,13 @@ SUBROUTINE GRFSML NEXTTO(IG,IG) = '-' END DO ! -!/T5 WRITE (NDST,9020) -!/T5 DO IG=1, NG -!/T5 TEMP = NEXTTO(IG,1:) -!/T5 WRITE (NDST,9021) IG, TEMP -!/T5 END DO +#ifdef W3_T5 + WRITE (NDST,9020) + DO IG=1, NG + TEMP = NEXTTO(IG,1:) + WRITE (NDST,9021) IG, TEMP + END DO +#endif ! ! 3. Loop over small grids ------------------------------------------ * ! @@ -2513,7 +2661,9 @@ SUBROUTINE GRFSML ! DO J=1, NSMALL ! -!/T5 WRITE (NDST,9030) IGMIN(J) +#ifdef W3_T5 + WRITE (NDST,9030) IGMIN(J) +#endif ! ! 3.a Find neighbours ! @@ -2531,18 +2681,24 @@ SUBROUTINE GRFSML END IF END DO ! -!/T5 WRITE (NDST,9031) NNEXT +#ifdef W3_T5 + WRITE (NDST,9031) NNEXT +#endif ! ! 3.b No neighbours found, mark as 'not to be processed further' ! IF ( NNEXT .EQ. 0 ) THEN GSTATS(IG)%INSTAT = .FALSE. -!/T5 WRITE (NDST,9032) IG +#ifdef W3_T5 + WRITE (NDST,9032) IG +#endif ELSE ! ! 3.c Check smallest neighbor ! -!/T5 WRITE (NDST,9033) IGADD, IGTEST, IGTEST+INGMIN, NINT(XMEAN) +#ifdef W3_T5 + WRITE (NDST,9033) IGADD, IGTEST, IGTEST+INGMIN, NINT(XMEAN) +#endif ! IF ( IGTEST + INGMIN .LT. NINT(XMEAN) ) THEN ! @@ -2561,17 +2717,23 @@ SUBROUTINE GRFSML ! ! ... Remove grid(s) from stats ! -!/T5 WRITE (NDST,9034) +#ifdef W3_T5 + WRITE (NDST,9034) +#endif ! GSTATS(IG)%INSTAT = .FALSE. -!/T5 WRITE (NDST,9032) IG +#ifdef W3_T5 + WRITE (NDST,9032) IG +#endif NNEXT = 0 DO JG=1, NG IF ( NEXTTO(IGADD,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 END DO IF ( NNEXT .EQ. 1 ) THEN GSTATS(IGADD)%INSTAT = .FALSE. -!/T5 WRITE (NDST,9032) IGADD +#ifdef W3_T5 + WRITE (NDST,9032) IGADD +#endif END IF ! END IF @@ -2582,11 +2744,15 @@ SUBROUTINE GRFSML ! ! 4. Make new grids as needed --------------------------------------- * ! -!/T5 WRITE (NDST,9040) NFREE +#ifdef W3_T5 + WRITE (NDST,9040) NFREE +#endif ! DO J=1, NFREE ! -!/T5 WRITE (NDST,9041) FREE(J) +#ifdef W3_T5 + WRITE (NDST,9041) FREE(J) +#endif ! ! 4.a Find biggest grid ! @@ -2612,16 +2778,24 @@ SUBROUTINE GRFSML IF ( GSTATS(IGB)%STRADLE ) MX = MX + NX ! IF ( MY .GE. MX ) THEN -!/T5 WRITE (NDST,9042) IGB, 'VERTICAL', MX, MY +#ifdef W3_T5 + WRITE (NDST,9042) IGB, 'VERTICAL', MX, MY +#endif NYN = NY0 + MY/2 ELSE -!/T5 WRITE (NDST,9042) IGB, 'HORIZONTAL', MX, MY +#ifdef W3_T5 + WRITE (NDST,9042) IGB, 'HORIZONTAL', MX, MY +#endif NXN = NX0 + MX/2 -!/T5 NXNT = 1 + MOD(NXN-1,NX) +#ifdef W3_T5 + NXNT = 1 + MOD(NXN-1,NX) +#endif END IF -!/T5 WRITE (NDST,9043) GSTATS(IGB)%NXL, GSTATS(IGB)%NXH, & -!/T5 GSTATS(IGB)%NYL, GSTATS(IGB)%NYH, & -!/T5 GSTATS(IGB)%STRADLE, NX0, NXN, NY0, NYN +#ifdef W3_T5 + WRITE (NDST,9043) GSTATS(IGB)%NXL, GSTATS(IGB)%NXH, & + GSTATS(IGB)%NYL, GSTATS(IGB)%NYH, & + GSTATS(IGB)%STRADLE, NX0, NXN, NY0, NYN +#endif ! DO IX=NX0, NXN JX = 1 + MOD(IX-1,NX) @@ -2639,20 +2813,22 @@ SUBROUTINE GRFSML ! ! Formats ! -!/T5 9010 FORMAT ( 'TEST GRFSML:',I2,' SMALL GRIDS:',10I4) -!/T5 9020 FORMAT ( 'TEST GRFSML: NEIGHBOUR MAP PER GRID') -!/T5 9021 FORMAT (2X,I3,2X,120A1) -!/T5 9030 FORMAT ( 'TEST GRFSML: PROCESSING SMALL GRID',I4) -!/T5 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') -!/T5 9032 FORMAT ( ' REMOVED GRID',I4,' FROM STATS') -!/T5 9033 FORMAT ( ' SMALLEST NEIGHBOUR AND SIZE',I4,I6/ & -!/T5 ' SIZE OF COMBINED GRIDS',I8,' (',I8,')') -!/T5 9034 FORMAT ( ' GRIDS TOO LARGE TO MERGE') -!/T5 9040 FORMAT ( 'TEST GRFSML: GENERATING',I3,' NEW GRIDS') -!/T5 9041 FORMAT ( ' MAKING GRID NR.:',I4) -!/T5 9042 FORMAT ( ' SPLITTING GRID',I3,' ',A,', MX,MY:',2I6) -!/T5 9043 FORMAT ( ' OLD RANGE :',4I6,L4/ & -!/T5 ' NEW RANGE :',4I6) +#ifdef W3_T5 + 9010 FORMAT ( 'TEST GRFSML:',I2,' SMALL GRIDS:',10I4) + 9020 FORMAT ( 'TEST GRFSML: NEIGHBOUR MAP PER GRID') + 9021 FORMAT (2X,I3,2X,120A1) + 9030 FORMAT ( 'TEST GRFSML: PROCESSING SMALL GRID',I4) + 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') + 9032 FORMAT ( ' REMOVED GRID',I4,' FROM STATS') + 9033 FORMAT ( ' SMALLEST NEIGHBOUR AND SIZE',I4,I6/ & + ' SIZE OF COMBINED GRIDS',I8,' (',I8,')') + 9034 FORMAT ( ' GRIDS TOO LARGE TO MERGE') + 9040 FORMAT ( 'TEST GRFSML: GENERATING',I3,' NEW GRIDS') + 9041 FORMAT ( ' MAKING GRID NR.:',I4) + 9042 FORMAT ( ' SPLITTING GRID',I3,' ',A,', MX,MY:',2I6) + 9043 FORMAT ( ' OLD RANGE :',4I6,L4/ & + ' NEW RANGE :',4I6) +#endif ! !/ End of GRFSML ----------------------------------------------------- / !/ @@ -2695,7 +2871,9 @@ SUBROUTINE GRFLRG !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GRFLRG') +#ifdef W3_S + CALL STRACE (IENT, 'GRFLRG') +#endif ! ! 1. Find big(s) ---------------------------------------------------- * ! @@ -2710,7 +2888,9 @@ SUBROUTINE GRFLRG END IF END DO ! -!/T6 WRITE (NDST,9010) NBIG, IGMAX(:NBIG) +#ifdef W3_T6 + WRITE (NDST,9010) NBIG, IGMAX(:NBIG) +#endif ! ! 2. Find neighbours ------------------------------------------------ * ! @@ -2738,17 +2918,21 @@ SUBROUTINE GRFLRG NEXTTO(IG,IG) = '-' END DO ! -!/T6 WRITE (NDST,9020) -!/T6 DO IG=1, NG -!/T6 TEMP = NEXTTO(IG,1:) -!/T6 WRITE (NDST,9021) IG, TEMP -!/T6 END DO +#ifdef W3_T6 + WRITE (NDST,9020) + DO IG=1, NG + TEMP = NEXTTO(IG,1:) + WRITE (NDST,9021) IG, TEMP + END DO +#endif ! ! 3. Loop over big grids -------------------------------------------- * ! DO J=1, NBIG ! -!/T6 WRITE (NDST,9030) IGMAX(J) +#ifdef W3_T6 + WRITE (NDST,9030) IGMAX(J) +#endif ! ! 3.a Find neighbours ! @@ -2758,13 +2942,17 @@ SUBROUTINE GRFLRG IF ( NEXTTO(IG,JG) .EQ. 'X' ) NNEXT = NNEXT + 1 END DO ! -!/T6 WRITE (NDST,9031) NNEXT +#ifdef W3_T6 + WRITE (NDST,9031) NNEXT +#endif ! ! 3.b Enough neighbours found, mark as 'not to be processed further' ! IF ( NNEXT .GE. 1 ) THEN GSTATS(IG)%INSTAT = .FALSE. -!/T6 WRITE (NDST,9032) +#ifdef W3_T6 + WRITE (NDST,9032) +#endif ELSE ! ! 3.c Biggest grid is isolated, should split @@ -2783,12 +2971,14 @@ SUBROUTINE GRFLRG 930 FORMAT ( ' *** ERROR GRFLRG: LARGEST GRID IS ISOLATED ***' & ' SPLITTING NOT YET IMPLEMENTED '/) ! -!/T6 9010 FORMAT ( 'TEST GRFLRG:',I2,' BIG GRIDS:',10I4) -!/T6 9020 FORMAT ( 'TEST GRFLRG: NEIGHBOUR MAP PER GRID') -!/T6 9021 FORMAT (2X,I3,2X,120A1) -!/T6 9030 FORMAT ( 'TEST GRFLRG: PROCESSING BIG GRID',I4) -!/T6 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') -!/T6 9032 FORMAT ( ' NO ACTION') +#ifdef W3_T6 + 9010 FORMAT ( 'TEST GRFLRG:',I2,' BIG GRIDS:',10I4) + 9020 FORMAT ( 'TEST GRFLRG: NEIGHBOUR MAP PER GRID') + 9021 FORMAT (2X,I3,2X,120A1) + 9030 FORMAT ( 'TEST GRFLRG: PROCESSING BIG GRID',I4) + 9031 FORMAT ( ' GRID HAS',I3,' NEIGHBOURS') + 9032 FORMAT ( ' NO ACTION') +#endif ! !/ End of GRFLRG ----------------------------------------------------- / !/ @@ -2828,15 +3018,21 @@ SUBROUTINE GR1GRD INTEGER :: NIT, IIT, IXL, IXH, IYL, IYH, NOCNT,& NOCNTM, NOCNTL, JX, JY, ISEA, MX, MY INTEGER :: MTMP2(NY,NX) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: XOFF LOGICAL :: MASK(NY,NX), LEFT, RIGHT, THERE !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'GR1GRD') +#ifdef W3_S + CALL STRACE (IENT, 'GR1GRD') +#endif ! -!/T7 WRITE (NDST,9000) IG +#ifdef W3_T7 + WRITE (NDST,9000) IG +#endif ! ! 1. Set up MTEMP with MAPSTA 0,1,3 for grid ------------------------ * ! @@ -2867,10 +3063,18 @@ SUBROUTINE GR1GRD ! NEEDED TO SET UP A LITTLE WIDER. NOT SURE WHY. NEED TO CHECK WITH ! WMEQL SUBROUTINE. ! -!/PR0 NIT = 0 -!/PR1 NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 -!/UQ NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 -!/UNO NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#ifdef W3_PR0 + NIT = 0 +#endif +#ifdef W3_PR1 + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 1 +#endif +#ifdef W3_UQ + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif +#ifdef W3_UNO + NIT = 1 + NHEXT + ( 1 + INT(DTMAX/DTCFL-0.001) ) * 3 +#endif ! ! 3.b Exand halo ! @@ -2991,14 +3195,18 @@ SUBROUTINE GR1GRD ! END DO ! -!/T7 WRITE (NDST,9040) +#ifdef W3_T7 + WRITE (NDST,9040) +#endif ! ! 5. Recompute grid range ------------------------------------------- * ! Using GSTOLD to store info for modified grid ! -!/T7 WRITE (NDST,9050) GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & -!/T7 GSTATS(IG)%NXL, GSTATS(IG)%NXH, & -!/T7 GSTATS(IG)%NYL, GSTATS(IG)%NYH +#ifdef W3_T7 + WRITE (NDST,9050) GSTATS(IG)%STRADLE, GSTATS(IG)%NPTS, & + GSTATS(IG)%NXL, GSTATS(IG)%NXH, & + GSTATS(IG)%NYL, GSTATS(IG)%NYH +#endif ! GSTOLD(IG)%STRADLE = .FALSE. GSTOLD(IG)%NPTS = 0 @@ -3060,9 +3268,11 @@ SUBROUTINE GR1GRD ! ! ... Make sure outside of grid is 2 or 3 ! -!/T7 WRITE (NDST,9051) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & -!/T7 GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & -!/T7 GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#ifdef W3_T7 + WRITE (NDST,9051) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & + GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & + GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#endif LEFT = .FALSE. RIGHT = .FALSE. ! @@ -3092,9 +3302,11 @@ SUBROUTINE GR1GRD GSTOLD(IG)%STRADLE = .TRUE. END IF ! -!/T7 WRITE (NDST,9052) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & -!/T7 GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & -!/T7 GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#ifdef W3_T7 + WRITE (NDST,9052) GSTOLD(IG)%STRADLE, GSTOLD(IG)%NPTS, & + GSTOLD(IG)%NXL, GSTOLD(IG)%NXH, & + GSTOLD(IG)%NYL, GSTOLD(IG)%NYH +#endif ! ! 6. Extract reduced grid data -------------------------------------- * ! @@ -3112,8 +3324,10 @@ SUBROUTINE GR1GRD XOFF = 360. * REAL ( NINT((PGRID(IG)%X0+0.5*REAL(MX-1)*SX)/360.) ) PGRID(IG)%X0 = PGRID(IG)%X0 - XOFF ! -!/T7 WRITE (NDST,9060) PGRID(IG)%NX, PGRID(IG)%NY, PGRID(IG)%NSEA, & -!/T7 PGRID(IG)%X0, PGRID(IG)%Y0, PGRID(IG)%SX, PGRID(IG)%SY +#ifdef W3_T7 + WRITE (NDST,9060) PGRID(IG)%NX, PGRID(IG)%NY, PGRID(IG)%NSEA, & + PGRID(IG)%X0, PGRID(IG)%Y0, PGRID(IG)%SX, PGRID(IG)%SY +#endif ! ALLOCATE ( PGRID(IG)%ZBIN(MX,MY) , & PGRID(IG)%OBSX(MX,MY) , & @@ -3145,14 +3359,16 @@ SUBROUTINE GR1GRD ! ! Formats ! -!/T7 9000 FORMAT ( 'TEST GR1GRD: EXTRACTING GRID:',I4) -!/T7 9040 FORMAT ( ' MASK ON FULL GRID COMPUTED') -!/T7 9050 FORMAT ( 'TEST GR1GRD: GRID STATS :'/ & -!/T7 ' GRID MAP :',L2,2X,I8,4I5) -!/T7 9051 FORMAT ( ' HALO ADDED :',L2,2X,I8,4I5) -!/T7 9052 FORMAT ( ' BORDER ADDED :',L2,2X,I8,4I5) -!/T7 9060 FORMAT ( 'TEST GR1GRD: EXTRACTED GRID :',2I5,I8/ & -!/T7 ' ',4E12.5) +#ifdef W3_T7 + 9000 FORMAT ( 'TEST GR1GRD: EXTRACTING GRID:',I4) + 9040 FORMAT ( ' MASK ON FULL GRID COMPUTED') + 9050 FORMAT ( 'TEST GR1GRD: GRID STATS :'/ & + ' GRID MAP :',L2,2X,I8,4I5) + 9051 FORMAT ( ' HALO ADDED :',L2,2X,I8,4I5) + 9052 FORMAT ( ' BORDER ADDED :',L2,2X,I8,4I5) + 9060 FORMAT ( 'TEST GR1GRD: EXTRACTED GRID :',2I5,I8/ & + ' ',4E12.5) +#endif ! !/ End of GR1GRD ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_multi.ftn b/model/src/ww3_multi.F90 similarity index 82% rename from model/ftn/ww3_multi.ftn rename to model/src/ww3_multi.F90 index 90134bb1a..ded819b37 100644 --- a/model/ftn/ww3_multi.ftn +++ b/model/src/ww3_multi.F90 @@ -83,7 +83,9 @@ PROGRAM W3MLTI !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -91,9 +93,13 @@ PROGRAM W3MLTI INTEGER :: I, MPI_COMM = -99 INTEGER, ALLOCATABLE :: TEND(:,:) LOGICAL :: FLGNML -!/MPI INTEGER :: IERR_MPI -!/MPI LOGICAL :: FLHYBR = .FALSE. -!/OMPH INTEGER :: THRLEV +#ifdef W3_MPI + INTEGER :: IERR_MPI + LOGICAL :: FLHYBR = .FALSE. +#endif +#ifdef W3_OMPH + INTEGER :: THRLEV +#endif !/ !/ ------------------------------------------------------------------- / ! 0. Initialization necessary for driver @@ -101,23 +107,33 @@ PROGRAM W3MLTI ! ! 0.b MPI environment: Here, we use MPI_COMM_WORLD ! -!/OMPH FLHYBR = .TRUE. -!/OMPH ! For hybrid MPI-OpenMP specify required thread level: -!/OMPH IF( FLHYBR ) THEN -!/OMPH CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) -!/OMPH ELSE -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/OMPH ENDIF -!/MPI MPI_COMM = MPI_COMM_WORLD -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_OMPH + FLHYBR = .TRUE. + ! For hybrid MPI-OpenMP specify required thread level: + IF( FLHYBR ) THEN + CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) + ELSE +#endif +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) +#endif +#ifdef W3_OMPH + ENDIF +#endif +#ifdef W3_MPI + MPI_COMM = MPI_COMM_WORLD + CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! ! 0.c Identifying output to "screen" unit ! IF ( IMPROC .EQ. NMPSCR ) WRITE (*,900) -!/OMPH IF ( IMPROC .EQ. NMPSCR ) WRITE (*,905) & -!/OMPH MPI_THREAD_FUNNELED, THRLEV +#ifdef W3_OMPH + IF ( IMPROC .EQ. NMPSCR ) WRITE (*,905) & + MPI_THREAD_FUNNELED, THRLEV +#endif ! !/ ------------------------------------------------------------------- / ! 1. Initialization of all wave models / grids @@ -170,16 +186,20 @@ PROGRAM W3MLTI ! IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) ! -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! ! Formats ! 900 FORMAT (/15X,' *** WAVEWATCH III Multi-grid shell *** '/ & 15X,'================================================='/) -!/OMPH 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & -!/OMPH ' Requested: ', I2/ & -!/OMPH ' Provided: ', I2/ ) +#ifdef W3_OMPH + 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & + ' Requested: ', I2/ & + ' Provided: ', I2/ ) +#endif ! 999 FORMAT(//' End of program '/ & ' ========================================'/ & diff --git a/model/ftn/ww3_ounf.ftn b/model/src/ww3_ounf.F90 similarity index 72% rename from model/ftn/ww3_ounf.ftn rename to model/src/ww3_ounf.F90 index d94c81ed5..73da7347c 100644 --- a/model/ftn/ww3_ounf.ftn +++ b/model/src/ww3_ounf.F90 @@ -144,18 +144,24 @@ PROGRAM W3OUNF USE W3ADATMD, ONLY: W3NAUX, W3SETA USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STR_TO_UPPER -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD USE W3IOGRMD, ONLY: W3IOGR USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD, W3FLGRDFLAG USE W3INITMD, ONLY: WWVER, SWITCHES USE W3ODATMD, ONLY: NAPROC, NOSWLL, PTMETH, PTFCUT -!/DEBUG USE W3ODATMD, only : IAPROC +#ifdef W3_DEBUG + USE W3ODATMD, only : IAPROC +#endif !/ USE W3GDATMD USE W3WDATMD, ONLY: TIME, WLV, ICE, ICEH, ICEF, BERG, & UST, USTDIR, RHOAIR -!/SETUP USE W3WDATMD, ONLY: ZETA_SETUP +#ifdef W3_SETUP + USE W3WDATMD, ONLY: ZETA_SETUP +#endif USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & THS, FP0, THP0, DTDYN, FCUT, & ABA, ABD, UBA, UBD, SXX, SYY, SXY, USERO, & @@ -185,7 +191,9 @@ PROGRAM W3OUNF ! USE NETCDF -!/SMC USE W3SMCOMD, SMCNOVAL=>NOVAL +#ifdef W3_SMC + USE W3SMCOMD, SMCNOVAL=>NOVAL +#endif IMPLICIT NONE @@ -209,7 +217,9 @@ PROGRAM W3OUNF ! INTEGER, ALLOCATABLE :: TABIPART(:), NCIDS(:,:,:) ! -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! REAL :: DTREQ, DTEST ! @@ -221,7 +231,9 @@ PROGRAM W3OUNF VECTOR, TOGETHER, FLGNML, FLGFC LOGICAL :: MAPSTAOUT = .TRUE. LOGICAL :: SMCGRD = .FALSE. -!/RTD LOGICAL :: RTDL = .FALSE. +#ifdef W3_RTD + LOGICAL :: RTDL = .FALSE. +#endif INTEGER :: TVARTYPE = NF90_DOUBLE CHARACTER(LEN=32) :: EPOCH_ISO @@ -251,7 +263,9 @@ PROGRAM W3OUNF NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3OUNF') +#ifdef W3_S + CALL STRACE (IENT, 'W3OUNF') +#endif ! WRITE (NDSO,900) ! @@ -265,17 +279,21 @@ PROGRAM W3OUNF CALL W3IOGR ( 'READ', NDSM ) WRITE (NDSO,920) GNAME ! -!/RTD ! Is the grid really rotated? -!/RTD IF ( Polat < 90. ) RTDL = .True. -!/RTD ! +#ifdef W3_RTD + ! Is the grid really rotated? + IF ( Polat < 90. ) RTDL = .True. + ! +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Read general data and first fields from file ! -!/DEBUG WRITE (NDSO,*) 'Before FLOGRD(2,1)=', FLOGRD(2,1) -!/DEBUG WRITE (NDSO,*) 'IAPROC=', IAPROC -!/DEBUG WRITE(740+IAPROC,*) 'Calling W3IOGO from ww3_ounf' -!/DEBUG FLUSH(740+IAPROC) +#ifdef W3_DEBUG + WRITE (NDSO,*) 'Before FLOGRD(2,1)=', FLOGRD(2,1) + WRITE (NDSO,*) 'IAPROC=', IAPROC + WRITE(740+IAPROC,*) 'Calling W3IOGO from ww3_ounf' + FLUSH(740+IAPROC) +#endif CALL W3IOGO ( 'READ', NDSOG, IOTEST ) ! WRITE (NDSO,930) @@ -285,10 +303,12 @@ PROGRAM W3OUNF END DO END DO ! -!/SMC IF( GTYPE .EQ. SMCTYPE ) THEN -!/SMC SMCGRD = .TRUE. -!/SMC WRITE (NDSO, *) " Conversion for SMCTYPE:", GTYPE -!/SMC ENDIF +#ifdef W3_SMC + IF( GTYPE .EQ. SMCTYPE ) THEN + SMCGRD = .TRUE. + WRITE (NDSO, *) " Conversion for SMCTYPE:", GTYPE + ENDIF +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 4. Read requests from input file. @@ -328,13 +348,15 @@ PROGRAM W3OUNF NOVAL = NML_FIELD%NOVAL MAPSTAOUT = NML_FIELD%MAPSTA IF(SMCGRD) THEN -!/SMC SMCOTYPE = NML_SMC%TYPE -!/SMC SXO = NML_SMC%SXO -!/SMC SYO = NML_SMC%SYO -!/SMC EXO = NML_SMC%EXO -!/SMC EYO = NML_SMC%EYO -!/SMC CELFAC = NML_SMC%CELFAC -!/SMC SMCNOVAL = NOVAL +#ifdef W3_SMC + SMCOTYPE = NML_SMC%TYPE + SXO = NML_SMC%SXO + SYO = NML_SMC%SYO + EXO = NML_SMC%EXO + EYO = NML_SMC%EYO + CELFAC = NML_SMC%CELFAC + SMCNOVAL = NOVAL +#endif ELSE IX1 = NML_FILE%IX0 IXN = NML_FILE%IXN @@ -395,16 +417,18 @@ PROGRAM W3OUNF CALL NEXTLN ( COMSTR , NDSI , NDSE ) IF(SMCGRD) THEN -!/SMC ! SMC output type (1 or 2) -!/SMC READ (NDSI,*,END=801,ERR=802) SMCOTYPE -!/SMC IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO -!/SMC ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output -!/SMC CALL NEXTLN ( COMSTR , NDSI , NDSE ) -!/SMC READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO, CELFAC -!/SMC ENDIF -!/SMC SMCNOVAL = NOVAL +#ifdef W3_SMC + ! SMC output type (1 or 2) + READ (NDSI,*,END=801,ERR=802) SMCOTYPE + IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO + ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output + CALL NEXTLN ( COMSTR , NDSI , NDSE ) + READ (NDSI,*,END=801,ERR=802) SXO, SYO, EXO, EYO, CELFAC + ENDIF + SMCNOVAL = NOVAL +#endif ELSE READ (NDSI,*,END=801,ERR=802) IX1, IXN, IY1, IYN ENDIF @@ -510,44 +534,48 @@ PROGRAM W3OUNF END IF IF(SMCGRD) THEN -!/SMC WRITE(NDSO, 4100) -!/SMC IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output -!/SMC ALLOCATE(SMCMASK(NSEA)) -!/SMC ALLOCATE(SMCIDX(NSEA)) -!/SMC SMCMASK(:) = .FALSE. -!/SMC CALL SMC_INTERP() -!/SMC SMCNOUT = COUNT(SMCMASK) -!/SMC NXO = SMCNOUT -!/SMC NYO = 1 -!/SMC WRITE(NDSO, 4120) SMCNOUT -!/SMC ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output -!/SMC ! Calculate regridding weights: -!/SMC ALLOCATE(XIDX(NSEA), YIDX(NSEA), XSPAN(NSEA), & -!/SMC YSPAN(NSEA), WTS(NSEA), SMCIDX(NSEA)) -!/SMC CALL SMC_INTERP() -!/SMC WRITE(NDSO, 4110) NXO, NYO, SXO, SYO, DXO, DYO -!/SMC -!/SMC ! Allocate space for coverage array and new MAPSTA array -!/SMC ALLOCATE(COV(NXO,NYO), MAPSMC(NXO,NYO)) -!/SMC ELSE IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) THEN ! Nearest neighbour interpolation -!/SMC CALL READ_SMCINT() -!/SMC ENDIF -!/SMC -!/SMC ! CB: IXN and IXY are calculated by SMC_INTERP for SMC GRID -!/SMC IX1 = 1 -!/SMC IXN = NXO -!/SMC IY1 = 1 -!/SMC IYN = NYO -!/SMC -!/SMC ! Also store NXO and NYO in __local__ RTDNX and RTDNY variables. -!/SMC ! This avoids compilation errors when the RTD switch is enabled -!/SMC ! but the SMC switch is not. TODO: Remove this when C-preprocessor -!/SMC ! is used in preference to switches. -!/SMC RTDNX = NXO -!/SMC RTDNY = NYO -!/SMC -!/SMC!/RTD ! SMC type 3/4 outputs are currently on standard pole grid only -!/SMC!/RTD IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) RTDL = .FALSE. +#ifdef W3_SMC + WRITE(NDSO, 4100) + IF(SMCOTYPE .EQ. 1) THEN ! Flat sea point output + ALLOCATE(SMCMASK(NSEA)) + ALLOCATE(SMCIDX(NSEA)) + SMCMASK(:) = .FALSE. + CALL SMC_INTERP() + SMCNOUT = COUNT(SMCMASK) + NXO = SMCNOUT + NYO = 1 + WRITE(NDSO, 4120) SMCNOUT + ELSE IF(SMCOTYPE .EQ. 2) THEN ! Regular grid output + ! Calculate regridding weights: + ALLOCATE(XIDX(NSEA), YIDX(NSEA), XSPAN(NSEA), & + YSPAN(NSEA), WTS(NSEA), SMCIDX(NSEA)) + CALL SMC_INTERP() + WRITE(NDSO, 4110) NXO, NYO, SXO, SYO, DXO, DYO + + ! Allocate space for coverage array and new MAPSTA array + ALLOCATE(COV(NXO,NYO), MAPSMC(NXO,NYO)) + ELSE IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) THEN ! Nearest neighbour interpolation + CALL READ_SMCINT() + ENDIF + + ! CB: IXN and IXY are calculated by SMC_INTERP for SMC GRID + IX1 = 1 + IXN = NXO + IY1 = 1 + IYN = NYO + + ! Also store NXO and NYO in __local__ RTDNX and RTDNY variables. + ! This avoids compilation errors when the RTD switch is enabled + ! but the SMC switch is not. TODO: Remove this when C-preprocessor + ! is used in preference to switches. + RTDNX = NXO + RTDNY = NYO + +#ifdef W3_RTD + ! SMC type 3/4 outputs are currently on standard pole grid only + IF(SMCOTYPE .EQ. 3 .OR. SMCOTYPE .EQ. 4) RTDL = .FALSE. +#endif +#endif ELSE IX1 = MAX ( IX1 , 1 ) IXN = MIN ( IXN , NX ) @@ -719,23 +747,25 @@ PROGRAM W3OUNF 3940 FORMAT ( ' X range : ',2I7/ & ' Y range : ',2I7) ! -!/SMC 4100 FORMAT (//' SMC grid output :' / & -!/SMC! -!/SMC ' --------------------------------------------------') -!/SMC 4110 FORMAT ( ' SMC to regular lat/lon grid using cell averaging' /& -!/SMC ' Aligned output grid definition: ' / & -!/SMC ' NX, NY : ', 2I8 / & -!/SMC ' X0, Y0 : ', 2F8.3 / & -!/SMC ' DX, DY : ', 2F8.5 ) -!/SMC 4120 FORMAT ( ' Flat seapoint dimensioned SMC output file' / & -!/SMC ' Num seapoints : ',I9 ) -!/SMC! -!/SMC 4130 FORMAT ( ' SMC regridding to regular lat/lon grid.' / & -!/SMC ' Output grid definition: ' / & -!/SMC ' NX, NY : ', 2I8 / & -!/SMC ' X0, Y0 : ', 2F8.3 / & -!/SMC ' DX, DY : ', 2F8.5 / & -!/SMC ' Interpolate ? : ', L ) +#ifdef W3_SMC + 4100 FORMAT (//' SMC grid output :' / & +! + ' --------------------------------------------------') + 4110 FORMAT ( ' SMC to regular lat/lon grid using cell averaging' /& + ' Aligned output grid definition: ' / & + ' NX, NY : ', 2I8 / & + ' X0, Y0 : ', 2F8.3 / & + ' DX, DY : ', 2F8.5 ) + 4120 FORMAT ( ' Flat seapoint dimensioned SMC output file' / & + ' Num seapoints : ',I9 ) +! + 4130 FORMAT ( ' SMC regridding to regular lat/lon grid.' / & + ' Output grid definition: ' / & + ' NX, NY : ', 2I8 / & + ' X0, Y0 : ', 2F8.3 / & + ' DX, DY : ', 2F8.5 / & + ' Interpolate ? : ', L ) +#endif ! 970 FORMAT (/' Generating files '/ & ' --------------------------------------------------') @@ -878,14 +908,20 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY : W3S2XY, UV_TO_MAG_DIR -!/RTD USE W3SERVMD, ONLY : W3THRTN, W3XYRTN, W3EQTOLL +#ifdef W3_RTD + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN, W3EQTOLL +#endif USE W3ARRYMD, ONLY : OUTA2I, PRTBLK USE W3GDATMD, ONLY : SIG, GTYPE, FLAGLL, MAPSTA, MAPST2 USE W3GDATMD, ONLY : NK, UNGTYPE, MAPSF, NTRI, CLGTYPE, RLGTYPE, & XGRD, YGRD, SX, SY, X0, Y0, XYB, TRIGP, USSP_WN -!/RTD ! Rotated pole data from the mod_def file -!/RTD USE W3GDATMD, ONLY : POLAT, POLON, FLAGUNR, AnglD -!/T USE W3ODATMD, ONLY : NDST +#ifdef W3_RTD + ! Rotated pole data from the mod_def file + USE W3GDATMD, ONLY : POLAT, POLON, FLAGUNR, AnglD +#endif +#ifdef W3_T + USE W3ODATMD, ONLY : NDST +#endif USE NETCDF IMPLICIT NONE @@ -918,7 +954,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & MAP(NX+1,NY), MP2(NX+1,NY) ! INTEGER :: DEFLATE=1 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! INTEGER, ALLOCATABLE :: TRIGP2(:,:) ! Make the below allocatable to avoid stack overflow on some machines @@ -926,11 +964,15 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & MXY(:,:), MAPOUT(:,:) ! REAL :: CABS, UABS, MFILLR -!/BT4 REAL, PARAMETER :: LOG2=LOG(2.) +#ifdef W3_BT4 + REAL, PARAMETER :: LOG2=LOG(2.) +#endif ! REAL,DIMENSION(:), ALLOCATABLE :: LON, LAT, FREQ REAL,DIMENSION(:,:), ALLOCATABLE :: LON2D, LAT2D, ANGLD2D -!/RTD REAL,DIMENSION(:,:), ALLOCATABLE :: LON2DEQ, LAT2DEQ +#ifdef W3_RTD + REAL,DIMENSION(:,:), ALLOCATABLE :: LON2DEQ, LAT2DEQ +#endif ! Make the below allocatable to avoid stack overflow on some machines REAL, ALLOCATABLE :: X1(:,:), X2(:,:), XX(:,:), XY(:,:), & XK(:,:,:), XXK(:,:,:), XYK(:,:,:), & @@ -953,7 +995,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! LOGICAL :: FLFRQ, FLDIR, FEXIST, FREMOVE LOGICAL :: CUSTOMFRQ=.FALSE. -!/T LOGICAL :: LTEMP(NGRPP) +#ifdef W3_T + LOGICAL :: LTEMP(NGRPP) +#endif TYPE(META_T) :: META(3) !TYPE(META_T) :: META @@ -961,13 +1005,17 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & !/ ------------------------------------------------------------------- / !/ ! -!/S CALL STRACE (IENT, 'W3EXNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3EXNC') +#endif ! -!/T DO IFI=1, NOGRP -!/T LTEMP = FLG2D(IFI,:) -!/T WRITE (NDST,9000) IFI, LTEMP -!/T END DO -!/T WRITE (NDST,9001) NCTYPE, IX1, IXN, IY1, IYN, VECTOR +#ifdef W3_T + DO IFI=1, NOGRP + LTEMP = FLG2D(IFI,:) + WRITE (NDST,9000) IFI, LTEMP + END DO + WRITE (NDST,9001) NCTYPE, IX1, IXN, IY1, IYN, VECTOR +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. Preparations @@ -978,12 +1026,14 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! arrays allocatable also moves them to the heap and avoids stack ! overflow issues that can occur on some architectures. (Chris Bunney) IF(SMCGRD) THEN -!/SMC ALLOCATE(X1(NXO,NYO), X2(NXO,NYO), XX(NXO,NYO), XY(NXO,NYO)) -!/SMC ALLOCATE(XK(NXO,NYO,NK), XXK(NXO,NYO,NK), XYK(NXO,NYO,NK)) -!/SMC -!/SMC ALLOCATE(MX1(NXO,NYO), MXX(NXO,NYO), MYY(NXO,NYO), & -!/SMC MXY(NXO,NYO), MAPOUT(NXO,NYO)) -!/SMC ALLOCATE(MX1R(NXO,NYO), MXXR(NXO,NYO), MYYR(NXO,NYO), MXYR(NXO,NYO)) +#ifdef W3_SMC + ALLOCATE(X1(NXO,NYO), X2(NXO,NYO), XX(NXO,NYO), XY(NXO,NYO)) + ALLOCATE(XK(NXO,NYO,NK), XXK(NXO,NYO,NK), XYK(NXO,NYO,NK)) + + ALLOCATE(MX1(NXO,NYO), MXX(NXO,NYO), MYY(NXO,NYO), & + MXY(NXO,NYO), MAPOUT(NXO,NYO)) + ALLOCATE(MX1R(NXO,NYO), MXXR(NXO,NYO), MYYR(NXO,NYO), MXYR(NXO,NYO)) +#endif ELSE ALLOCATE(X1(NX+1,NY),X2(NX+1,NY),XX(NX+1,NY),XY(NX+1,NY)) ALLOCATE(XK(NX+1,NY,NK), XXK(NX+1,NY,NK), XYK(NX+1,NY,NK)) @@ -1067,12 +1117,14 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & FNAMENC(S1+1:S1+S4) = TIMEID(1:S4) ! -!/SMC! -!/SMC!--- Update MAPSMC for SMC type 2 output. This needs to be -!/SMC! done at each timestep as MAPSTA could change if there -!/SMC! are water level or ice input chagnes. -!/SMC! -!/SMC IF( SMCGRD .AND. (SMCOTYPE .EQ. 2) ) CALL MAPSTA_SMC() +#ifdef W3_SMC +! +!--- Update MAPSMC for SMC type 2 output. This needs to be +! done at each timestep as MAPSTA could change if there +! are water level or ice input chagnes. +! + IF( SMCGRD .AND. (SMCOTYPE .EQ. 2) ) CALL MAPSTA_SMC() +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Loop over output fields. @@ -1099,7 +1151,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (I1.EQ.0) I1=IFI IF (J1.EQ.0) J1=IFJ FORMF = '(1X,32I5)' -!/T WRITE (NDST,9020) IDOUT(IFI,IFJ) +#ifdef W3_T + WRITE (NDST,9020) IDOUT(IFI,IFJ) +#endif ! ! 2.1 Set output arrays and parameters ! @@ -1115,8 +1169,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! Surface current ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN !! Note - CX and CY read in from .ww3 file are X-Y vectors -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX(1:NSEA), CY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX(1:NSEA), CY(1:NSEA), AnglD) +#endif ! IF( .NOT. VECTOR ) THEN CALL UV_TO_MAG_DIR(CX(1:NSEA), CY(1:NSEA), NSEA, & @@ -1130,8 +1186,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! Wind ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN !! Note - UA and UD read in from .ww3 file are UX,UY -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA(1:NSEA), UD(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA(1:NSEA), UD(1:NSEA), AnglD) +#endif ! IF( .NOT. VECTOR ) THEN CALL UV_TO_MAG_DIR(UA(1:NSEA), UD(1:NSEA), NSEA, & @@ -1162,12 +1220,16 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! Atmospheric momentum ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN !! Note - TAUA and TAUADIR read in from .ww3 file are TAUAX,TAUAY -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUA(1:NSEA), TAUADIR(1:NSEA), AnglD) +#endif IF( SMCGRD ) THEN -!/SMC CALL W3S2XY_SMC( TAUA (1:NSEA), XX ) -!/SMC CALL W3S2XY_SMC( TAUADIR(1:NSEA), XY ) +#ifdef W3_SMC + CALL W3S2XY_SMC( TAUA (1:NSEA), XX ) + CALL W3S2XY_SMC( TAUADIR(1:NSEA), XY ) +#endif ELSE ! IF(SMCGRD) CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUA(1:NSEA) & , MAPSF, XX ) @@ -1179,26 +1241,34 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! Air density ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN IF( SMCGRD ) THEN -!/SMC CALL W3S2XY_SMC(RHOAIR, X1) +#ifdef W3_SMC + CALL W3S2XY_SMC(RHOAIR, X1) +#endif ELSE CALL W3S2XY ( NSEA, NSEA, NX+1, NY, RHOAIR, MAPSF, X1 ) ENDIF ! -!/BT4 ! Krumbein phi scale -!/BT4 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN -!/BT4 CALL S2GRID(SED_D50, X1) -!/BT4 WHERE ( X1.NE.UNDEF) X1 = -LOG(X1/0.001)/LOG2 -!/BT4 NFIELD=1 +#ifdef W3_BT4 + ! Krumbein phi scale + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10 ) THEN + CALL S2GRID(SED_D50, X1) + WHERE ( X1.NE.UNDEF) X1 = -LOG(X1/0.001)/LOG2 + NFIELD=1 +#endif ! -!/IS2 ! Ice thickness -!/IS2 ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN -!/IS2 CALL S2GRID(ICEH(1:NSEA), X1) -!/IS2 NFIELD=1 +#ifdef W3_IS2 + ! Ice thickness + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 11 ) THEN + CALL S2GRID(ICEH(1:NSEA), X1) + NFIELD=1 +#endif ! -!/IS2 ! Maximum ice floe diameter -!/IS2 ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN -!/IS2 CALL S2GRID(ICEF(1:NSEA), X1) -!/IS2 NFIELD=1 +#ifdef W3_IS2 + ! Maximum ice floe diameter + ELSE IF (IFI .EQ. 1 .AND. IFJ .EQ. 12 ) THEN + CALL S2GRID(ICEF(1:NSEA), X1) + NFIELD=1 +#endif ! Significant wave height ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN @@ -1227,8 +1297,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave mean direction ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#endif CALL S2GRID(THM, X1, .TRUE.) ! IF( SMCGRD ) THEN @@ -1248,8 +1320,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Peak direction ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#endif CALL S2GRID(THP0, X1, .TRUE.) ! IF( SMCGRD ) THEN !!/SMC CALL W3S2XY_SMC( THP0, X1, .TRUE. ) @@ -1309,7 +1383,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! Mean wave number ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 19 ) THEN IF( SMCGRD ) THEN -!/SMC CALL W3S2XY_SMC( WNMEAN, X1 ) +#ifdef W3_SMC + CALL W3S2XY_SMC( WNMEAN, X1 ) +#endif ELSE CALL W3S2XY ( NSEA, NSEA, NX+1, NY, WNMEAN, MAPSF, X1 ) END IF @@ -1333,8 +1409,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & I1F=E3DF(2,2) I2F=E3DF(3,2) DO IK=I1F,I2F -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH1M(:,IK), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH1M(:,IK), AnglD, .FALSE.) +#endif CALL S2GRID(TH1M(:,IK), XX) XK(:,:,IK)=XX END DO @@ -1357,8 +1435,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & I1F=E3DF(2,4) I2F=E3DF(3,4) DO IK=I1F,I2F -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH2M(:,IK), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, TH2M(:,IK), AnglD, .FALSE.) +#endif CALL S2GRID(TH2M(:,IK), XX) XK(:,:,IK)=XX END DO @@ -1399,8 +1479,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Partition wave mean direction ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) +#endif CALL S2GRID(PDIR(:,IPART), X1, .TRUE.) ! IF( SMCGRD ) THEN !!/SMC CALL W3S2XY_SMC( PDIR(:,IPART), X1, .TRUE. ) @@ -1423,8 +1505,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Partition peak direction ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) +#endif CALL S2GRID(PTHP0(:,IPART), X1, .TRUE.) ! IF( SMCGRD ) THEN !!/SMC CALL W3S2XY_SMC( PTHP0(:,IPART), X1, .TRUE. ) @@ -1488,8 +1572,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & USTDIR(ISEA)=UNDEF END IF END DO -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST(1:NSEA), USTDIR(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST(1:NSEA), USTDIR(1:NSEA), AnglD) +#endif CALL S2GRID(UST(1:NSEA), XX) CALL S2GRID(USTDIR(1:NSEA), XY) !! Commented out unnecessary statements below for time being @@ -1528,8 +1614,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave supported wind stress ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 5 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX(1:NSEA), TAUWIY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX(1:NSEA), TAUWIY(1:NSEA), AnglD) +#endif CALL S2GRID(TAUWIX(1:NSEA), XX) CALL S2GRID(TAUWIY(1:NSEA), XY) @@ -1552,8 +1640,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave to wind stress ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 6 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX(1:NSEA), TAUWNY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX(1:NSEA), TAUWNY(1:NSEA), AnglD) +#endif CALL S2GRID(TAUWNX(1:NSEA), XX) CALL S2GRID(TAUWNY(1:NSEA), XY) NFIELD=2 @@ -1580,8 +1670,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Radiation stress ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 1 ) THEN -!/RTD ! Radition stress components are always left on rotated pole -!/RTD ! at present - need to confirm how to de-rotate +#ifdef W3_RTD + ! Radition stress components are always left on rotated pole + ! at present - need to confirm how to de-rotate +#endif CALL S2GRID(SXX(1:NSEA), X1) CALL S2GRID(SYY(1:NSEA), X2) @@ -1590,8 +1682,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave to ocean stress ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 2 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX(1:NSEA), TAUOY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX(1:NSEA), TAUOY(1:NSEA), AnglD) +#endif CALL S2GRID(TAUOX(1:NSEA), XX) CALL S2GRID(TAUOY(1:NSEA), XY) NFIELD=2 @@ -1610,8 +1704,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Stokes transport ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 5 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX(1:NSEA), TUSY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX(1:NSEA), TUSY(1:NSEA), AnglD) +#endif CALL S2GRID(TUSX(1:NSEA), XX) CALL S2GRID(TUSY(1:NSEA), XY) ! X1, X2 will not be output when NFIELD == 2 @@ -1629,8 +1725,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! TUSX(ISEA) = CABS ! END DO !IF( SMCGRD ) THEN -!/SMC !CALL W3S2XY_SMC( TUSX(:), X1 ) -!/SMC !CALL W3S2XY_SMC( TUSY(:), X2 ) ! TODO: CHRISB: TUSY is in degrees....W3S2XY_SMC expects radians... +#ifdef W3_SMC + !CALL W3S2XY_SMC( TUSX(:), X1 ) + !CALL W3S2XY_SMC( TUSY(:), X2 ) ! TODO: CHRISB: TUSY is in degrees....W3S2XY_SMC expects radians... +#endif !ELSE ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSX,MAPSF, X1 ) ! CALL W3S2XY ( NSEA, NSEA, NX+1, NY,TUSY,MAPSF, X2 ) @@ -1643,8 +1741,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & USSX(ISEA)=MAX(-0.9998,MIN(0.9998,USSX(ISEA))) USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) END DO -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX(1:NSEA), USSY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX(1:NSEA), USSY(1:NSEA), AnglD) +#endif CALL S2GRID(USSX(1:NSEA), XX) CALL S2GRID(USSY(1:NSEA), XY) !! Commented out unnecessary statements below for time being @@ -1678,8 +1778,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & I1F=US3DF(2) I2F=US3DF(3) DO IK= I1F,I2F -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, US3D(:,IK), US3D(:,NK+IK), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, US3D(:,IK), US3D(:,NK+IK), AnglD) +#endif CALL S2GRID(US3D(:,IK), XX) CALL S2GRID(US3D(:,NK+IK), XY) XXK(:,:,IK)=XX @@ -1706,8 +1808,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave to sea ice stress ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 10 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUICE(1:NSEA,1), TAUICE(1:NSEA,2), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUICE(1:NSEA,1), TAUICE(1:NSEA,2), AnglD) +#endif CALL S2GRID(TAUICE(1:NSEA,1), XX) CALL S2GRID(TAUICE(1:NSEA,2), XY) NFIELD=2 @@ -1731,8 +1835,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & I1F=1 I2F=USSPF(2) DO IK= I1F,I2F -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSP(:,IK), USSP(:,NK+IK), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSP(:,IK), USSP(:,NK+IK), AnglD) +#endif CALL S2GRID(USSP(:,IK), XX) CALL S2GRID(USSP(:,NK+IK), XY) XXK(:,:,IK) = XX @@ -1741,11 +1847,15 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Total momentum to the ocean ELSE IF ( IFI .EQ. 6 .AND. IFJ .EQ. 13 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX(1:NSEA), TAUOCY(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX(1:NSEA), TAUOCY(1:NSEA), AnglD) +#endif IF( SMCGRD ) THEN -!/SMC CALL W3S2XY_SMC( TAUOCX(1:NSEA), XX ) -!/SMC CALL W3S2XY_SMC( TAUOCY(1:NSEA), XY ) +#ifdef W3_SMC + CALL W3S2XY_SMC( TAUOCX(1:NSEA), XX ) + CALL W3S2XY_SMC( TAUOCY(1:NSEA), XY ) +#endif ELSE CALL W3S2XY ( NSEA, NSEA, NX+1, NY, TAUOCX(1:NSEA) & , MAPSF, XX ) @@ -1757,8 +1867,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! RMS of bottom displacement amplitude ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 1 ) THEN ! NB: ABA and ABD are the X and Y components of the bottom displacement -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA(1:NSEA), ABD(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA(1:NSEA), ABD(1:NSEA), AnglD) +#endif CALL S2GRID(ABA(1:NSEA), XX) CALL S2GRID(ABD(1:NSEA), XY) NFIELD=2 @@ -1766,17 +1878,21 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! RMS of bottom velocity amplitude ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 2 ) THEN ! NB: UBA and UBD are the X and Y components of the bottom velocity -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA(1:NSEA), UBD(1:NSEA), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA(1:NSEA), UBD(1:NSEA), AnglD) +#endif CALL S2GRID(UBA(1:NSEA), XX) CALL S2GRID(UBD(1:NSEA), XY) NFIELD=2 ! ! Bottom roughness ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 3 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & -!/RTD BEDFORMS(1:NSEA,3), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & + BEDFORMS(1:NSEA,3), AnglD) +#endif CALL S2GRID(BEDFORMS(1:NSEA,1), X1) CALL S2GRID(BEDFORMS(1:NSEA,2), X2) CALL S2GRID(BEDFORMS(1:NSEA,3), XY) @@ -1788,33 +1904,41 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! Wave to bottom boundary layer stress ELSE IF ( IFI .EQ. 7 .AND. IFJ .EQ. 5 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & -!/RTD TAUBBL(1:NSEA,2), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & + TAUBBL(1:NSEA,2), AnglD) +#endif CALL S2GRID(TAUBBL(1:NSEA,1), XX) CALL S2GRID(TAUBBL(1:NSEA,2), XY) NFIELD=2 ! ! Mean square slope ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 1 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) +#endif CALL S2GRID(MSSX, XX) CALL S2GRID(MSSY, XY) NFIELD=2 ! ! Phillips constant ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 2 ) THEN -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) +#endif CALL S2GRID(MSCX, XX) CALL S2GRID(MSCY, XY) NFIELD=2 ! ! u direction for mss ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 3 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( MSSD(ISEA) .NE. UNDEF ) THEN MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) @@ -1824,8 +1948,10 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! ! x direction for msc ELSE IF ( IFI .EQ. 8 .AND. IFJ .EQ. 4 ) THEN -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( MSCD(ISEA) .NE. UNDEF ) THEN MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) @@ -1936,16 +2062,18 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! If regular grid, initializes the lat/lon or x/y dimension lengths IF (GTYPE.NE.UNGTYPE) THEN IF( SMCGRD ) THEN -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! Flat seapoints file -!/SMC !dimln(2) = NSEA -!/SMC dimln(2) = SMCNOUT -!/SMC dimln(3) = -1 ! not used -!/SMC ELSE -!/SMC ! Regular gridded lat/lon file: -!/SMC dimln(2) = NXO -!/SMC dimln(3) = NYO -!/SMC ENDIF ! SMCOTYPE +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! Flat seapoints file + !dimln(2) = NSEA + dimln(2) = SMCNOUT + dimln(3) = -1 ! not used + ELSE + ! Regular gridded lat/lon file: + dimln(2) = NXO + dimln(3) = NYO + ENDIF ! SMCOTYPE +#endif ELSE ! SMCGRD DIMLN(2)=IXN-IX1+1 DIMLN(3)=IYN-IY1+1 @@ -2059,49 +2187,61 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! If NOT curvilinear grid, ELSE IF( SMCGRD ) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC ! Flat seapoints file -!/SMC IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(SMCNOUT)) -!/SMC IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(SMCNOUT)) -!/SMC IF(.NOT.ALLOCATED(smccx)) ALLOCATE(smccx(SMCNOUT)) -!/SMC IF(.NOT.ALLOCATED(smccy)) ALLOCATE(smccy(SMCNOUT)) -!/SMC ELSE -!/SMC ! Regular gridded file -!/SMC IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(NXO)) -!/SMC IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(NYO)) -!/RTD ! Intermediate EQUatorial lat/lon arrays for de-rotation -!/RTD ! of rotated pole coordinates: -!/RTD !!IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(NXO,NYO)) -!/RTD !!IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(NXO,NYO)) -!/RTD ! -!/RTD ! Use local RTDNX/RTDNY variables until CPP implemented to -!/RTD ! avoid compile error when SMC switch not enabled (C.Bunney): -!/RTD IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(RTDNX,RTDNY)) -!/RTD IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(RTDNX,RTDNY)) -!/SMC ENDIF -!/RTD ! Arrays for de-rotated lat/lon coordinates: -!/RTD IF(.NOT.ALLOCATED(LON2D)) THEN -!/RTD !!ALLOCATE(LON2D(NXO,NYO), LAT2D(NXO,NYO)) -!/RTD !!ALLOCATE(ANGLD2D(NXO,NYO)) -!/RTD ! -!/RTD ! Use local RTDNX/RTDNY variables until CPP implemented to -!/RTD ! avoid compile error when SMC switch not enabled (C.Bunney): -!/RTD ALLOCATE(LON2D(RTDNX,RTDNY), LAT2D(RTDNX,RTDNY)) -!/RTD ALLOCATE(ANGLD2D(RTDNX,RTDNY)) -!/RTD ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + ! Flat seapoints file + IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(SMCNOUT)) + IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(SMCNOUT)) + IF(.NOT.ALLOCATED(smccx)) ALLOCATE(smccx(SMCNOUT)) + IF(.NOT.ALLOCATED(smccy)) ALLOCATE(smccy(SMCNOUT)) + ELSE + ! Regular gridded file + IF(.NOT.ALLOCATED(lon)) ALLOCATE(lon(NXO)) + IF(.NOT.ALLOCATED(lat)) ALLOCATE(lat(NYO)) +#endif +#ifdef W3_RTD + ! Intermediate EQUatorial lat/lon arrays for de-rotation + ! of rotated pole coordinates: + !!IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(NXO,NYO)) + !!IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(NXO,NYO)) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + IF(.NOT.ALLOCATED(LON2DEQ)) ALLOCATE(LON2DEQ(RTDNX,RTDNY)) + IF(.NOT.ALLOCATED(LAT2DEQ)) ALLOCATE(LAT2DEQ(RTDNX,RTDNY)) +#endif +#ifdef W3_SMC + ENDIF +#endif +#ifdef W3_RTD + ! Arrays for de-rotated lat/lon coordinates: + IF(.NOT.ALLOCATED(LON2D)) THEN + !!ALLOCATE(LON2D(NXO,NYO), LAT2D(NXO,NYO)) + !!ALLOCATE(ANGLD2D(NXO,NYO)) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + ALLOCATE(LON2D(RTDNX,RTDNY), LAT2D(RTDNX,RTDNY)) + ALLOCATE(ANGLD2D(RTDNX,RTDNY)) + ENDIF +#endif ELSE ! SMCGRD ! instanciates lon with x/lon for regular grid or nodes for unstructured mesh IF (.NOT.ALLOCATED(LON)) ALLOCATE(LON(NX)) -!/RTD ! 2d longitude array for standard grid coordinates -!/RTD IF ( RTDL .AND. .NOT.ALLOCATED(LON2D)) & -!/RTD ALLOCATE(LON2D(NX,NY),LON2DEQ(NX,NY),ANGLD2D(NX,NY)) +#ifdef W3_RTD + ! 2d longitude array for standard grid coordinates + IF ( RTDL .AND. .NOT.ALLOCATED(LON2D)) & + ALLOCATE(LON2D(NX,NY),LON2DEQ(NX,NY),ANGLD2D(NX,NY)) +#endif IF (.NOT.ALLOCATED(LAT)) THEN ! If regular grid, instanciates lat with y/lat IF (GTYPE.EQ.RLGTYPE) THEN ALLOCATE(LAT(NY)) -!/RTD ! 2d latitude array for standard grid coordinates -!/RTD IF ( RTDL .AND. .NOT.ALLOCATED(LAT2D)) & -!/RTD ALLOCATE(LAT2D(NX,NY),LAT2DEQ(NX,NY)) +#ifdef W3_RTD + ! 2d latitude array for standard grid coordinates + IF ( RTDL .AND. .NOT.ALLOCATED(LAT2D)) & + ALLOCATE(LAT2D(NX,NY),LAT2DEQ(NX,NY)) +#endif ! If unstructured mesh, instanciates lat with nodes ELSE ALLOCATE(LAT(NX)) @@ -2116,55 +2256,73 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! If regular grid IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN IF( SMCGRD ) THEN -!/SMC ! CB: Calculate lat/lons of SMC grid -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! CB: Flat seapoints file -!/SMC DO i=1,SMCNOUT -!/SMC j = SMCIDX(i) -!/SMC lon(i) = (X0-0.5*SX) + (IJKCel(1,j) + 0.5 * IJKCel(3,j)) * dlon -!/SMC lat(i) = (Y0-0.5*SY) + (IJKCel(2,j) + 0.5 * IJKCel(4,j)) * dlat -!/SMC smccx(i) = IJKCel(3,j) -!/SMC smccy(i) = IJKCel(4,j) -!/SMC ENDDO -!/RTD !!CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & -!/RTD !! ANGLD2D(:,1), POLAT, POLON, NYO*NXO) -!/RTD ! -!/RTD ! Use local RTDNX/RTDNY variables until CPP implemented to -!/RTD ! avoid compile error when SMC switch not enabled (C.Bunney): -!/RTD CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & -!/RTD ANGLD2D(:,1), POLAT, POLON, RTDNY*RTDNX) -!/SMC ELSE -!/SMC ! CB: Regridded SMC data -!/SMC SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DXO)) )) -!/SMC SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DYO)) )) -!/SMC X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SXO)) )) -!/SMC Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SYO)) )) -!/SMC DO i=1,NXO -!/SMC lon(i)=REAL(X0D+SXD*DBLE(i-1)) -!/RTD LON2DEQ(i,:) = lon(i) -!/SMC END DO -!/SMC DO i=1,NYO -!/SMC lat(i)=REAL(Y0D+SYD*DBLE(i-1)) -!/RTD LAT2DEQ(:,i) = lat(i) -!/SMC END DO -!/SMC WRITE(STR2,'(F12.7)') DYO -!/SMC STR2=ADJUSTL(STR2) -!/SMC IF(FL_DEFAULT_GBL_META) THEN -!/SMC IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & -!/SMC 'latitude_resolution', TRIM(str2)) -!/SMC WRITE(STR2,'(F12.7)') DXO -!/SMC STR2=ADJUSTL(STR2) -!/SMC IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & -!/SMC 'longitude_resolution',TRIM(str2)) -!/SMC ENDIF -!/RTD !!CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & -!/RTD !! ANGLD2D, POLAT, POLON, NYO*NXO) -!/RTD ! -!/RTD ! Use local RTDNX/RTDNY variables until CPP implemented to -!/RTD ! avoid compile error when SMC switch not enabled (C.Bunney): -!/RTD CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & -!/RTD ANGLD2D, POLAT, POLON, RTDNY*RTDNX) -!/SMC ENDIF ! SMCOTYPE +#ifdef W3_SMC + ! CB: Calculate lat/lons of SMC grid + IF( SMCOTYPE .EQ. 1 ) THEN + ! CB: Flat seapoints file + DO i=1,SMCNOUT + j = SMCIDX(i) + lon(i) = (X0-0.5*SX) + (IJKCel(1,j) + 0.5 * IJKCel(3,j)) * dlon + lat(i) = (Y0-0.5*SY) + (IJKCel(2,j) + 0.5 * IJKCel(4,j)) * dlat + smccx(i) = IJKCel(3,j) + smccy(i) = IJKCel(4,j) + ENDDO +#endif +#ifdef W3_RTD + !!CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & + !! ANGLD2D(:,1), POLAT, POLON, NYO*NXO) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + CALL W3EQTOLL(lat, lon, LAT2D(:,1), LON2D(:,1), & + ANGLD2D(:,1), POLAT, POLON, RTDNY*RTDNX) +#endif +#ifdef W3_SMC + ELSE + ! CB: Regridded SMC data + SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DXO)) )) + SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(DYO)) )) + X0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SXO)) )) + Y0D=DBLE(0.000001d0*DNINT(1d6*(DBLE(SYO)) )) + DO i=1,NXO + lon(i)=REAL(X0D+SXD*DBLE(i-1)) +#endif +#ifdef W3_RTD + LON2DEQ(i,:) = lon(i) +#endif +#ifdef W3_SMC + END DO + DO i=1,NYO + lat(i)=REAL(Y0D+SYD*DBLE(i-1)) +#endif +#ifdef W3_RTD + LAT2DEQ(:,i) = lat(i) +#endif +#ifdef W3_SMC + END DO + WRITE(STR2,'(F12.7)') DYO + STR2=ADJUSTL(STR2) + IF(FL_DEFAULT_GBL_META) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'latitude_resolution', TRIM(str2)) + WRITE(STR2,'(F12.7)') DXO + STR2=ADJUSTL(STR2) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'longitude_resolution',TRIM(str2)) + ENDIF +#endif +#ifdef W3_RTD + !!CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + !! ANGLD2D, POLAT, POLON, NYO*NXO) + ! + ! Use local RTDNX/RTDNY variables until CPP implemented to + ! avoid compile error when SMC switch not enabled (C.Bunney): + CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + ANGLD2D, POLAT, POLON, RTDNY*RTDNX) +#endif +#ifdef W3_SMC + ENDIF ! SMCOTYPE +#endif ELSE ! SMCGRD SXD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SX)) )) SYD=DBLE(0.000001d0*DNINT(1d6*(DBLE(SY)) )) @@ -2176,17 +2334,19 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & DO I=1,NY LAT(I)=REAL(Y0D+SYD*DBLE(I-1)) END DO -!/RTD IF ( RTDL ) THEN -!/RTD ! Calculate the standard grid coordinates -!/RTD DO I=1,NX -!/RTD LON2DEQ(I,:)=LON(I) -!/RTD END DO -!/RTD DO I=1,NY -!/RTD LAT2DEQ(:,I)=LAT(I) -!/RTD END DO -!/RTD CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & -!/RTD ANGLD2D, POLAT, POLON, NY*NX) -!/RTD END IF ! RTDL +#ifdef W3_RTD + IF ( RTDL ) THEN + ! Calculate the standard grid coordinates + DO I=1,NX + LON2DEQ(I,:)=LON(I) + END DO + DO I=1,NY + LAT2DEQ(:,I)=LAT(I) + END DO + CALL W3EQTOLL(LAT2DEQ, LON2DEQ, LAT2D, LON2D, & + ANGLD2D, POLAT, POLON, NY*NX) + END IF ! RTDL +#endif IF(FL_DEFAULT_GBL_META) THEN WRITE(STR2,'(F12.0)') SY STR2=ADJUSTL(STR2) @@ -2272,12 +2432,14 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & 'altitude_resolution','n/a') CALL CHECK_ERR(IRET) -!/RTD IF ( RTDL ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & -!/RTD 'grid_north_pole_latitude',POLAT) -!/RTD IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & -!/RTD 'grid_north_pole_longitude',POLON) -!/RTD END IF +#ifdef W3_RTD + IF ( RTDL ) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'grid_north_pole_latitude',POLAT) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL, & + 'grid_north_pole_longitude',POLON) + END IF +#endif ENDIF ! FL_DEFAULT_GBL_META CALL T2D(TIME,STARTDATE,IERR) @@ -2293,29 +2455,33 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! If regular grid IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN IF(SMCGRD) THEN ! CB: shelter original code from SMC grid -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(1),LON(:)) -!/SMC CALL CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(:)) -!/SMC CALL CHECK_ERR(IRET) -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC ! For type 1 SCM file also put lat/lons and cell sizes: -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(5),SMCCX) -!/SMC CALL CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(6),SMCCY) -!/SMC CALL CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + IRET=NF90_PUT_VAR(NCID,VARID(1),LON(:)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(:)) + CALL CHECK_ERR(IRET) + IF(SMCOTYPE .EQ. 1) THEN + ! For type 1 SCM file also put lat/lons and cell sizes: + IRET=NF90_PUT_VAR(NCID,VARID(5),SMCCX) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(6),SMCCY) + CALL CHECK_ERR(IRET) + ENDIF +#endif ELSE ! SMCGRD IRET=NF90_PUT_VAR(NCID,VARID(1),LON(IX1:IXN)) CALL CHECK_ERR(IRET) IRET=NF90_PUT_VAR(NCID,VARID(2),LAT(IY1:IYN)) CALL CHECK_ERR(IRET) ENDIF ! SMCGRD -!/RTD IF ( RTDL ) THEN -!/RTD IRET=NF90_PUT_VAR(NCID,VARID(7),LON2D(IX1:IXN,IY1:IYN)) -!/RTD CALL CHECK_ERR(IRET) -!/RTD IRET=NF90_PUT_VAR(NCID,VARID(8),LAT2D(IX1:IXN,IY1:IYN)) -!/RTD CALL CHECK_ERR(IRET) -!/RTD END IF +#ifdef W3_RTD + IF ( RTDL ) THEN + IRET=NF90_PUT_VAR(NCID,VARID(7),LON2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(8),LAT2D(IX1:IXN,IY1:IYN)) + CALL CHECK_ERR(IRET) + END IF +#endif END IF ! If curvilinear grid @@ -2396,14 +2562,16 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (COORDTYPE.EQ.1) THEN IF (NCVARTYPE.EQ.2) THEN IF( SMCGRD ) THEN -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! SMC Flat file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) -!/SMC ELSE -!/SMC ! SMC Regridded file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) -!/SMC ENDIF -!/SMC CALL CHECK_ERR(IRET) +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF + CALL CHECK_ERR(IRET) +#endif ELSE ! SMCGRD IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) @@ -2412,14 +2580,16 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (NCTYPE.EQ.4) CALL CHECK_ERR(IRET) ELSE IF( SMCGRD ) THEN -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! SMC Flat file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) -!/SMC ELSE -!/SMC ! SMC Regridded file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) -!/SMC ENDIF -!/SMC CALL CHECK_ERR(IRET) +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF + CALL CHECK_ERR(IRET) +#endif ELSE ! SMCGRD IRET=NF90_DEF_VAR(NCID,META(I)%VARNM, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) @@ -2452,14 +2622,16 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & CALL CHECK_ERR(IRET) ! CB ! !! CHRISB: Commenting out below - will be handled by w3oundmeta module -!/RTD -!/RTD ! IF ( RTDL ) THEN -!/RTD ! ! Add grid mapping attribute for rotated pole grids: -!/RTD ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & -!/RTD ! 'rotated_pole') -!/RTD ! CALL CHECK_ERR(IRET) -!/RTD ! END IF -!/RTD +#ifdef W3_RTD + + ! IF ( RTDL ) THEN + ! ! Add grid mapping attribute for rotated pole grids: + ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & + ! 'rotated_pole') + ! CALL CHECK_ERR(IRET) + ! END IF + +#endif END DO ! ! put START date in global attribute @@ -2487,12 +2659,14 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! If it is spherical coordinate IF (FLAGLL) THEN IF(SMCGRD) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_INQ_DIMID (NCID, 'seapoint', DIMID(2)) -!/SMC ELSE -!/SMC IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) -!/SMC IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) -!/SMC ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_INQ_DIMID (NCID, 'seapoint', DIMID(2)) + ELSE + IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) + IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) + ENDIF +#endif ELSE IRET=NF90_INQ_DIMID (NCID, 'longitude', DIMID(2)) IRET=NF90_INQ_DIMID (NCID, 'latitude', DIMID(3)) @@ -2542,13 +2716,15 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (COORDTYPE.EQ.1) THEN IF (NCVARTYPE.EQ.2) THEN IF( SMCGRD ) THEN -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! SMC Flat file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) -!/SMC ELSE -!/SMC ! SMC Regridded file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) -!/SMC ENDIF +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF +#endif ELSE IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_SHORT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) @@ -2556,13 +2732,15 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (NCTYPE.EQ.4) IRET = NF90_DEF_VAR_DEFLATE(NCID, VARID(IVAR), 1, 1, DEFLATE) ELSE IF( SMCGRD ) THEN -!/SMC IF( SMCOTYPE .EQ. 1 ) THEN -!/SMC ! SMC Flat file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) -!/SMC ELSE -!/SMC ! SMC Regridded file -!/SMC IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) -!/SMC ENDIF +#ifdef W3_SMC + IF( SMCOTYPE .EQ. 1 ) THEN + ! SMC Flat file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, (/DIMID(2), DIMID(4+EXTRADIM)/), VARID(IVAR)) + ELSE + ! SMC Regridded file + IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) + ENDIF +#endif ELSE IRET = NF90_DEF_VAR(NCID,META(I)%varnm, NF90_FLOAT, DIMID(2:4+EXTRADIM), VARID(IVAR)) CALL CHECK_ERR(IRET) @@ -2595,14 +2773,16 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & CALL CHECK_ERR(IRET) ! CB ! !! CHRISB: Commenting out below - will be handled by w3oundmeta module -!/RTD -!/RTD ! IF ( RTDL ) THEN -!/RTD ! ! Add grid mapping attribute for rotated pole grids: -!/RTD ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & -!/RTD ! 'rotated_pole') -!/RTD ! CALL CHECK_ERR(IRET) -!/RTD ! END IF -!/RTD +#ifdef W3_RTD + + ! IF ( RTDL ) THEN + ! ! Add grid mapping attribute for rotated pole grids: + ! IRET=NF90_PUT_ATT(NCID,VARID(IVAR),'grid_mapping', & + ! 'rotated_pole') + ! CALL CHECK_ERR(IRET) + ! END IF + +#endif END DO IRET = NF90_ENDDEF(NCID) CALL CHECK_ERR(IRET) @@ -2680,41 +2860,43 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & IF (NCVARTYPE.EQ.2) THEN IF ( NFIELD.EQ.3 ) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( X1(IX,IY) .EQ. UNDEF ) THEN -!/SMC MXX(IX,IY) = MFILL -!/SMC MYY(IX,IY) = MFILL -!/SMC MXY(IX,IY) = MFILL -!/SMC ELSE -!/SMC MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) -!/SMC MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) -!/SMC MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & -!/SMC MXY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & -!/SMC MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + MXY(IX,IY) = MFILL + ELSE + MXX(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(X2(IX,IY)/META(2)%FSC) + MXY(IX,IY) = NINT(XY(IX,IY)/META(3)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -2745,33 +2927,35 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! EXTRADIM=0 IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XX(IX,IY) .EQ. UNDEF ) THEN -!/SMC MXX(IX,IY) = MFILL -!/SMC MYY(IX,IY) = MFILL -!/SMC ELSE -!/SMC MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) -!/SMC MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XX(IX,IY) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + ELSE + MXX(IX,IY) = NINT(XX(IX,IY)/META(1)%FSC) + MYY(IX,IY) = NINT(XY(IX,IY)/META(2)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYY(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -2800,35 +2984,37 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN -!/SMC MXX(IX,IY) = MFILL -!/SMC MYY(IX,IY) = MFILL -!/SMC ELSE -!/SMC MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) -!/SMC MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & -!/SMC (/COUNT(1), COUNT(3), COUNT(4)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MXY(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & -!/SMC (/COUNT(1), COUNT(3), COUNT(4)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN + MXX(IX,IY) = MFILL + MYY(IX,IY) = MFILL + ELSE + MXX(IX,IY) = NINT(XXK(IX,IY,IK)/META(1)%FSC) + MYY(IX,IY) = NINT(XYK(IX,IY,IK)/META(2)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & + (/COUNT(1), COUNT(3), COUNT(4)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MXY(IX1:IXN,IY1:IYN),(/START(1), START(3), START(4)/), & + (/COUNT(1), COUNT(3), COUNT(4)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXX(IX1:IXN,IY1:IYN),(/START(1:4)/),(/COUNT(1:4)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -2853,25 +3039,27 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! EXTRADIM=0 IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( X1(IX,IY) .EQ. UNDEF ) THEN -!/SMC MX1(IX,IY) = MFILL -!/SMC ELSE -!/SMC MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MX1(IX,IY) = MFILL + ELSE + MX1(IX,IY) = NINT(X1(IX,IY)/META(1)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -2893,25 +3081,27 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & START(3+1-COORDTYPE)=START(3+1-COORDTYPE)+1 IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN -!/SMC MX1(IX,IY) = MFILL -!/SMC ELSE -!/SMC MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN + MX1(IX,IY) = MFILL + ELSE + MX1(IX,IY) = NINT(XK(IX,IY,IK)/META(1)%FSC) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -2935,41 +3125,43 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ELSE IF ( NFIELD.EQ.3 ) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( X1(IX,IY) .EQ. UNDEF ) THEN -!/SMC MXXR(IX,IY) = MFILLR -!/SMC MYYR(IX,IY) = MFILLR -!/SMC MXYR(IX,IY) = MFILLR -!/SMC ELSE -!/SMC MXXR(IX,IY) = X1(IX,IY) -!/SMC MYYR(IX,IY) = X2(IX,IY) -!/SMC MXYR(IX,IY) = XY(IX,IY) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & -!/SMC MXYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & -!/SMC MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MXXR(IX,IY) = MFILLR + MYYR(IX,IY) = MFILLR + MXYR(IX,IY) = MFILLR + ELSE + MXXR(IX,IY) = X1(IX,IY) + MYYR(IX,IY) = X2(IX,IY) + MXYR(IX,IY) = XY(IX,IY) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+3), & + MXYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF(SMCGRD) DO IX=IX1, IXN DO IY=IY1, IYN @@ -3000,33 +3192,35 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! EXTRADIM=0 IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XX(IX,IY) .EQ. UNDEF ) THEN -!/SMC MXXR(IX,IY) = MFILLR -!/SMC MYYR(IX,IY) = MFILLR -!/SMC ELSE -!/SMC MXXR(IX,IY) = XX(IX,IY) -!/SMC MYYR(IX,IY) = XY(IX,IY) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XX(IX,IY) .EQ. UNDEF ) THEN + MXXR(IX,IY) = MFILLR + MYYR(IX,IY) = MFILLR + ELSE + MXXR(IX,IY) = XX(IX,IY) + MYYR(IX,IY) = XY(IX,IY) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN @@ -3053,33 +3247,35 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & START(4-COORDTYPE)=START(4-COORDTYPE)+1 IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN -!/SMC MXXR(IX,IY) = MFILLR -!/SMC MYYR(IX,IY) = MFILLR -!/SMC ELSE -!/SMC MXXR(IX,IY) = XXK(IX,IY,IK) -!/SMC MYYR(IX,IY) = XYK(IX,IY,IK) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & -!/SMC MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XXK(IX,IY,IK) .EQ. UNDEF ) THEN + MXXR(IX,IY) = MFILLR + MYYR(IX,IY) = MFILLR + ELSE + MXXR(IX,IY) = XXK(IX,IY,IK) + MYYR(IX,IY) = XYK(IX,IY,IK) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MXXR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+2), & + MYYR(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN @@ -3104,25 +3300,27 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ! EXTRADIM=0 IF (EXTRADIM.EQ.0) THEN IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( X1(IX,IY) .EQ. UNDEF ) THEN -!/SMC MX1R(IX,IY) = MFILLR -!/SMC ELSE -!/SMC MX1R(IX,IY) = X1(IX,IY) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( X1(IX,IY) .EQ. UNDEF ) THEN + MX1R(IX,IY) = MFILLR + ELSE + MX1R(IX,IY) = X1(IX,IY) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN @@ -3143,25 +3341,27 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & DO IK=I1F,I2F START(4-COORDTYPE)=START(4-COORDTYPE)+1 IF (SMCGRD) THEN -!/SMC DO IX=IX1, IXN -!/SMC DO IY=IY1, IYN -!/SMC ! TODO: Find some other way to access MAPSTA -!/SMC IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN -!/SMC MX1R(IX,IY) = MFILLR -!/SMC ELSE -!/SMC MX1R(IX,IY) = XK(IX,IY,IK) -!/SMC END IF -!/SMC END DO -!/SMC END DO -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE -!/SMC IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & -!/SMC MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + DO IX=IX1, IXN + DO IY=IY1, IYN + ! TODO: Find some other way to access MAPSTA + IF ( XK(IX,IY,IK) .EQ. UNDEF ) THEN + MX1R(IX,IY) = MFILLR + ELSE + MX1R(IX,IY) = XK(IX,IY,IK) + END IF + END DO + END DO + IF(SMCOTYPE .EQ. 1) THEN + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1), START(3)/),(/COUNT(1), COUNT(3)/)) + call CHECK_ERR(IRET) + ELSE + IRET=NF90_PUT_VAR(NCID,VARID(IVAR1+1), & + MX1R(IX1:IXN,IY1:IYN),(/START(1:3)/),(/COUNT(1:3)/)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE ! IF SMCGRD DO IX=IX1, IXN DO IY=IY1, IYN @@ -3212,7 +3412,9 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & DEALLOCATE(AUX1) IF (ALLOCATED(LON)) DEALLOCATE(LON, LAT) IF (ALLOCATED(LON2D)) DEALLOCATE(LON2D, LAT2D) -!/RTD IF (ALLOCATED(LON2DEQ)) DEALLOCATE(LAT2DEQ, LON2DEQ, ANGLD2D) +#ifdef W3_RTD + IF (ALLOCATED(LON2DEQ)) DEALLOCATE(LAT2DEQ, LON2DEQ, ANGLD2D) +#endif ! RETURN ! @@ -3227,16 +3429,22 @@ SUBROUTINE W3EXNC ( NX, NY, IX1, IXN, IY1, IYN, NSEA, & ' PLEASE UPDATE FIELDS !!! '/ & ' IFI = ',I2, '- IFJ = ',I2/) ! -!/T 9000 FORMAT (' TEST W3EXNC : FLAGS :',I3,2X,20L2) -!/T 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & -!/T ' IX1/N :',2I7/ & -!/T ' IY1/N :',2I7/ & -!/T ' VECTOR :',1L2) -! -!/T 9012 FORMAT (' TEST W3EXNC : BLOK PARS : ',3I4) -!/T 9014 FORMAT (' BASE NAME : ',A) -! -!/T 9020 FORMAT (' TEST W3EXNC : OUTPUT FIELD : ',A) +#ifdef W3_T + 9000 FORMAT (' TEST W3EXNC : FLAGS :',I3,2X,20L2) + 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & + ' IX1/N :',2I7/ & + ' IY1/N :',2I7/ & + ' VECTOR :',1L2) +#endif +! +#ifdef W3_T + 9012 FORMAT (' TEST W3EXNC : BLOK PARS : ',3I4) + 9014 FORMAT (' BASE NAME : ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3EXNC : OUTPUT FIELD : ',A) +#endif !/ @@ -3253,8 +3461,10 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & EXTRADIM, NCTYPE, MAPSTAOUT ) ! USE W3GDATMD, ONLY : GTYPE, FLAGLL, UNGTYPE, CLGTYPE, RLGTYPE -!/RTD ! Rotated pole parameters from the mod_def file -!/RTD USE W3GDATMD, ONLY : POLAT, POLON +#ifdef W3_RTD + ! Rotated pole parameters from the mod_def file + USE W3GDATMD, ONLY : POLAT, POLON +#endif USE NETCDF USE W3TIMEMD @@ -3298,14 +3508,16 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & IF (GTYPE.NE.UNGTYPE) THEN IF (FLAGLL) THEN IF (SMCGRD) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC ! Flat seapoints file -!/SMC IRET = NF90_DEF_DIM(NCID, 'seapoint', dimln(2), DIMID(2)) -!/SMC ELSE -!/SMC ! Regular gridded file: -!/SMC IRET = NF90_DEF_DIM(NCID, 'longitude', dimln(2), DIMID(2)) -!/SMC IRET = NF90_DEF_DIM(NCID, 'latitude', dimln(3), DIMID(3)) -!/SMC ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + ! Flat seapoints file + IRET = NF90_DEF_DIM(NCID, 'seapoint', dimln(2), DIMID(2)) + ELSE + ! Regular gridded file: + IRET = NF90_DEF_DIM(NCID, 'longitude', dimln(2), DIMID(2)) + IRET = NF90_DEF_DIM(NCID, 'latitude', dimln(3), DIMID(3)) + ENDIF +#endif ELSE IRET = NF90_DEF_DIM(NCID, 'longitude', DIMLN(2), DIMID(2)) IRET = NF90_DEF_DIM(NCID, 'latitude', DIMLN(3), DIMID(3)) @@ -3348,38 +3560,40 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & !longitude IF (GTYPE.EQ.RLGTYPE .OR. GTYPE.EQ.SMCTYPE) THEN IF (SMCGRD) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC ! Flat SMC grid - use seapoint dimension: -!/SMC IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) -!/SMC CALL CHECK_ERR(IRET) -!/SMC IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) -!/SMC CALL CHECK_ERR(IRET) -!/SMC -!/SMC ! Latitude and longitude are auxililary variables in type 1 sea point -!/SMC ! SMC file; add to "coordinates" attribute: -!/SMC COORDS_ATTR = TRIM(COORDS_ATTR) // " latitude longitude" -!/SMC -!/SMC ! For seapoint style SMC grid, also define out cell size variables: -!/SMC IRET = NF90_DEF_VAR(NCID, 'cx', NF90_SHORT, DIMID(2), VARID(5)) -!/SMC CALL CHECK_ERR(IRET) -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(5), 'long_name', & -!/SMC 'longitude cell size factor') -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_min', 1) -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_max', 256) -!/SMC -!/SMC IRET = NF90_DEF_VAR(NCID, 'cy', NF90_SHORT, DIMID(2), VARID(6)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(6), 'long_name', & -!/SMC 'latitude cell size factor') -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_min', 1) -!/SMC IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_max', 256) -!/SMC ELSE -!/SMC ! Regirdded regular SMC grid - use lon/lat dimensions: -!/SMC IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + ! Flat SMC grid - use seapoint dimension: + IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) + CALL CHECK_ERR(IRET) + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) + CALL CHECK_ERR(IRET) + + ! Latitude and longitude are auxililary variables in type 1 sea point + ! SMC file; add to "coordinates" attribute: + COORDS_ATTR = TRIM(COORDS_ATTR) // " latitude longitude" + + ! For seapoint style SMC grid, also define out cell size variables: + IRET = NF90_DEF_VAR(NCID, 'cx', NF90_SHORT, DIMID(2), VARID(5)) + CALL CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, VARID(5), 'long_name', & + 'longitude cell size factor') + IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_min', 1) + IRET = NF90_PUT_ATT(NCID, VARID(5), 'valid_max', 256) + + IRET = NF90_DEF_VAR(NCID, 'cy', NF90_SHORT, DIMID(2), VARID(6)) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, VARID(6), 'long_name', & + 'latitude cell size factor') + IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_min', 1) + IRET = NF90_PUT_ATT(NCID, VARID(6), 'valid_max', 256) + ELSE + ! Regirdded regular SMC grid - use lon/lat dimensions: + IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) + call CHECK_ERR(IRET) + IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) + call CHECK_ERR(IRET) + ENDIF +#endif ELSE IRET = NF90_DEF_VAR(NCID, 'longitude', NF90_FLOAT, DIMID(2), VARID(1)) IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(3), VARID(2)) @@ -3394,94 +3608,118 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & IRET = NF90_DEF_VAR(NCID, 'latitude', NF90_FLOAT, DIMID(2), VARID(2)) END IF IRET=NF90_PUT_ATT(NCID,VARID(1),'units','degree_east') -!/RTD ! Is the grid really rotated -!/RTD IF ( .NOT. RTDL ) THEN +#ifdef W3_RTD + ! Is the grid really rotated + IF ( .NOT. RTDL ) THEN +#endif IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude') IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','longitude') -!/RTD ELSE -!/RTD ! Override the above for RTD pole: -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude in rotated pole grid') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','grid_longitude') -!/RTD END IF +#ifdef W3_RTD + ELSE + ! Override the above for RTD pole: + IRET=NF90_PUT_ATT(NCID,VARID(1),'long_name','longitude in rotated pole grid') + IRET=NF90_PUT_ATT(NCID,VARID(1),'standard_name','grid_longitude') + END IF +#endif IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_min',-180.0) IRET=NF90_PUT_ATT(NCID,VARID(1),'valid_max',360.) ! IRET=NF90_PUT_ATT(NCID,VARID(2),'units','degree_north') -!/RTD IF ( .NOT. RTDL ) THEN +#ifdef W3_RTD + IF ( .NOT. RTDL ) THEN +#endif IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','latitude') IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','latitude') -!/RTD ELSE -!/RTD ! Override the above for RTD pole: -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','latitude in rotated pole grid') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','grid_latitude') -!/RTD END IF +#ifdef W3_RTD + ELSE + ! Override the above for RTD pole: + IRET=NF90_PUT_ATT(NCID,VARID(2),'long_name','latitude in rotated pole grid') + IRET=NF90_PUT_ATT(NCID,VARID(2),'standard_name','grid_latitude') + END IF +#endif IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_min',-90.0) IRET=NF90_PUT_ATT(NCID,VARID(2),'valid_max',90.) ! IF(SMCGRD) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/RTD IF ( RTDL ) THEN -!/RTD ! For SMC grid type 1, standard lat/lon variables are 1D: -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & -!/RTD (/ DIMID(2) /), VARID(7)) -!/RTD call CHECK_ERR(IRET) -!/RTD -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & -!/RTD (/ DIMID(2) /), VARID(8)) -!/RTD call CHECK_ERR(IRET) -!/RTD ENDIF ! RTDL -!/SMC ELSE -!/RTD IF ( RTDL ) THEN -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & -!/RTD (/ DIMID(2), DIMID(3)/), VARID(7)) -!/RTD call CHECK_ERR(IRET) -!/RTD -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & -!/RTD (/ DIMID(2), DIMID(3)/), VARID(8)) -!/RTD call CHECK_ERR(IRET) -!/RTD ENDIF ! RTDL -!/SMC ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN +#endif +#ifdef W3_RTD + IF ( RTDL ) THEN + ! For SMC grid type 1, standard lat/lon variables are 1D: + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & + (/ DIMID(2) /), VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & + (/ DIMID(2) /), VARID(8)) + call CHECK_ERR(IRET) + ENDIF ! RTDL +#endif +#ifdef W3_SMC + ELSE +#endif +#ifdef W3_RTD + IF ( RTDL ) THEN + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, & + (/ DIMID(2), DIMID(3)/), VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, & + (/ DIMID(2), DIMID(3)/), VARID(8)) + call CHECK_ERR(IRET) + ENDIF ! RTDL +#endif +#ifdef W3_SMC + ENDIF +#endif ELSE -!/RTD IF ( RTDL ) THEN -!/RTD !Add secondary coordinate system linking rotated grid back to standard lat-lon -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & -!/RTD VARID(7)) -!/RTD call CHECK_ERR(IRET) -!/RTD -!/RTD IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & -!/RTD VARID(8)) -!/RTD call CHECK_ERR(IRET) -!/RTD END IF +#ifdef W3_RTD + IF ( RTDL ) THEN + !Add secondary coordinate system linking rotated grid back to standard lat-lon + IRET = NF90_DEF_VAR(NCID, 'standard_longitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(7)) + call CHECK_ERR(IRET) + + IRET = NF90_DEF_VAR(NCID, 'standard_latitude', NF90_FLOAT, (/ DIMID(2), DIMID(3)/), & + VARID(8)) + call CHECK_ERR(IRET) + END IF +#endif ENDIF ! SMCGRD -!/RTD -!/RTD IF ( RTDL ) THEN -!/RTD ! Attributes for standard_longitude: -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree_east') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','longitude') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','longitude') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-180.0) -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) -!/RTD -!/RTD ! Attributes for standard_latitude: -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree_north') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','latitude') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','latitude') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',-90.0) -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',90.) -!/RTD -!/RTD ! Add rotated pole grid mapping variable (dummy scalar variable -!/RTD ! used to simply store rotated pole information; see CF1.6 conventions). -!/RTD ! TODO: FUTURE WW3_OUNF DEVELOPMENT WILL ALLOW USER TO DEFINE THE -!/RTD ! COORDINATE REFERENCE SYSTEM - THIS WILL REQUIRE THE BELOW TO BE -!/RTD ! HANDLED DIFFERENTLY. C. Bunney. +#ifdef W3_RTD + + IF ( RTDL ) THEN + ! Attributes for standard_longitude: + IRET=NF90_PUT_ATT(NCID,VARID(7),'units','degree_east') + IRET=NF90_PUT_ATT(NCID,VARID(7),'long_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(7),'standard_name','longitude') + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_min',-180.0) + IRET=NF90_PUT_ATT(NCID,VARID(7),'valid_max',360.) + + ! Attributes for standard_latitude: + IRET=NF90_PUT_ATT(NCID,VARID(8),'units','degree_north') + IRET=NF90_PUT_ATT(NCID,VARID(8),'long_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(8),'standard_name','latitude') + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_min',-90.0) + IRET=NF90_PUT_ATT(NCID,VARID(8),'valid_max',90.) + + ! Add rotated pole grid mapping variable (dummy scalar variable + ! used to simply store rotated pole information; see CF1.6 conventions). + ! TODO: FUTURE WW3_OUNF DEVELOPMENT WILL ALLOW USER TO DEFINE THE + ! COORDINATE REFERENCE SYSTEM - THIS WILL REQUIRE THE BELOW TO BE + ! HANDLED DIFFERENTLY. C. Bunney. +#endif !! CHRISB: Commenting out below - will be handled by w3oundmeta module -!/RTD !!IRET=NF90_DEF_VAR(NCID, 'rotated_pole', NF90_CHAR, VARID(12)) -!/RTD !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_north_pole_latitude',POLAT) -!/RTD !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_north_pole_longitude',POLON) -!/RTD !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_mapping_name', & -!/RTD !! 'rotated_latitude_longitude') -!/RTD END IF +#ifdef W3_RTD + !!IRET=NF90_DEF_VAR(NCID, 'rotated_pole', NF90_CHAR, VARID(12)) + !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_north_pole_latitude',POLAT) + !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_north_pole_longitude',POLON) + !!IRET=NF90_PUT_ATT(NCID, VARID(12), 'grid_mapping_name', & + !! 'rotated_latitude_longitude') + END IF +#endif ! ELSE IF (GTYPE.EQ.RLGTYPE) THEN @@ -3646,28 +3884,32 @@ SUBROUTINE W3CRNC (NCFILE, NCID, DIMID, DIMLN, VARID, & CALL CHECK_ERR(IRET) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'WAVEWATCH_III_switches',TRIM(SWITCHES)) CALL CHECK_ERR(IRET) -!/ST4 IF (ZZWND.NE.10) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ZWD',ZZWND) -!/ST4 IF (AALPHA.NE.0.0095) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ALPHA0',AALPHA) -!/ST4 IF (BBETA.NE.1.43) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter BETAMAX',BBETA) -!/ST4 IF(SSDSC(7).NE.0.3) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SDS4 namelist parameter WHITECAPWIDTH', SSDSC(7)) +#ifdef W3_ST4 + IF (ZZWND.NE.10) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ZWD',ZZWND) + IF (AALPHA.NE.0.0095) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter ALPHA0',AALPHA) + IF (BBETA.NE.1.43) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SIN4 namelist parameter BETAMAX',BBETA) + IF(SSDSC(7).NE.0.3) IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SDS4 namelist parameter WHITECAPWIDTH', SSDSC(7)) +#endif ! ... TO BE CONTINUED ... IF(SMCGRD) THEN -!/SMC IF(SMCOTYPE .EQ. 1) THEN -!/SMC IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lat', Y0) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lon', X0) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lat_size', dlat) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lon_size', dlon) -!/SMC call CHECK_ERR(IRET) -!/SMC IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','seapoint') -!/SMC call CHECK_ERR(IRET) -!/SMC ELSE IF(SMCOTYPE .EQ. 2) THEN -!/SMC IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','regular_regridded') -!/SMC call CHECK_ERR(IRET) -!/SMC ENDIF +#ifdef W3_SMC + IF(SMCOTYPE .EQ. 1) THEN + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lat', Y0) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'first_lon', X0) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lat_size', dlat) + call CHECK_ERR(IRET) + IRET = NF90_PUT_ATT(NCID, NF90_GLOBAL, 'base_lon_size', dlon) + call CHECK_ERR(IRET) + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','seapoint') + call CHECK_ERR(IRET) + ELSE IF(SMCOTYPE .EQ. 2) THEN + IRET=NF90_PUT_ATT(NCID,NF90_GLOBAL,'SMC_grid_type','regular_regridded') + call CHECK_ERR(IRET) + ENDIF +#endif ENDIF ENDIF ! FL_DEFAULT_GBL_META @@ -3746,9 +3988,11 @@ SUBROUTINE S2GRID(S, X, FLDIRN) FLDR = .FALSE. IF(PRESENT(FLDIRN)) FLDR = FLDIRN -!/SMC IF( SMCGRD ) THEN -!/SMC CALL W3S2XY_SMC( S, X, FLDR ) -!/SMC ELSE ! IF(SMCGRD) +#ifdef W3_SMC + IF( SMCGRD ) THEN + CALL W3S2XY_SMC( S, X, FLDR ) + ELSE ! IF(SMCGRD) +#endif IF(FLDR) THEN DO ISEA=1, NSEA IF (S(ISEA) .NE. UNDEF ) THEN @@ -3761,7 +4005,9 @@ SUBROUTINE S2GRID(S, X, FLDIRN) IF(NOVAL .NE. UNDEF) WHERE(S .EQ. UNDEF) S = NOVAL CALL W3S2XY ( NSEA, NSEA, NX+1, NY, S, MAPSF, X ) -!/SMC ENDIF +#ifdef W3_SMC + ENDIF +#endif END SUBROUTINE S2GRID diff --git a/model/ftn/ww3_ounp.ftn b/model/src/ww3_ounp.F90 similarity index 88% rename from model/ftn/ww3_ounp.ftn rename to model/src/ww3_ounp.F90 index 409d16f3c..e871abfa4 100644 --- a/model/ftn/ww3_ounp.ftn +++ b/model/src/ww3_ounp.F90 @@ -156,13 +156,17 @@ PROGRAM W3OUNP !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG USE W3WDATMD, ONLY: W3SETW, W3NDAT -!/NL1 USE W3ADATMD, ONLY: W3SETA, W3NAUX +#ifdef W3_NL1 + USE W3ADATMD, ONLY: W3SETA, W3NAUX +#endif USE W3ODATMD, ONLY: W3SETO, W3NOUT USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT, DIMP USE W3IOGRMD, ONLY: W3IOGR USE W3IOPOMD, ONLY: W3IOPO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: CALTYPE, STME21, TICK21, DSEC21, T2D, TSUB, U2D !/ USE W3GDATMD @@ -170,18 +174,28 @@ PROGRAM W3OUNP USE W3ODATMD, ONLY: NDSE, NDSO, NOPTS, PTLOC, PTNME, & DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& IPASS => IPASS2, ICEFO, ICEO, ICEHO -!/FLX5 USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO -!/T USE W3ODATMD, ONLY: NDST -!/SETUP USE W3ODATMD, ONLY: ZET_SETO -! -!/O14 USE W3ODATMD, ONLY: GRDID +#ifdef W3_FLX5 + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif +#ifdef W3_T + USE W3ODATMD, ONLY: NDST +#endif +#ifdef W3_SETUP + USE W3ODATMD, ONLY: ZET_SETO +#endif +! +#ifdef W3_O14 + USE W3ODATMD, ONLY: GRDID +#endif ! USE W3NMLOUNPMD USE NETCDF ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -203,10 +217,18 @@ PROGRAM W3OUNP INTEGER :: DIMID(7), DIMLN(5), VARID(28), & STARTDATE(8), STOPDATE(8), & TOUT(2), TDUM(2), TOUTL(2) -!/MPI INTEGER :: IERR_MPI -!/O14 INTEGER :: NDBO -!/S INTEGER, SAVE :: IENT = 0 -!/NCO INTEGER :: NDSTAB, NDST +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_O14 + INTEGER :: NDBO +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_NCO + INTEGER :: NDSTAB, NDST +#endif ! INTEGER, ALLOCATABLE :: INDREQ(:), INDREQTMP(:) INTEGER,ALLOCATABLE :: NCID(:) @@ -247,7 +269,9 @@ PROGRAM W3OUNP 'Sum of selected sources ' / FLSRCE = .FALSE. ! -!/NCO/! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#ifdef W3_NCO +! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1.a IO set-up. @@ -256,8 +280,10 @@ PROGRAM W3OUNP CALL W3SETG ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) CALL W3SETW ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -269,30 +295,42 @@ PROGRAM W3OUNP NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3OUNP') +#ifdef W3_S + CALL STRACE (IENT, 'W3OUNP') +#endif +! +#ifdef W3_NCO ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSOP = 13 -!/O14 NDBO = 14 -!/NCO NDSTRC = NDSO +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSOP = 13 +#endif +#ifdef W3_O14 + NDBO = 14 +#endif +#ifdef W3_NCO + NDSTRC = NDSO +#endif ! ! ! 1.b MPP initializations ! -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 +#ifdef W3_SHRD + NAPROC = 1 + IAPROC = 1 +#endif ! -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#endif ! IF ( IAPROC .EQ. NAPERR ) THEN NDSEN = NDSE @@ -863,7 +901,9 @@ PROGRAM W3OUNP ! ... ITYPE = 3 ELSE IF (ITYPE .EQ. 3) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,942) ITYPE, 'Source terms' -!/NCO NDSTAB = 51 +#ifdef W3_NCO + NDSTAB = 51 +#endif ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) ! ... OTYPE = 1 @@ -971,11 +1011,21 @@ PROGRAM W3OUNP !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 6. Time management. ! -!/IC1 WRITE(NDSO,3960) -!/IC2 WRITE(NDSO,3960) -!/IC3 WRITE(NDSO,3960) -!/IC5 WRITE(NDSO,3960) -!/NL5 WRITE(NDSO,3961) +#ifdef W3_IC1 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC2 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC3 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC5 + WRITE(NDSO,3960) +#endif +#ifdef W3_NL5 + WRITE(NDSO,3961) +#endif ! CALL T2D(TIME,STARTDATE,IERR) WRITE(STRSTARTDATE,'(I4.4,A,4(I2.2,A),I2.2)') STARTDATE(1),'-',STARTDATE(2), & @@ -1132,7 +1182,9 @@ PROGRAM W3OUNP CLOSE(NDSOP) ! closes binary file out_pnt* IPASS = 0 ! resets time counter for binary file out_pnt* CALL W3IOPO ( 'READ', NDSOP, IOTEST ) -!/T WRITE(NDSE,*) 'out_pnt* closed and reopened' +#ifdef W3_T + WRITE(NDSE,*) 'out_pnt* closed and reopened' +#endif TOUT=TOUTL NOUT=NOUTL @@ -1181,9 +1233,11 @@ PROGRAM W3OUNP WRITE (NDSE,1004) NF90_INQ_LIBVERS() CALL EXTCDE ( 44 ) ! -!/O14 805 CONTINUE -!/O14 WRITE (NDSE,1005) IERR -!/O14 CALL EXTCDE ( 45 ) +#ifdef W3_O14 + 805 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 45 ) +#endif ! ! 888 CONTINUE @@ -1194,9 +1248,13 @@ PROGRAM W3OUNP IF(ALLOCATED(INDREQ)) DEALLOCATE(INDREQ) ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! -!/NCO/! CALL W3TAGE('WAVESPEC') +#ifdef W3_NCO +! CALL W3TAGE('WAVESPEC') +#endif ! ! Formats ! @@ -1221,7 +1279,9 @@ PROGRAM W3OUNP ' ',A, I3 /) 943 FORMAT ( ' Subtype : ',A) 944 FORMAT ( ' ',A) -!/O14 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#ifdef W3_O14 + 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#endif 949 FORMAT (/' End of file reached '/) ! 950 FORMAT (/' Requested output for ',I6,' points : '/ & @@ -1267,9 +1327,11 @@ PROGRAM W3OUNP ' NCTYPE=4 IS INCOMPATIBLE WITH'/ & ' NETCDF LIBRARY USED :',A/) ! -!/O14 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & -!/O14 ' ERROR IN OPENING BUOY LOG FILE'/ & -!/O14 ' IOSTAT =',I5/) +#ifdef W3_O14 + 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & + ' ERROR IN OPENING BUOY LOG FILE'/ & + ' IOSTAT =',I5/) +#endif ! 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & ' ITYPE AND OTYPE COMBINATION NOT RECOGNIZED'/) @@ -1285,21 +1347,31 @@ PROGRAM W3OUNP 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUNP : '/ & ' ILLEGAL TYPE, OTYPE =',I4/) ! -!/IC1 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & -!/IC1 ' Ice source terms !/IC1 skipped'/ & -!/IC1 ' in dissipation term.'/) -!/IC2 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & -!/IC2 ' Ice source terms !/IC2 skipped'/ & -!/IC2 ' in dissipation term.'/) -!/IC3 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & -!/IC3 ' Ice source terms !/IC3 skipped'/ & -!/IC3 ' in dissipation term.'/) -!/IC5 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & -!/IC5 ' Ice source terms !/IC5 skipped'/ & -!/IC5 ' in dissipation term.'/) -!/NL5 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & -!/NL5 ' Snl source terms !/NL5 skipped'/ & -!/NL5 ' in interaction term.'/) +#ifdef W3_IC1 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC1 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC2 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC2 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC3 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC3 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC5 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Ice source terms !/IC5 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_NL5 + 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUNP :'/ & + ' Snl source terms !/NL5 skipped'/ & + ' in interaction term.'/) +#endif !/ !/ Internal subroutine W3EXNC ---------------------------------------- / !/ @@ -1387,30 +1459,74 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/FLX1 USE W3FLX1MD -!/FLX2 USE W3FLX2MD -!/FLX3 USE W3FLX3MD -!/FLX4 USE W3FLX4MD -!/FLX5 USE W3FLX5MD -!/LN1 USE W3SLN1MD -!/ST1 USE W3SRC1MD -!/ST2 USE W3SRC2MD -!/ST3 USE W3SRC3MD -!/ST4 USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 -!/ST6 USE W3SRC6MD -!/ST6 USE W3SWLDMD, ONLY : W3SWL6 -!/ST6 USE W3GDATMD, ONLY : SWL6S6 -!/NL1 USE W3SNL1MD -!/NL2 USE W3SNL2MD -!/NL3 USE W3SNL3MD -!/NL4 USE W3SNL4MD -!/BT1 USE W3SBT1MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/DB1 USE W3SDB1MD -!/BS1 USE W3SBS1MD -!/IS2 USE W3SIS2MD +#ifdef W3_FLX1 + USE W3FLX1MD +#endif +#ifdef W3_FLX2 + USE W3FLX2MD +#endif +#ifdef W3_FLX3 + USE W3FLX3MD +#endif +#ifdef W3_FLX4 + USE W3FLX4MD +#endif +#ifdef W3_FLX5 + USE W3FLX5MD +#endif +#ifdef W3_LN1 + USE W3SLN1MD +#endif +#ifdef W3_ST1 + USE W3SRC1MD +#endif +#ifdef W3_ST2 + USE W3SRC2MD +#endif +#ifdef W3_ST3 + USE W3SRC3MD +#endif +#ifdef W3_ST4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 +#endif +#ifdef W3_ST6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 +#endif +#ifdef W3_NL1 + USE W3SNL1MD +#endif +#ifdef W3_NL2 + USE W3SNL2MD +#endif +#ifdef W3_NL3 + USE W3SNL3MD +#endif +#ifdef W3_NL4 + USE W3SNL4MD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BS1 + USE W3SBS1MD +#endif +#ifdef W3_IS2 + USE W3SIS2MD +#endif USE W3PARTMD, ONLY: W3PART USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION USE W3GDATMD, ONLY: IICEDISP @@ -1418,8 +1534,10 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) USE W3ARRYMD, ONLY: PRT1DS, PRT2DS, PRT1DM USE W3DISPMD, ONLY: NAR1D, DFAC, N1MAX, ECG1, EWN1, DSIE USE NETCDF -!/IG1 USE W3GIG1MD, ONLY: W3ADDIG -!/IG1 USE W3CANOMD, ONLY: W3ADD2NDORDER +#ifdef W3_IG1 + USE W3GIG1MD, ONLY: W3ADDIG + USE W3CANOMD, ONLY: W3ADD2NDORDER +#endif IMPLICIT NONE @@ -1436,7 +1554,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) INTEGER :: J, J1, I1, I2, ISP, IKM, IKL, IKH, & ITH, IK, ITT, NPART, IX, IY, ISEA INTEGER :: CURDATE(8), REFDATE(8) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & @@ -1449,7 +1569,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) YSTAR, FHIGH, ZWND, Z0, USTD, EMEAN, & FMEAN, WNMEAN, UDIRCA, CHARN, M2KM, & ICETHICK, ICECON -!/FLX5 REAL :: TAUA, TAUADIR, RHOAIR +#ifdef W3_FLX5 + REAL :: TAUA, TAUADIR, RHOAIR +#endif REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK), & R(NK), WN(NK), CG(NK), APM(NK), & E3(NTH,NK,NREQ), E(NK,NTH), E1(NK), & @@ -1464,22 +1586,42 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) SIN1(NK), SNL1(NK), SDS1(NK), & SBT1(NK), SIS1(NK), STT1(NK), & E1ALL(NK,6), UDIR1(NREQ), CDIR1(NREQ) -!/FLX5 REAL :: TAUDIR1(NREQ) +#ifdef W3_FLX5 + REAL :: TAUDIR1(NREQ) +#endif REAL, SAVE :: HSMIN = 0.05 -!/IS2 REAL :: ICEF, ICEDMAX, DIA2(NTH,NK) -!/ST1 REAL :: AMAX, FH1, FH2 -!/ST2 REAL :: AMAX, ALPHA(NK), FPI -!/ST3 REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & -!/ST3 TAUWNX, TAUWNY -!/ST4 REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & -!/ST4 TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4) -!/ST4 REAL :: LAMBDA(NSPEC), DLWMEAN -!/ST6 REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY -!/BS1 REAL :: TAUSCX, TAUSCY -!/BT4 REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) +#ifdef W3_IS2 + REAL :: ICEF, ICEDMAX, DIA2(NTH,NK) +#endif +#ifdef W3_ST1 + REAL :: AMAX, FH1, FH2 +#endif +#ifdef W3_ST2 + REAL :: AMAX, ALPHA(NK), FPI +#endif +#ifdef W3_ST3 + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY +#endif +#ifdef W3_ST4 + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4) + REAL :: LAMBDA(NSPEC), DLWMEAN +#endif +#ifdef W3_ST6 + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY +#endif +#ifdef W3_BS1 + REAL :: TAUSCX, TAUSCY +#endif +#ifdef W3_BT4 + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) +#endif REAL :: ICE -!/STAB2 REAL :: STAB0, STAB, COR1, COR2, ASFAC, & -!/STAB2 THARG1, THARG2 +#ifdef W3_STAB2 + REAL :: STAB0, STAB, COR1, COR2, ASFAC, & + THARG1, THARG2 +#endif ! DOUBLE PRECISION :: OUTJULDAY ! @@ -1488,8 +1630,12 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) LOGICAL :: LASTSTATION=.FALSE. LOGICAL :: SHORT=.TRUE. LOGICAL :: LBREAK -!/ST3 LOGICAL :: LLWS(NSPEC) -!/ST4 LOGICAL :: LLWS(NSPEC) +#ifdef W3_ST3 + LOGICAL :: LLWS(NSPEC) +#endif +#ifdef W3_ST4 + LOGICAL :: LLWS(NSPEC) +#endif ! DATA VAR1 / 'Sin ' , 'Snl ', 'Sds ' , 'Sbt ' , 'Sice', 'Stot' / @@ -1500,7 +1646,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) !/ ! 1. Initialisations ! -!/S CALL STRACE (IENT, 'W3EXNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3EXNC') +#endif ! IF ( FLAGLL ) THEN M2KM = 1. @@ -1529,8 +1677,10 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) ! CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) ! -!/T WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) -!/T WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#ifdef W3_T + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1568,20 +1718,24 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) WN(IK) = SIG(IK)*SIG(IK)/GRAV CG(IK) = 0.5 * GRAV / SIG(IK) END IF -!/T WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#ifdef W3_T + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#endif ! END DO ! ! Computes 2nd order spectrum ! -!/IG1 IF (IGPARS(2).EQ.1) THEN -!/IG1 IF(IGPARS(1).EQ.1) THEN -!/IG1 CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 ELSE -!/IG1 CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 END IF -!/IG1 END IF +#ifdef W3_IG1 + IF (IGPARS(2).EQ.1) THEN + IF(IGPARS(1).EQ.1) THEN + CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) + ELSE + CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + END IF + END IF +#endif ! DO J1=1, NREQ @@ -1624,7 +1778,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) DO J1=1,NREQ UDIR1(J1) = MOD ( 270. - WDO(INDREQ(J1))*RADE , 360. ) CDIR1(J1) = MOD ( 270. - CDO(INDREQ(J1))*RADE , 360. ) -!/FLX5 TAUDIR1(J1) = MOD ( 270. - TAUDO(INDREQ(J1))*RADE , 360. ) +#ifdef W3_FLX5 + TAUDIR1(J1) = MOD ( 270. - TAUDO(INDREQ(J1))*RADE , 360. ) +#endif END DO ! IF (NCVARTYPE.LE.3) THEN @@ -1685,7 +1841,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) ! ! Open netCDF file ! -!/T WRITE (NDST,9002) PTNME(J) +#ifdef W3_T + WRITE (NDST,9002) PTNME(J) +#endif ! ! 2. Calculate grid parameters using and inlined version of WAVNU1. ! @@ -1696,24 +1854,32 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) UDIRR = WDO(J) UABS = MAX ( 0.001 , WAO(J) ) CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) -!/FLX5 TAUA = MAX ( 0.001 , TAUAO(J)) -!/FLX5 TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) -!/FLX5 RHOAIR = MAX ( 0. , DAIRO(J)) -!/IS2 ICEDMAX = MAX ( 0., ICEFO(J)) -!/IS2 ICEF = ICEDMAX +#ifdef W3_FLX5 + TAUA = MAX ( 0.001 , TAUAO(J)) + TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) + RHOAIR = MAX ( 0. , DAIRO(J)) +#endif +#ifdef W3_IS2 + ICEDMAX = MAX ( 0., ICEFO(J)) + ICEF = ICEDMAX +#endif ICETHICK = MAX (0., ICEHO(J)) ICECON = MAX (0., ICEO(J)) ! -!/STAB2 STAB0 = ZWIND * GRAV / 273. -!/STAB2 STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 -!/STAB2 STAB = MAX ( -1. , MIN ( 1. , STAB ) ) -!/STAB2 THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) -!/STAB2 THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) -!/STAB2 COR1 = CCNG * TANH(THARG1) -!/STAB2 COR2 = CCPS * TANH(THARG2) -!/STAB2 ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -! -!/T WRITE (NDST,9010) DEPTH +#ifdef W3_STAB2 + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif +! +#ifdef W3_T + WRITE (NDST,9010) DEPTH +#endif DO IK=1, NK SIX = SIG(IK) * SQRTH I1 = INT(SIX/DSIE) @@ -1727,19 +1893,23 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) WN(IK) = SIG(IK)*SIG(IK)/GRAV CG(IK) = 0.5 * GRAV / SIG(IK) END IF -!/T WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#ifdef W3_T + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#endif ! END DO ! ! Computes 2nd order spectrum ! -!/IG1 IF (IGPARS(2).EQ.1) THEN -!/IG1 IF(IGPARS(1).EQ.1) THEN -!/IG1 CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 ELSE -!/IG1 CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 END IF -!/IG1 END IF +#ifdef W3_IG1 + IF (IGPARS(2).EQ.1) THEN + IF(IGPARS(1).EQ.1) THEN + CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) + ELSE + CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + END IF + END IF +#endif ! ! ! 3. Prepare spectra etc. @@ -1856,81 +2026,131 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END DO END DO ! -!/STAB2 UABS = UABS / ASFAC -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST3 ZWND = ZZWND -!/ST3 TAUWX = 0. -!/ST3 TAUWY = 0. -!/ST3 LLWS(:) = .TRUE. -!/ST4 LLWS(:) = .TRUE. -!/ST4 ZWND = ZZWND -!/ST4 TAUWX = 0. -!/ST4 TAUWY = 0. -!/ST6 ZWND = 10. - -! -!/ST1 CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST6 CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -! -!/FLX1 CALL W3FLX1 ( ZWND, UABS, UDIRR, & -!/FLX1 USTAR, USTD, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & -!/FLX5 RHOAIR, USTAR, USTD, Z0, CD ) +#ifdef W3_STAB2 + UABS = UABS / ASFAC +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST3 + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:) = .TRUE. +#endif +#ifdef W3_ST4 + LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif + +! +#ifdef W3_ST1 + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN +#endif +#ifdef W3_ST2 + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif +! +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD ) +#endif ! DO ITT=1, 3 -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XIN, DIA ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 IX=1 -!/ST3 IY=1 -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST3 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& -!/ST3 TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 IX=1 -!/ST4 IY=1 -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS,DLWMEAN ) -!/ST4 CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & -!/ST4 DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) -!/ST4 CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST4 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & -!/ST4 TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + IX=1 + IY=1 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + IX=1 + IY=1 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS,DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif END DO ! ! Add alternative flux calculations here as part of !/ST2 option .... ! Also add before actual source term calculation !!! ! -!/STAB2 UABS = UABS * ASFAC +#ifdef W3_STAB2 + UABS = UABS * ASFAC +#endif ! IF ( WAO(J) .LT. 0.01 ) THEN UNORM = 0. @@ -1968,154 +2188,258 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) END DO END DO ! -!/STAB2 UABS = UABS / ASFAC -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST3 ZWND = ZZWND -!/ST0 USTAR = 1. -!/ST1 USTAR = 1. -!/ST2 USTAR = 1. -!/ST3 USTAR = 0. -!/ST3 USTD = 0. -!/ST3 TAUWX = 0. -!/ST3 TAUWY = 0. -!/ST4 ZWND = ZZWND -!/ST4 USTAR = 0. -!/ST4 USTD = 0. -!/ST4 TAUWX = 0. -!/ST4 TAUWY = 0. -!/ST6 ZWND = 10. -! -!/ST0 FHIGH = SIG(NK) -!/ST1 CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST1 FH1 = FXFM * FMEAN -!/ST1 FH2 = FXPM / USTAR -!/ST1 FHIGH = MAX ( FH1 , FH2 ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST4 CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & -!/ST4 DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) -!/ST6 CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -!/ST6 FHIGH = SIG(NK) -! -!/FLX1 CALL W3FLX1 ( ZWND, UABS, UDIRR, & -!/FLX1 USTAR, USTD, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & -!/FLX5 RHOAIR, USTAR, USTD, Z0, CD ) +#ifdef W3_STAB2 + UABS = UABS / ASFAC +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST3 + ZWND = ZZWND +#endif +#ifdef W3_ST0 + USTAR = 1. +#endif +#ifdef W3_ST1 + USTAR = 1. +#endif +#ifdef W3_ST2 + USTAR = 1. +#endif +#ifdef W3_ST3 + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST4 + ZWND = ZZWND + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif +! +#ifdef W3_ST0 + FHIGH = SIG(NK) +#endif +#ifdef W3_ST1 + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) +#endif +#ifdef W3_ST2 + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + FHIGH = SIG(NK) +#endif +! +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD ) +#endif ! DO ITT=1, 3 -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XIN, DIA ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST3 ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & -!/ST3 TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST4 CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST4 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,TAUWNX,& -!/ST4 TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,TAUWNX,& + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif END DO ! -!/ST2 FHIGH = XFC * FPI +#ifdef W3_ST2 + FHIGH = XFC * FPI +#endif ! IF ( FLSRCE(2) ) THEN -!/LN1 CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) -! -!/ST1 CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& -!/ST2 FPI, XIN, DIA ) -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & -!/ST3 DAIR/DWAT, ASO(J), UDIRR, & -!/ST3 Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & -!/ST3 ICE, XIN, DIA, LLWS, IX, IY ) -! -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST4 CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & -!/ST4 DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) -!/ST4 CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & -!/ST4 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & -!/ST4 TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/ST6 CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & -!/ST6 TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) +#ifdef W3_LN1 + CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) +#endif +! +#ifdef W3_ST1 + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& + FPI, XIN, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + ICE, XIN, DIA, LLWS, IX, IY ) +#endif +! +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) + CALL W3SIN4 (A, CG, WN2, UABS, USTAR, DAIR/DWAT, & + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY, TAUWNX, & + TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_ST6 + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & + TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) +#endif END IF IF ( FLSRCE(3) ) THEN -!/NL1 CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) -!/NL2 CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) -!/NL3 CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) -!/NL4 CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#ifdef W3_NL1 + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL2 + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL3 + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL4 + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif END IF IF ( FLSRCE(4) ) THEN -!/ST1 CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & -!/ST1 XDS, DIA ) -!/ST2 CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & -!/ST2 ALPHA, XDS, DIA ) -!/ST3 CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & -!/ST3 USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST4 CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & -!/ST4 DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) -!/ST6 CALL W3SDS6 ( A, CG, WN, XDS, DIA ) -!/ST6 IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) -! -!/DB1 CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & -!/DB1 WNMEAN, CG, LBREAK, XDB, DIA ) +#ifdef W3_ST1 + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & + XDS, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & + ALPHA, XDS, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP , DLWMEAN) +#endif +#ifdef W3_ST6 + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) +#endif +! +#ifdef W3_DB1 + CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & + WNMEAN, CG, LBREAK, XDB, DIA ) +#endif END IF IF ( FLSRCE(5) ) THEN -!/BT1 CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) -!/BT2 SBTC2 = 2. * -0.067 / GRAV -!/BT2 CALL W3SBT2 ( A, CG, WN, DEPTH, XBT, DIA, SBTC2 ) -!/BT4 IX=1 ! to be fixed later -!/BT4 IY=1 ! to be fixed later -!/BT4 ISEA=1 ! to be fixed later -!/BT4 D50 = SED_D50(ISEA) -!/BT4 PSIC= SED_PSIC(ISEA) -!/BT4 CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & -!/BT4 BEDFORM, XBT, DIA, IX, IY ) +#ifdef W3_BT1 + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) +#endif +#ifdef W3_BT2 + SBTC2 = 2. * -0.067 / GRAV + CALL W3SBT2 ( A, CG, WN, DEPTH, XBT, DIA, SBTC2 ) +#endif +#ifdef W3_BT4 + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) +#endif ! see remarks about BT8 and BT9 in ww3_outp.ftn !....broken....!/BT8 CALL W3SBT8 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) !....broken....!/BT9 CALL W3SBT9 ( SPEC, DEPTH, VSBT, VDBT, IX, IY ) ! -!/BS1 CALL W3SBS1 ( A, CG, WN, DEPTH, & -!/BS1 CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & -!/BS1 TAUSCX, TAUSCY, XBS, DIA ) +#ifdef W3_BS1 + CALL W3SBS1 ( A, CG, WN, DEPTH, & + CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) +#endif ! END IF IF ( FLSRCE(6) ) THEN @@ -2127,11 +2451,15 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) CG_ICE=CG END IF ! -!/IS2 CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & -!/IS2 IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#ifdef W3_IS2 + CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & + IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#endif END IF ! -!/STAB2 UABS = UABS * ASFAC +#ifdef W3_STAB2 + UABS = UABS * ASFAC +#endif ! IF ( ISCALE.EQ.0 .OR. ISCALE.EQ.3 ) THEN FACF = TPIINV @@ -2162,7 +2490,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) SWN(IK,ITH) = ( XLN(ITH,IK) + XIN(ITH,IK) ) * FACTOR SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR -!/ST6 SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#ifdef W3_ST6 + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#endif SBT(IK,ITH) = ( XBT(ITH,IK) + XBS(ITH,IK) ) * FACTOR SIS(IK,ITH) = XIS(ITH,IK) * FACTOR STT(IK,ITH) = SWN(IK,ITH) + SNL(IK,ITH) + SDS(IK,ITH) + & @@ -2336,7 +2666,9 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) IRET=NF90_PUT_VAR(NCID,VARID(8),CDIR,(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(9),WAO(J),(/ J1,IOUT /)) IRET=NF90_PUT_VAR(NCID,VARID(10),UDIR,(/ J1,IOUT /)) -!/SETUP IRET=NF90_PUT_VAR(NCID,VARID(11),ZET_SETO,(/ J1,IOUT /)) +#ifdef W3_SETUP + IRET=NF90_PUT_VAR(NCID,VARID(11),ZET_SETO,(/ J1,IOUT /)) +#endif ! ! Performs subtype 2 @@ -2636,16 +2968,18 @@ SUBROUTINE W3EXNC(I,NCID,NREQ,INDREQ,ORDER) 15X,' Mean wave direct. :',F7.1,' (degr)'/ & 15X,' Direct. spread :',F7.1,' (degr)'/) ! -!/T 9000 FORMAT (' TEST W3EXNC : FLAGS :',40L2) -!/T 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & -!/T ' OTPYE :',I4/ & -!/T ' NREQ :',I4/ & -!/T ' SCALE1 :',E10.3/ & -!/T ' SCALE2 :',E10.3/ & -!/T ' FLSRCE :',6L2) -!/T 9002 FORMAT (' TEST W3EXNC : OUTPUT POINT : ',A) -!/T 9010 FORMAT (' TEST W3EXNC : DEPTH =',F7.1,' IK, T, K, CG :') -!/T 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#ifdef W3_T + 9000 FORMAT (' TEST W3EXNC : FLAGS :',40L2) + 9001 FORMAT (' TEST W3EXNC : ITPYE :',I4/ & + ' OTPYE :',I4/ & + ' NREQ :',I4/ & + ' SCALE1 :',E10.3/ & + ' SCALE2 :',E10.3/ & + ' FLSRCE :',6L2) + 9002 FORMAT (' TEST W3EXNC : OUTPUT POINT : ',A) + 9010 FORMAT (' TEST W3EXNC : DEPTH =',F7.1,' IK, T, K, CG :') + 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif !/ !/ End of W3EXNC ----------------------------------------------------- / !/ @@ -2922,11 +3256,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF +#endif !f/fp @@ -2971,11 +3307,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(13),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TXY') IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station frequency') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') + END IF +#endif !sth1m IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/ DIMID(4),DIMID(TWO),DIMID(ONE) /), VARID(14)) @@ -3092,11 +3430,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Efth IF (NCVARTYPE.LE.3) THEN @@ -3131,11 +3471,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, END IF IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station frequency direction') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF +#endif !d IF (NCVARTYPE.LE.3) THEN @@ -3219,11 +3561,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, END IF IRET=NF90_PUT_ATT(NCID,VARID(13),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(13),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(13),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Uc IF (NCVARTYPE.LE.3) THEN @@ -3280,11 +3624,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, END IF IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') + END IF +#endif ! Add values in netCDF file @@ -3372,11 +3718,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Uc IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) @@ -3406,11 +3754,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(11),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Hs IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(12)) @@ -3468,11 +3818,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(15),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(15),'content','TXY') IRET=NF90_PUT_ATT(NCID,VARID(15),'associates','time station npart') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(15),'direction_reference','Rotated Pole Grid North') + END IF +#endif !sth1m IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT,(/DIMID(4),DIMID(TWO),DIMID(ONE)/),VARID(16)) @@ -3598,11 +3950,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(8),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(8),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(8),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(8),'direction_reference','Rotated Pole Grid North') + END IF +#endif !U10 IRET=NF90_DEF_VAR(NCID, 'wnd', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(9)) @@ -3632,26 +3986,30 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(10),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(10),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(10),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(10),'direction_reference','Rotated Pole Grid North') + END IF +#endif !zeta_setup -!/SETUP IRET=NF90_DEF_VAR(NCID, 'wave_setup', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) -!/SETUP IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wave setup') -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wave_induced_setup') -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wave_induced_setup') -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') -!/SETUP IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') +#ifdef W3_SETUP + IRET=NF90_DEF_VAR(NCID, 'wave_setup', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(11)) + IF (NCTYPE.EQ.4) IRET=NF90_DEF_VAR_DEFLATE(NCID, VARID(11), 1, 1, DEFLATE) + IRET=NF90_PUT_ATT(NCID,VARID(11),'long_name','wave setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'standard_name','wave_induced_setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'globwave_name','wave_induced_setup') + IRET=NF90_PUT_ATT(NCID,VARID(11),'units','m') + IRET=NF90_PUT_ATT(NCID,VARID(11),'scale_factor',1.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'add_offset',0.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_min',-100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'valid_max',100.) + IRET=NF90_PUT_ATT(NCID,VARID(11),'_FillValue',NF90_FILL_FLOAT) + IRET=NF90_PUT_ATT(NCID,VARID(11),'content','TX') + IRET=NF90_PUT_ATT(NCID,VARID(11),'associates','time station') +#endif ! NF90_ENDDEF function IRET=NF90_ENDDEF(NCID) @@ -3718,11 +4076,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(9),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(9),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF +#endif !sth1p IRET=NF90_DEF_VAR(NCID, 'sth1p', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) @@ -3766,11 +4126,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') + END IF +#endif !sth1m IRET=NF90_DEF_VAR(NCID, 'sth1m', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) @@ -3826,11 +4188,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF +#endif !fpst IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) @@ -3915,11 +4279,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF +#endif !fpst IRET=NF90_DEF_VAR(NCID, 'fpst', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) @@ -4003,11 +4369,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Hs IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) @@ -4120,11 +4488,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(7),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(7),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(7),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(7),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Hs IRET=NF90_DEF_VAR(NCID, 'hs', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(8)) @@ -4820,11 +5190,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(9),'valid_max',360.) IRET=NF90_PUT_ATT(NCID,VARID(9),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(9),'axis','Z') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(9),'direction_reference','Rotated Pole Grid North') + END IF +#endif !d IRET=NF90_DEF_VAR(NCID, 'dpt', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(10)) @@ -4869,11 +5241,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(12),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(12),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(12),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(12),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Uc IRET=NF90_DEF_VAR(NCID, 'cur', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(13)) @@ -4904,11 +5278,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(14),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(14),'content','TX') IRET=NF90_PUT_ATT(NCID,VARID(14),'associates','time station') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(14),'direction_reference','Rotated Pole Grid North') + END IF +#endif !Ust IRET=NF90_DEF_VAR(NCID, 'ust', NF90_FLOAT, (/ DIMID(TWO),DIMID(ONE) /), VARID(15)) @@ -4943,11 +5319,13 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(16),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(16),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(16),'associates','time station frequency direction') -!/RTD IF ( FLAGUNR ) THEN -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','True North') -!/RTD ELSE -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','Rotated Pole Grid North') -!/RTD END IF +#ifdef W3_RTD + IF ( FLAGUNR ) THEN + IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','True North') + ELSE + IRET=NF90_PUT_ATT(NCID,VARID(16),'direction_reference','Rotated Pole Grid North') + END IF +#endif ENDIF !Swn @@ -4965,7 +5343,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(17),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(17),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(17),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(17),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(17),'direction_reference','Rotated Pole Grid North') +#endif ENDIF !Snl @@ -4983,7 +5363,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(18),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(18),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(18),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(18),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(18),'direction_reference','Rotated Pole Grid North') +#endif ENDIF !Sds @@ -5001,7 +5383,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(19),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(19),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(19),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(19),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(19),'direction_reference','Rotated Pole Grid North') +#endif ENDIF !Sbt @@ -5019,7 +5403,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(20),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(20),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(20),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(20),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(20),'direction_reference','Rotated Pole Grid North') +#endif ENDIF !Sice @@ -5037,7 +5423,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(21),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(21),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(21),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(21),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(21),'direction_reference','Rotated Pole Grid North') +#endif ENDIF !Stt @@ -5055,7 +5443,9 @@ SUBROUTINE W3CRNC (ITYPE, OTYPE, NCTYPE, NCFILE, NCID, DIMID, DIMLN, VARID, ONE, IRET=NF90_PUT_ATT(NCID,VARID(22),'_FillValue',NF90_FILL_FLOAT) IRET=NF90_PUT_ATT(NCID,VARID(22),'content','TXYZ') IRET=NF90_PUT_ATT(NCID,VARID(22),'associates','time station frequency direction') -!/RTD IRET=NF90_PUT_ATT(NCID,VARID(22),'direction_reference','Rotated Pole Grid North') +#ifdef W3_RTD + IRET=NF90_PUT_ATT(NCID,VARID(22),'direction_reference','Rotated Pole Grid North') +#endif ENDIF ENDIF diff --git a/model/ftn/ww3_outf.ftn b/model/src/ww3_outf.F90 similarity index 93% rename from model/ftn/ww3_outf.ftn rename to model/src/ww3_outf.F90 index a7ed8df51..9ed2f7bd5 100644 --- a/model/ftn/ww3_outf.ftn +++ b/model/src/ww3_outf.F90 @@ -112,7 +112,9 @@ PROGRAM W3OUTF USE W3ADATMD, ONLY: W3NAUX, W3SETA USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD USE W3IOGRMD, ONLY: W3IOGR USE W3IOGOMD, ONLY: W3IOGO, W3READFLGRD @@ -146,7 +148,9 @@ PROGRAM W3OUTF TOUT(2), TDUM(2), IOTEST, NOUT, & ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & IDLA, IDFM, IOUT, IPART -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTREQ, DTEST CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11, & TABNME*9 @@ -175,7 +179,9 @@ PROGRAM W3OUTF NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3OUTF') +#ifdef W3_S + CALL STRACE (IENT, 'W3OUTF') +#endif ! WRITE (NDSO,900) ! @@ -579,7 +585,9 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY : W3S2XY -!/RTD USE W3SERVMD, ONLY : W3THRTN, W3XYRTN +#ifdef W3_RTD + USE W3SERVMD, ONLY : W3THRTN, W3XYRTN +#endif USE W3ARRYMD, ONLY : OUTA2I, PRTBLK !/ !/ ------------------------------------------------------------------- / @@ -599,7 +607,9 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) INTEGER, SAVE :: IPASS ! INTEGER, SAVE :: NCOL = 80 INTEGER, SAVE :: NCOL = 132 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: FSC, CABS, UABS, FSCA, XMIN, XMAX, & XAVG, XSTD, YGBX, XGBX, AABS REAL :: X1(NX+1,NY), X2(NX+1,NY), & @@ -609,23 +619,31 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) !!Li DOUBLE PRECISION :: XDS, XDSQ LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI -!/T LOGICAL :: LTEMP(NGRPP) +#ifdef W3_T + LOGICAL :: LTEMP(NGRPP) +#endif CHARACTER :: OLDTID*8, FNAME*32, ENAME*7, & FORMG*12, FORMF*11, UNITS*10, FSCS*7 CHARACTER, SAVE :: TIMEID*8 = '00000000' CHARACTER, SAVE :: FILEID*13 = 'WAVEWATCH III' -!/BT4 REAL, PARAMETER :: LOG2=LOG(2.) +#ifdef W3_BT4 + REAL, PARAMETER :: LOG2=LOG(2.) +#endif !/ !/ ------------------------------------------------------------------- / !/ -!/S CALL STRACE (IENT, 'W3EXGO') -! -!/T DO IFI=1, NOGRP -!/T LTEMP = FLREQ(IFI,:) -!/T WRITE (NDST,9000) IFI, LTEMP -!/T END DO -!/T WRITE (NDST,9001) ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & -!/T SCALE, VECTOR, NDSDAT +#ifdef W3_S + CALL STRACE (IENT, 'W3EXGO') +#endif +! +#ifdef W3_T + DO IFI=1, NOGRP + LTEMP = FLREQ(IFI,:) + WRITE (NDST,9000) IFI, LTEMP + END DO + WRITE (NDST,9001) ITYPE, IX1, IXN, IXS, IY1, IYN, IYS, & + SCALE, VECTOR, NDSDAT +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. Preparations @@ -650,7 +668,9 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) END IF NXTOT = 1 + (IXN-IX1)/IXS NBLOK = 1 + (NXTOT-1)/NXMAX -!/T WRITE (NDST,9012) NXMAX, NXTOT, NBLOK +#ifdef W3_T + WRITE (NDST,9012) NXMAX, NXTOT, NBLOK +#endif END IF ! ! Output file unit number @@ -681,7 +701,9 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FNAME(1:4) = ENAME IPASS = IPASS + 1 END IF -!/T WRITE (NDST,9014) FNAME(1:13) +#ifdef W3_T + WRITE (NDST,9014) FNAME(1:13) +#endif FORMG = '((10G12.2))' END IF ! @@ -693,7 +715,9 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) IF ( FLREQ(IFI,IFJ) ) THEN ! FORMF = '(1X,32I4)' -!/T WRITE (NDST,9020) IDOUT(IFI,IFJ) +#ifdef W3_T + WRITE (NDST,9020) IDOUT(IFI,IFJ) +#endif ! ! 2.a Set output arrays and parameters @@ -734,8 +758,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) ENAME = '.cur' UNITS = 'm s-1' FORMF = '(1X,17I7)' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = CX(1:NSEA) XS2 = CY(1:NSEA) @@ -774,8 +800,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.1 ENAME = '.wnd' UNITS = 'm s-1' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = UA(1:NSEA) XS2 = UD(1:NSEA) @@ -851,39 +879,45 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) CALL W3S2XY ( NSEA, NSEA, NX+1, NY, BERG , MAPSF, X1 ) ENDIF ! -!/BT4 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN -!/BT4 FLONE = .TRUE. -!/BT4 FSC = 0.01 -!/BT4 UNITS = 'Krumbein phi scale' -!/BT4 ENAME = '.d50' -!/BT4 WHERE ( SED_D50.NE.UNDEF) SED_D50 = -LOG(SED_D50/0.001)/LOG2 -!/BT4 IF ( ITYPE .EQ. 4 ) THEN -!/BT4 XS1 = SED_D50 -!/BT4 ELSE -!/BT4 CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SED_D50 , MAPSF, X1 ) -!/BT4 ENDIF -! -!/IS2 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN -!/IS2 FLONE = .TRUE. -!/IS2 FSC = 0.001 -!/IS2 UNITS = 'm' -!/IS2 ENAME = '.ic1' -!/IS2 IF ( ITYPE .EQ. 4) THEN -!/IS2 XS1 = ICEH -!/IS2 ELSE -!/IS2 CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEH, MAPSF, X1 ) -!/IS2 ENDIF -! -!/IS2 ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10) THEN -!/IS2 FLONE = .TRUE. -!/IS2 FSC = 0.001 -!/IS2 UNITS = 'm' -!/IS2 ENAME = '.ic5' -!/IS2 IF ( ITYPE .EQ. 4) THEN -!/IS2 XS1 = ICEF -!/IS2 ELSE -!/IS2 CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEF, MAPSF, X1 ) -!/IS2 ENDIF +#ifdef W3_BT4 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 8 ) THEN + FLONE = .TRUE. + FSC = 0.01 + UNITS = 'Krumbein phi scale' + ENAME = '.d50' + WHERE ( SED_D50.NE.UNDEF) SED_D50 = -LOG(SED_D50/0.001)/LOG2 + IF ( ITYPE .EQ. 4 ) THEN + XS1 = SED_D50 + ELSE + CALL W3S2XY ( NSEA, NSEA, NX+1, NY, SED_D50 , MAPSF, X1 ) + ENDIF +#endif +! +#ifdef W3_IS2 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 9 ) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm' + ENAME = '.ic1' + IF ( ITYPE .EQ. 4) THEN + XS1 = ICEH + ELSE + CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEH, MAPSF, X1 ) + ENDIF +#endif +! +#ifdef W3_IS2 + ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 10) THEN + FLONE = .TRUE. + FSC = 0.001 + UNITS = 'm' + ENAME = '.ic5' + IF ( ITYPE .EQ. 4) THEN + XS1 = ICEF + ELSE + CALL W3S2XY (NSEA, NSEA, NX+1, NY, ICEF, MAPSF, X1 ) + ENDIF +#endif ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. @@ -956,8 +990,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1. UNITS = 'degree' ENAME = '.dir' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( THM(ISEA) .NE. UNDEF ) & THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) @@ -984,8 +1020,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1. UNITS = 'degree' ENAME = '.dp' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( THP0(ISEA) .NE. UNDEF ) THEN THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) @@ -1156,8 +1194,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1. UNITS = 'degree' ENAME = '.pdir' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,IPART), AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( PDIR(ISEA,IPART) .NE. UNDEF ) THEN PDIR(ISEA,IPART) = & @@ -1200,8 +1240,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.0 UNITS = 'degree' ENAME = '.pdp' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, PTHP0(:,IPART), AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( PTHP0(ISEA,IPART) .NE. UNDEF ) THEN PTHP0(ISEA,IPART) = & @@ -1335,8 +1377,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) ENAME = '.ust' FORMF = '(1X,20I6)' UNITS = 'm s-1' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = UST (1:NSEA) XS2 = USTDIR(1:NSEA) @@ -1421,8 +1465,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-6 UNITS = 'm2 s-2' ENAME = '.taw' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX, TAUWIY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWIX, TAUWIY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TAUWIX(1:NSEA) XS2 = TAUWIY(1:NSEA) @@ -1465,8 +1511,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-6 UNITS = 'm2 s-2' ENAME = '.twa' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX, TAUWNY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUWNX, TAUWNY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TAUWNX(1:NSEA) XS2 = TAUWNY(1:NSEA) @@ -1553,8 +1601,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 10. UNITS = 'N m-1' ENAME = '.sxy' -!/RTD ! Radition stress components are always left on rotated pole -!/RTD ! at present - need to confirm how to de-rotate (A. Saulter) +#ifdef W3_RTD + ! Radition stress components are always left on rotated pole + ! at present - need to confirm how to de-rotate (A. Saulter) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = SXX(1:NSEA) XS2 = SYY(1:NSEA) @@ -1577,8 +1627,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-6 UNITS = 'm2 s-2' ENAME = '.two' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX, TAUOY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOX, TAUOY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TAUOX(1:NSEA) XS2 = TAUOY(1:NSEA) @@ -1647,8 +1699,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.001 UNITS = 'm2 s-1' ENAME = '.tus' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX, TUSY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TUSX, TUSY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TUSX(1:NSEA) XS2 = TUSY(1:NSEA) @@ -1692,8 +1746,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) USSY(ISEA)=MAX(-0.9998,MIN(0.9998,USSY(ISEA))) END IF END DO -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX, USSY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, USSX, USSY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = USSX(1:NSEA) XS2 = USSY(1:NSEA) @@ -1749,8 +1805,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-6 UNITS = 'm2 s-2' ENAME = '.toc' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX, TAUOCY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUOCX, TAUOCY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TAUOCX(1:NSEA) XS2 = TAUOCY(1:NSEA) @@ -1792,8 +1850,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.01 ENAME = '.abr' UNITS = 'm' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA, ABD, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, ABA, ABD, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = ABA(1:NSEA) XS2 = ABD(1:NSEA) @@ -1834,8 +1894,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.01 ENAME = '.ubr' UNITS = 'm s-1' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA, UBD, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UBA, UBD, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = UBA(1:NSEA) XS2 = UBD(1:NSEA) @@ -1872,9 +1934,11 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-2 UNITS = 'm' ENAME = '.bed' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & -!/RTD BEDFORMS(1:NSEA,3), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, BEDFORMS(1:NSEA,2), & + BEDFORMS(1:NSEA,3), AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = BEDFORMS(1:NSEA,1) XS2 = BEDFORMS(1:NSEA,2) @@ -1905,9 +1969,11 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 1.E-6 UNITS = 'm2 s-2' ENAME = '.tbb' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & -!/RTD TAUBBL(1:NSEA,2), AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, TAUBBL(1:NSEA,1), & + TAUBBL(1:NSEA,2), AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = TAUBBL(1:NSEA,1) XS2 = TAUBBL(1:NSEA,2) @@ -1928,8 +1994,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) ENAME = '.mss' FORMF = '(1X,20I6)' UNITS = '1' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSSX, MSSY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = MSSX(1:NSEA) XS2 = MSSY(1:NSEA) @@ -1949,8 +2017,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.00001 ENAME = '.msc' UNITS = '1' -!/RTD ! Rotate x,y vector back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) +#ifdef W3_RTD + ! Rotate x,y vector back to standard pole + IF ( FLAGUNR ) CALL W3XYRTN(NSEA, MSCX, MSCY, AnglD) +#endif IF ( ITYPE .EQ. 4 ) THEN XS1 = MSCX(1:NSEA) XS2 = MSCY(1:NSEA) @@ -1989,8 +2059,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.1 UNITS = 'degree' ENAME = '.msd' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSSD, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( MSSD(ISEA) .NE. UNDEF ) THEN MSSD(ISEA) = MOD ( 630. - RADE*MSSD(ISEA) , 180. ) @@ -2007,8 +2079,10 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) FSC = 0.1 UNITS = 'degree' ENAME = '.mcd' -!/RTD ! Rotate direction back to standard pole -!/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) +#ifdef W3_RTD + ! Rotate direction back to standard pole + IF ( FLAGUNR ) CALL W3THRTN(NSEA, MSCD, AnglD, .FALSE.) +#endif DO ISEA=1, NSEA IF ( MSCD(ISEA) .NE. UNDEF ) THEN MSCD(ISEA) = MOD ( 630. - RADE*MSCD(ISEA) , 180. ) @@ -2468,17 +2542,23 @@ SUBROUTINE W3EXGO ( NX, NY, NSEA ) ' ERROR IN OPENING OUTPUT FILE'/ & ' IOSTAT =',I5/) ! -!/T 9000 FORMAT (' TEST W3EXGO : FLAGS :',I3,2X,20L2) -!/T 9001 FORMAT (' TEST W3EXGO : ITPYE :',I4/ & -!/T ' IX1/N/S :',3I4/ & -!/T ' IY1/N/S :',3I4/ & -!/T ' SCALE, VECTOR :',2L2/ & -!/T ' NDSDAT :',I4) -! -!/T 9012 FORMAT (' TEST W3EXGO : BLOK PARS : ',3I4) -!/T 9014 FORMAT (' BASE NAME : ',A) -! -!/T 9020 FORMAT (' TEST W3EXGO : OUTPUT FIELD : ',A) +#ifdef W3_T + 9000 FORMAT (' TEST W3EXGO : FLAGS :',I3,2X,20L2) + 9001 FORMAT (' TEST W3EXGO : ITPYE :',I4/ & + ' IX1/N/S :',3I4/ & + ' IY1/N/S :',3I4/ & + ' SCALE, VECTOR :',2L2/ & + ' NDSDAT :',I4) +#endif +! +#ifdef W3_T + 9012 FORMAT (' TEST W3EXGO : BLOK PARS : ',3I4) + 9014 FORMAT (' BASE NAME : ',A) +#endif +! +#ifdef W3_T + 9020 FORMAT (' TEST W3EXGO : OUTPUT FIELD : ',A) +#endif !/ !/ End of W3EXGO ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_outp.ftn b/model/src/ww3_outp.F90 similarity index 80% rename from model/ftn/ww3_outp.ftn rename to model/src/ww3_outp.F90 index 1b5997469..206dddd87 100644 --- a/model/ftn/ww3_outp.ftn +++ b/model/src/ww3_outp.F90 @@ -168,12 +168,16 @@ PROGRAM W3OUTP !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG USE W3WDATMD, ONLY: W3SETW, W3NDAT -!/NL1 USE W3ADATMD, ONLY: W3SETA, W3NAUX +#ifdef W3_NL1 + USE W3ADATMD, ONLY: W3SETA, W3NAUX +#endif USE W3ODATMD, ONLY: W3SETO, W3NOUT USE W3IOGRMD, ONLY: W3IOGR USE W3IOPOMD, ONLY: W3IOPO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 !/ USE W3GDATMD @@ -181,13 +185,21 @@ PROGRAM W3OUTP USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOPTS, PTLOC, PTNME, & DPO, WAO, WDO, ASO, CAO, CDO, SPCO, FNMPRE,& ICEO, ICEHO, ICEFO, DIMP -!/FLX5 USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#ifdef W3_FLX5 + USE W3ODATMD, ONLY: TAUAO, TAUDO, DAIRO +#endif USE W3BULLMD, ONLY: NPTAB, NFLD, NPMAX, BHSMIN, BHSDROP, IYY, & HST, TPT, DMT, ASCBLINE, CSVBLINE -!/NCO USE W3BULLMD, ONLY: CASCBLINE -!/O14 USE W3ODATMD, ONLY: GRDID -!/IG1 USE W3GIG1MD, ONLY: W3ADDIG -!/IG1 USE W3CANOMD, ONLY: W3ADD2NDORDER +#ifdef W3_NCO + USE W3BULLMD, ONLY: CASCBLINE +#endif +#ifdef W3_O14 + USE W3ODATMD, ONLY: GRDID +#endif +#ifdef W3_IG1 + USE W3GIG1MD, ONLY: W3ADDIG + USE W3CANOMD, ONLY: W3ADD2NDORDER +#endif ! IMPLICIT NONE !/ @@ -199,11 +211,17 @@ PROGRAM W3OUTP NREQ, IPOINT, ITYPE, OTYPE, NDSTAB, & IOTEST, IK, ITH, IOUT, J, DIMXP, & NDSBUL, NDSCSV, ICSV, IJ -!/NCO INTEGER :: NDSCBUL +#ifdef W3_NCO + INTEGER :: NDSCBUL +#endif INTEGER :: ISCALE = 0 INTEGER :: TIMEV(2) -!/O14 INTEGER :: NDBO -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_O14 + INTEGER :: NDBO +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DTREQ, SCALE1, SCALE2, DTEST REAL :: M2KM REAL, ALLOCATABLE :: XPART(:,:) @@ -213,7 +231,9 @@ PROGRAM W3OUTP TABNME*9, TFNAME*16 CHARACTER(LEN=25) :: IDSRCE(7) CHARACTER :: HSTR*6, HTYPE*3 -!/BT2 REAL :: SBTC2 +#ifdef W3_BT2 + REAL :: SBTC2 +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -226,7 +246,9 @@ PROGRAM W3OUTP 'Sum of selected sources ' / FLSRCE = .FALSE. ! -!/NCO/! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#ifdef W3_NCO +! CALL W3TAGB('WAVESPEC',1998,0007,0050,'NP21 ') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. IO set-up. @@ -235,8 +257,10 @@ PROGRAM W3OUTP CALL W3SETG ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) CALL W3SETW ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -244,26 +268,36 @@ PROGRAM W3OUTP NDSM = 20 NDSOP = 20 NDSBUL = 0 -!/NCO NDSCBUL = 0 +#ifdef W3_NCO + NDSCBUL = 0 +#endif ! NDSTRC = 6 NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3OUTP') +#ifdef W3_S + CALL STRACE (IENT, 'W3OUTP') +#endif ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSOP = 13 -!/O14 NDBO = 14 -!/NCO NDSTRC = NDSO +#ifdef W3_NCO +! +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSOP = 13 +#endif +#ifdef W3_O14 + NDBO = 14 +#endif +#ifdef W3_NCO + NDSTRC = NDSO +#endif ! WRITE (NDSO,900) ! @@ -376,14 +410,16 @@ PROGRAM W3OUTP ! IF ( ITYPE .EQ. 0 ) THEN ! -!/O14 WRITE (NDSO,942) ITYPE, 'Generating buoy log file' -!/O14 OPEN (NDBO,FILE=FNMPRE(:J)//'buoy_log.ww3', & -!/O14 STATUS='NEW',ERR=805,IOSTAT=IERR) -!/O14 DO I = 1,NOPTS -!/O14 WRITE(NDBO,945) I, PTNME(I), PTLOC(1,I), & -!/O14 PTLOC(2,I), GRDID(I) -!/O14 END DO -!/O14 CLOSE(NDBO) +#ifdef W3_O14 + WRITE (NDSO,942) ITYPE, 'Generating buoy log file' + OPEN (NDBO,FILE=FNMPRE(:J)//'buoy_log.ww3', & + STATUS='NEW',ERR=805,IOSTAT=IERR) + DO I = 1,NOPTS + WRITE(NDBO,945) I, PTNME(I), PTLOC(1,I), & + PTLOC(2,I), GRDID(I) + END DO + CLOSE(NDBO) +#endif ! WRITE (NDSO,942) ITYPE, 'Checking contents of file' DO @@ -403,7 +439,9 @@ PROGRAM W3OUTP CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & NDSTAB, FLFORM -!/NCO NDSTAB = 51 +#ifdef W3_NCO + NDSTAB = 51 +#endif IF (OTYPE .EQ. 1) THEN WRITE (NDSO,943) 'print plots' IF ( SCALE1 .LT. 0. ) THEN @@ -468,7 +506,9 @@ PROGRAM W3OUTP WRITE (NDSO,942) ITYPE, 'Table of mean wave parameters' CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB -!/NCO NDSTAB = 51 +#ifdef W3_NCO + NDSTAB = 51 +#endif TABNME = 'tab--.ww3' IF ( NDSTAB.LE.0 .OR. NDSTAB.GT.99 ) NDSTAB = 51 WRITE ( TABNME(4:5) , '(I2.2)' ) NDSTAB @@ -500,7 +540,9 @@ PROGRAM W3OUTP CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) OTYPE, SCALE1, SCALE2, & NDSTAB, FLSRCE, ISCALE, FLFORM -!/NCO NDSTAB = 51 +#ifdef W3_NCO + NDSTAB = 51 +#endif ISCALE = MAX ( 0 , MIN ( 5 , ISCALE ) ) IF ( OTYPE .EQ. 1 ) THEN WRITE (NDSO,943) 'Print plots' @@ -594,7 +636,9 @@ PROGRAM W3OUTP WRITE (NDSO,942) ITYPE, 'Spectral partitions or bulletins' CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) OTYPE, NDSTAB, TIMEV, HTYPE -!/NCO NDSTAB = 51 +#ifdef W3_NCO + NDSTAB = 51 +#endif IF ( OTYPE .EQ. 1 ) THEN WRITE (NDSO,943) 'Partitioning of spectra' TABNME = 'tab--.ww3' @@ -618,9 +662,11 @@ PROGRAM W3OUTP NDSBUL = NDSTAB + (IJ - 1) OPEN(NDSBUL,FILE=TRIM(PTNME(IJ))//'.bull',ERR=803,IOSTAT=IERR) WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.bull' -!/NCO NDSCBUL = NDSTAB + (IJ - 1) + NOPTS -!/NCO OPEN(NDSCBUL,FILE=TRIM(PTNME(IJ))//'.cbull',ERR=803,IOSTAT=IERR) -!/NCO WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.cbull' +#ifdef W3_NCO + NDSCBUL = NDSTAB + (IJ - 1) + NOPTS + OPEN(NDSCBUL,FILE=TRIM(PTNME(IJ))//'.cbull',ERR=803,IOSTAT=IERR) + WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.cbull' +#endif ENDIF ENDDO ENDIF @@ -631,7 +677,9 @@ PROGRAM W3OUTP IF (FLREQ(IJ)) THEN ICSV = 0 IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL -!/NCO IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL +#ifdef W3_NCO + IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL +#endif NDSCSV = NDSTAB + (IJ - 1) + ICSV OPEN(NDSCSV,FILE=TRIM(PTNME(IJ))//'.csv',ERR=803,IOSTAT=IERR) WRITE (NDSO,1947) TRIM(PTNME(IJ))//'.csv' @@ -675,12 +723,24 @@ PROGRAM W3OUTP ! ! remark: it would be better to write these warnings only if source term ! output is requested -!/IC1 WRITE(NDSO,3960) -!/IC2 WRITE(NDSO,3960) -!/IC3 WRITE(NDSO,3960) -!/IC4 WRITE(NDSO,3960) -!/IC5 WRITE(NDSO,3960) -!/NL5 WRITE(NDSO,3961) +#ifdef W3_IC1 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC2 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC3 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC4 + WRITE(NDSO,3960) +#endif +#ifdef W3_IC5 + WRITE(NDSO,3960) +#endif +#ifdef W3_NL5 + WRITE(NDSO,3961) +#endif DO DTEST = DSEC21 ( TIME , TOUT ) @@ -716,9 +776,11 @@ PROGRAM W3OUTP NDSBUL = NDSTAB + (IJ - 1) WRITE(NDSBUL,971) WRITE(NDSBUL,974) BHSDROP, BHSMIN -!/NCO NDSCBUL = NDSTAB + (IJ - 1) + NOPTS -!/NCO WRITE(NDSCBUL,961) -!/NCO WRITE(NDSCBUL,962) +#ifdef W3_NCO + NDSCBUL = NDSTAB + (IJ - 1) + NOPTS + WRITE(NDSCBUL,961) + WRITE(NDSCBUL,962) +#endif ENDIF ENDDO ENDIF @@ -747,15 +809,19 @@ PROGRAM W3OUTP WRITE (NDSE,1004) IERR CALL EXTCDE ( 44 ) ! -!/O14 805 CONTINUE -!/O14 WRITE (NDSE,1005) IERR -!/O14 CALL EXTCDE ( 45 ) +#ifdef W3_O14 + 805 CONTINUE + WRITE (NDSE,1005) IERR + CALL EXTCDE ( 45 ) +#endif ! 888 CONTINUE ! WRITE (NDSO,999) ! -!/NCO/! CALL W3TAGE('WAVESPEC') +#ifdef W3_NCO +! CALL W3TAGE('WAVESPEC') +#endif ! ! Formats ! @@ -780,7 +846,9 @@ PROGRAM W3OUTP ' ',A/) 943 FORMAT ( ' Subtype : ',A) 944 FORMAT ( ' ',A) -!/O14 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#ifdef W3_O14 + 945 FORMAT ( ' ',I5,3X,A,2F10.2,3X,A) +#endif 948 FORMAT ( ' Data for ',A) 949 FORMAT (/' End of file reached '/) ! @@ -790,14 +858,16 @@ PROGRAM W3OUTP 953 FORMAT ( ' ',A,2(F8.1,'E3')) 952 FORMAT (/' Output times :'/ & ' --------------------------------------------------') -!/NCO 961 FORMAT ('----------------------------------------', & -!/NCO '---------------------------') -!/NCO 962 FORMAT ( 'DD = Day of Month'/ & -!/NCO 'HH = Hour of Day'/ & -!/NCO 'HS = Total Significant Wave Height (feet)'/ & -!/NCO 'SS = Significant Wave Height of separate system (feet)'/ & -!/NCO 'PP = Peak Period of separate system (whole seconds)'/ & -!/NCO 'DDD = Mean Direction of separate system (degrees,"from")') +#ifdef W3_NCO + 961 FORMAT ('----------------------------------------', & + '---------------------------') + 962 FORMAT ( 'DD = Day of Month'/ & + 'HH = Hour of Day'/ & + 'HS = Total Significant Wave Height (feet)'/ & + 'SS = Significant Wave Height of separate system (feet)'/ & + 'PP = Peak Period of separate system (whole seconds)'/ & + 'DDD = Mean Direction of separate system (degrees,"from")') +#endif 971 FORMAT (' +-------+-----------+-----------------+', & '-----------------+-----------------+----', & '-------------+-----------------+--------', & @@ -858,9 +928,11 @@ PROGRAM W3OUTP ' ERROR IN OPENING IDL FILE'/ & ' IOSTAT =',I5/) ! -!/O14 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & -!/O14 ' ERROR IN OPENING BUOY LOG FILE'/ & -!/O14 ' IOSTAT =',I5/) +#ifdef W3_O14 + 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & + ' ERROR IN OPENING BUOY LOG FILE'/ & + ' IOSTAT =',I5/) +#endif ! 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & ' ERROR IN READING FROM INPUT FILE'/ & @@ -876,24 +948,36 @@ PROGRAM W3OUTP 1012 FORMAT (/' *** WAVEWATCH III ERROR IN W3OUTP : '/ & ' MULTIPLE OUTPUT POINTS DEFINED, ITYPE =',I4,/ & ' ONLY SINGLE POINT ALLOWED IN THIS VERSION'/) -!/IC1 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/IC1 ' Ice source terms !/IC1 skipped'/ & -!/IC1 ' in dissipation term.'/) -!/IC2 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/IC2 ' Ice source terms !/IC2 skipped'/ & -!/IC2 ' in dissipation term.'/) -!/IC3 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/IC3 ' Ice source terms !/IC3 skipped'/ & -!/IC3 ' in dissipation term.'/) -!/IC4 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/IC4 ' Ice source terms !/IC4 skipped'/ & -!/IC4 ' in dissipation term.'/) -!/IC5 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/IC5 ' Ice source terms !/IC5 skipped'/ & -!/IC5 ' in dissipation term.'/) -!/NL5 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & -!/NL5 ' Snl source terms !/NL5 skipped'/ & -!/NL5 ' in interaction term.'/) +#ifdef W3_IC1 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC1 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC2 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC2 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC3 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC3 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC4 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC4 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_IC5 + 3960 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Ice source terms !/IC5 skipped'/ & + ' in dissipation term.'/) +#endif +#ifdef W3_NL5 + 3961 FORMAT (/' *** WAVEWATCH-III WARNING IN W3OUTP :'/ & + ' Snl source terms !/NL5 skipped'/ & + ' in interaction term.'/) +#endif ! !/ !/ Internal subroutine W3EXPO ---------------------------------------- / @@ -1061,33 +1145,81 @@ SUBROUTINE W3EXPO ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/FLX1 USE W3FLX1MD -!/FLX2 USE W3FLX2MD -!/FLX3 USE W3FLX3MD -!/FLX4 USE W3FLX4MD -!/FLX5 USE W3FLX5MD -!/LN1 USE W3SLN1MD -!/ST1 USE W3SRC1MD -!/ST2 USE W3SRC2MD -!/ST3 USE W3SRC3MD -!/ST4 USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 -!/ST6 USE W3SRC6MD -!/ST6 USE W3SWLDMD, ONLY : W3SWL6 -!/ST6 USE W3GDATMD, ONLY : SWL6S6 -!/NL1 USE W3SNL1MD -!/NL2 USE W3SNL2MD -!/NL3 USE W3SNL3MD -!/NL4 USE W3SNL4MD -!/NLS USE W3SNLSMD -!/BT1 USE W3SBT1MD -!/BT2 USE W3SBT2MD -!/BT4 USE W3SBT4MD -!/BT8 USE W3SBT8MD -!/BT9 USE W3SBT9MD -!/DB1 USE W3SDB1MD -!/BS1 USE W3SBS1MD -!/IS2 USE W3SIS2MD -!/IS2 USE W3GDATMD, ONLY: IICEDISP +#ifdef W3_FLX1 + USE W3FLX1MD +#endif +#ifdef W3_FLX2 + USE W3FLX2MD +#endif +#ifdef W3_FLX3 + USE W3FLX3MD +#endif +#ifdef W3_FLX4 + USE W3FLX4MD +#endif +#ifdef W3_FLX5 + USE W3FLX5MD +#endif +#ifdef W3_LN1 + USE W3SLN1MD +#endif +#ifdef W3_ST1 + USE W3SRC1MD +#endif +#ifdef W3_ST2 + USE W3SRC2MD +#endif +#ifdef W3_ST3 + USE W3SRC3MD +#endif +#ifdef W3_ST4 + USE W3SRC4MD, ONLY : W3SPR4, W3SIN4, W3SDS4 +#endif +#ifdef W3_ST6 + USE W3SRC6MD + USE W3SWLDMD, ONLY : W3SWL6 + USE W3GDATMD, ONLY : SWL6S6 +#endif +#ifdef W3_NL1 + USE W3SNL1MD +#endif +#ifdef W3_NL2 + USE W3SNL2MD +#endif +#ifdef W3_NL3 + USE W3SNL3MD +#endif +#ifdef W3_NL4 + USE W3SNL4MD +#endif +#ifdef W3_NLS + USE W3SNLSMD +#endif +#ifdef W3_BT1 + USE W3SBT1MD +#endif +#ifdef W3_BT2 + USE W3SBT2MD +#endif +#ifdef W3_BT4 + USE W3SBT4MD +#endif +#ifdef W3_BT8 + USE W3SBT8MD +#endif +#ifdef W3_BT9 + USE W3SBT9MD +#endif +#ifdef W3_DB1 + USE W3SDB1MD +#endif +#ifdef W3_BS1 + USE W3SBS1MD +#endif +#ifdef W3_IS2 + USE W3SIS2MD + USE W3GDATMD, ONLY: IICEDISP +#endif USE W3PARTMD, ONLY: W3PART USE W3DISPMD, ONLY: WAVNU1, LIU_FORWARD_DISPERSION !/ @@ -1102,7 +1234,9 @@ SUBROUTINE W3EXPO IK, IH, IM, IS, IYR, IMTH, IDY, ITT, & I, NPART, IP, IX, IY, ISEA INTEGER, SAVE :: IPASS = 0 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif REAL :: DEPTH, SQRTH, CDIR, SIX, R1, R2, & UDIR, UDIRR, UABS, XL, XH, XL2, XH2, & ET, EWN, ETR, ETX, ETY, EBND, EBX, & @@ -1115,20 +1249,40 @@ SUBROUTINE W3EXPO FMEAN, WNMEAN, UDIRCA, X, Y, CHARN, & M2KM, ICEF, ICEDMAX, ICETHICK, & ICECON -!/FLX5 REAL ::TAUA, TAUADIR, RHOAIR -!/IS2 REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK) -!/ST1 REAL :: AMAX, FH1, FH2 -!/ST2 REAL :: AMAX, ALPHA(NK), FPI -!/ST3 REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & -!/ST3 TAUWNX, TAUWNY -!/ST4 REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & -!/ST4 TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN -!/ST6 REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY -!/BS1 REAL :: TAUSCX, TAUSCY -!/BT4 REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) +#ifdef W3_FLX5 + REAL ::TAUA, TAUADIR, RHOAIR +#endif +#ifdef W3_IS2 + REAL :: WN_R(NK),CG_ICE(NK), ALPHA_LIU(NK) +#endif +#ifdef W3_ST1 + REAL :: AMAX, FH1, FH2 +#endif +#ifdef W3_ST2 + REAL :: AMAX, ALPHA(NK), FPI +#endif +#ifdef W3_ST3 + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY +#endif +#ifdef W3_ST4 + REAL :: AMAX, FMEANS, FMEANWS, TAUWX, TAUWY, & + TAUWNX, TAUWNY, FMEAN1, WHITECAP(1:4), DLWMEAN +#endif +#ifdef W3_ST6 + REAL :: AMAX, TAUWX, TAUWY, TAUWNX, TAUWNY +#endif +#ifdef W3_BS1 + REAL :: TAUSCX, TAUSCY +#endif +#ifdef W3_BT4 + REAL :: D50, PSIC, BEDFORM(3), TAUBBL(2) +#endif REAL :: ICE -!/STAB2 REAL :: STAB0, STAB, COR1, COR2, ASFAC, & -!/STAB2 THARG1, THARG2 +#ifdef W3_STAB2 + REAL :: STAB0, STAB, COR1, COR2, ASFAC, & + THARG1, THARG2 +#endif REAL, SAVE :: HSMIN = 0.05 REAL :: WN(NK), CG(NK), R(NK) REAL :: E(NK,NTH), E1(NK), APM(NK), & @@ -1145,9 +1299,13 @@ SUBROUTINE W3EXPO SBT1(NK), STT1(NK), SIS1(NK), & E1ALL(NK,6) LOGICAL :: LBREAK -!/ST3 LOGICAL :: LLWS(NSPEC) -!/ST4 LOGICAL :: LLWS(NSPEC) -!/ST4 REAL :: LAMBDA(NSPEC) +#ifdef W3_ST3 + LOGICAL :: LLWS(NSPEC) +#endif +#ifdef W3_ST4 + LOGICAL :: LLWS(NSPEC) + REAL :: LAMBDA(NSPEC) +#endif CHARACTER :: DTME21*23 CHARACTER(LEN=4) VAR1(6) CHARACTER(LEN=1) IDLAT, IDLON @@ -1159,7 +1317,9 @@ SUBROUTINE W3EXPO !/ ! 1. Initialisations ! -!/S CALL STRACE (IENT, 'W3EXPO') +#ifdef W3_S + CALL STRACE (IENT, 'W3EXPO') +#endif ! IF ( FLAGLL ) THEN M2KM = 1. @@ -1187,8 +1347,10 @@ SUBROUTINE W3EXPO XIS = 0. END IF ! -!/T WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) -!/T WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#ifdef W3_T + WRITE (NDST,9000) (FLREQ(J),J=1,NOPTS) + WRITE (NDST,9001) ITYPE, OTYPE, NREQ, SCALE1, SCALE2, FLSRCE +#endif ! ! Output of time ! @@ -1265,7 +1427,9 @@ SUBROUTINE W3EXPO DO J=1, NOPTS IF ( FLREQ(J) ) THEN ! -!/T WRITE (NDST,9002) PTNME(J) +#ifdef W3_T + WRITE (NDST,9002) PTNME(J) +#endif ! ! 2. Calculate grid parameters using and inlined version of WAVNU1. ! @@ -1275,25 +1439,31 @@ SUBROUTINE W3EXPO UDIRCA = WDO(J)*RADE UDIRR = WDO(J) UABS = MAX ( 0.001 , WAO(J) ) -!/FLX5 TAUA = MAX ( 0.001 , TAUAO(J)) -!/FLX5 TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) -!/FLX5 RHOAIR = MAX ( 0. , DAIRO(J)) +#ifdef W3_FLX5 + TAUA = MAX ( 0.001 , TAUAO(J)) + TAUADIR = MOD ( 270. - TAUDO(J)*RADE , 360. ) + RHOAIR = MAX ( 0. , DAIRO(J)) +#endif CDIR = MOD ( 270. - CDO(J)*RADE , 360. ) ICEDMAX = MAX ( 0., ICEFO(J)) ICEF = ICEDMAX ICETHICK = MAX (0., ICEHO(J)) ICECON = MAX (0., ICEO(J)) ! -!/STAB2 STAB0 = ZWIND * GRAV / 273. -!/STAB2 STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 -!/STAB2 STAB = MAX ( -1. , MIN ( 1. , STAB ) ) -!/STAB2 THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) -!/STAB2 THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) -!/STAB2 COR1 = CCNG * TANH(THARG1) -!/STAB2 COR2 = CCPS * TANH(THARG2) -!/STAB2 ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) -! -!/T WRITE (NDST,9010) DEPTH +#ifdef W3_STAB2 + STAB0 = ZWIND * GRAV / 273. + STAB = STAB0 * ASO(J) / MAX(5.,WAO(J))**2 + STAB = MAX ( -1. , MIN ( 1. , STAB ) ) + THARG1 = MAX ( 0. , FFNG*(STAB-OFSTAB)) + THARG2 = MAX ( 0. , FFPS*(STAB-OFSTAB)) + COR1 = CCNG * TANH(THARG1) + COR2 = CCPS * TANH(THARG2) + ASFAC = SQRT ( (1.+COR1+COR2)/SHSTAB ) +#endif +! +#ifdef W3_T + WRITE (NDST,9010) DEPTH +#endif DO IK=1, NK SIX = SIG(IK) * SQRTH I1 = INT(SIX/DSIE) @@ -1307,20 +1477,24 @@ SUBROUTINE W3EXPO WN(IK) = SIG(IK)*SIG(IK)/GRAV CG(IK) = 0.5 * GRAV / SIG(IK) END IF -!/T WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#ifdef W3_T + WRITE (NDST,9011) IK, TPI/SIG(IK), WN(IK), CG(IK) +#endif ! END DO ! ! Computes 2nd order spectrum ! -!/IG1 IF (IGPARS(2).EQ.1) THEN -!/IG1 IF(IGPARS(1).EQ.1) THEN -!/IG1 CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 ELSE -!/IG1 CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) -!/IG1 END IF -!/IG1 END IF +#ifdef W3_IG1 + IF (IGPARS(2).EQ.1) THEN + IF(IGPARS(1).EQ.1) THEN + CALL W3ADDIG(SPCO(:,J),DPO(J),WN,CG,0) + ELSE + CALL W3ADD2NDORDER(SPCO(:,J),DPO(J),WN,CG,0) + END IF + END IF +#endif ! ! 3. Prepare spectra etc. ! 3.a Mean wave parameters. @@ -1438,79 +1612,129 @@ SUBROUTINE W3EXPO END DO END DO ! -!/STAB2 UABS = UABS / ASFAC -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST3 ZWND = ZZWND -!/ST3 TAUWX = 0. -!/ST3 TAUWY = 0. -!/ST3 LLWS(:) = .TRUE. -!/ST4 LLWS(:) = .TRUE. -!/ST4 ZWND = ZZWND -!/ST4 TAUWX = 0. -!/ST4 TAUWY = 0. -!/ST6 ZWND = 10. +#ifdef W3_STAB2 + UABS = UABS / ASFAC +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST3 + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. + LLWS(:) = .TRUE. +#endif +#ifdef W3_ST4 + LLWS(:) = .TRUE. + ZWND = ZZWND + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif USTAR = 1. ! -!/ST1 CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST6 CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -! -!/FLX1 CALL W3FLX1 ( ZWND, UABS, UDIRR, & -!/FLX1 USTAR, USTD, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & -!/FLX5 RHOAIR, USTAR, USTD, Z0, CD ) +#ifdef W3_ST1 + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN +#endif +#ifdef W3_ST2 + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) +#endif +! +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD ) +#endif ! DO ITT=1, 3 -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XIN, DIA ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 IX=1 -!/ST3 IY=1 -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST3 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& -!/ST3 TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 IX=1 -!/ST4 IY=1 -!/ST4 CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST4 ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& -!/ST4 TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + IX=1 + IY=1 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + IX=1 + IY=1 + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD, TAUWX, TAUWY,& + TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif END DO ! ! Add alternative flux calculations here as part of !/ST2 option .... ! Also add before actual source term calculation !!! ! -!/STAB2 UABS = UABS * ASFAC +#ifdef W3_STAB2 + UABS = UABS * ASFAC +#endif ! IF ( WAO(J) .LT. 0.01 ) THEN UNORM = 0. @@ -1547,138 +1771,242 @@ SUBROUTINE W3EXPO END DO END DO ! -!/STAB2 UABS = UABS / ASFAC -! -!/ST0 ZWND = 10. -!/ST1 ZWND = 10. -!/ST2 ZWND = ZWIND -!/ST3 ZWND = ZZWND -!/ST0 USTAR = 1. -!/ST1 USTAR = 1. -!/ST2 USTAR = 1. -!/ST3 USTAR = 0. -!/ST3 USTD = 0. -!/ST3 TAUWX = 0. -!/ST3 TAUWY = 0. -!/ST4 ZWND = ZZWND -!/ST4 USTAR = 0. -!/ST4 USTD = 0. -!/ST4 TAUWX = 0. -!/ST4 TAUWY = 0. -!/ST6 ZWND = 10. -! -!/ST0 FHIGH = SIG(NK) -!/ST1 CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) -!/ST1 FP = 0.85 * FMEAN -!/ST1 FH1 = FXFM * FMEAN -!/ST1 FH2 = FXPM / USTAR -!/ST1 FHIGH = MAX ( FH1 , FH2 ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST6 CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) -!/ST6 FHIGH = SIG(NK) -! -!/FLX1 CALL W3FLX1 ( ZWND, UABS, UDIRR, & -!/FLX1 USTAR, USTD, Z0, CD ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) -!/FLX4 CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) -!/FLX5 CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & -!/FLX5 RHOAIR, USTAR, USTD, Z0, CD ) +#ifdef W3_STAB2 + UABS = UABS / ASFAC +#endif +! +#ifdef W3_ST0 + ZWND = 10. +#endif +#ifdef W3_ST1 + ZWND = 10. +#endif +#ifdef W3_ST2 + ZWND = ZWIND +#endif +#ifdef W3_ST3 + ZWND = ZZWND +#endif +#ifdef W3_ST0 + USTAR = 1. +#endif +#ifdef W3_ST1 + USTAR = 1. +#endif +#ifdef W3_ST2 + USTAR = 1. +#endif +#ifdef W3_ST3 + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST4 + ZWND = ZZWND + USTAR = 0. + USTD = 0. + TAUWX = 0. + TAUWY = 0. +#endif +#ifdef W3_ST6 + ZWND = 10. +#endif +! +#ifdef W3_ST0 + FHIGH = SIG(NK) +#endif +#ifdef W3_ST1 + CALL W3SPR1 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX) + FP = 0.85 * FMEAN + FH1 = FXFM * FMEAN + FH2 = FXPM / USTAR + FHIGH = MAX ( FH1 , FH2 ) +#endif +#ifdef W3_ST2 + CALL W3SPR2 (A, CG, WN, DEPTH, FP , UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SPR6 (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX, FP) + FHIGH = SIG(NK) +#endif +! +#ifdef W3_FLX1 + CALL W3FLX1 ( ZWND, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX4 + CALL W3FLX4 ( ZWND, UABS, UDIRR, USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX5 + CALL W3FLX5 ( ZWND, UABS, UDIRR, TAUA, TAUADIR, & + RHOAIR, USTAR, USTD, Z0, CD ) +#endif ! DO ITT=1, 3 -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & -!/ST2 FPI, XIN, DIA ) -!/ST2 CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & -!/ST2 EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) -!/ST3 CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & -!/ST3 WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& -!/ST3 TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST3 ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & -!/ST3 TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) -!/ST4 CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & -!/ST4 WNMEAN, AMAX, UABS, UDIRR, & -!/ST4!/FLX5 TAUA, TAUADIR, RHOAIR, & -!/ST4 USTAR, USTD, TAUWX, TAUWY, CD, Z0, & -!/ST4 CHARN, LLWS, FMEANWS, DLWMEAN ) -!/ST4 CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& -!/ST4 ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & -!/ST4 TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/FLX2 CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX2 USTAR, USTD, Z0, CD ) -!/FLX3 CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & -!/FLX3 USTAR, USTD, Z0, CD ) +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0, & + FPI, XIN, DIA ) + CALL W3SPR2 (A, CG, WN, DEPTH, FPI, UABS, USTAR, & + EMEAN, FMEAN, WNMEAN, AMAX, ALPHA, FP ) +#endif +#ifdef W3_ST3 + CALL W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, & + WNMEAN, AMAX, UABS, UDIRR, USTAR, USTD,& + TAUWX, TAUWY, CD, Z0, CHARN, LLWS, FMEANWS ) + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, ICE, XIN, DIA, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SPR4 (A, CG, WN, EMEAN, FMEAN, FMEAN1, & + WNMEAN, AMAX, UABS, UDIRR, & +#ifdef W3_FLX5 + TAUA, TAUADIR, RHOAIR, & +#endif + USTAR, USTD, TAUWX, TAUWY, CD, Z0, & + CHARN, LLWS, FMEANWS, DLWMEAN ) + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, DAIR/DWAT,& + ASO(J), UDIRR, Z0, CD,TAUWX, TAUWY, & + TAUWNX, TAUWNY, XIN, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_FLX2 + CALL W3FLX2 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif +#ifdef W3_FLX3 + CALL W3FLX3 ( ZWND, DEPTH, FP, UABS, UDIRR, & + USTAR, USTD, Z0, CD ) +#endif END DO ! -!/ST2 FHIGH = XFC * FPI +#ifdef W3_ST2 + FHIGH = XFC * FPI +#endif ! IF ( FLSRCE(2) ) THEN -!/LN1 CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) -! -!/ST1 CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) -!/ST2 CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& -!/ST2 FPI, XIN, DIA ) -!/ST3 CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & -!/ST3 DAIR/DWAT, ASO(J), UDIRR, & -!/ST3 Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & -!/ST3 ICE, XIN, DIA, LLWS, IX, IY ) -!/ST4 CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, & -!/ST4 DAIR/DWAT, ASO(J), UDIRR, & -!/ST4 Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & -!/ST4 XIN, DIA, LLWS, IX, IY, LAMBDA ) -!/ST6 CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & -!/ST6 TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) +#ifdef W3_LN1 + CALL W3SLN1 (WN, FHIGH, USTAR, UDIRR, XLN ) +#endif +! +#ifdef W3_ST1 + CALL W3SIN1 (A, WN2, USTAR, UDIRR, XIN, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SIN2 (A, CG, WN2, UABS, UDIRR, CD, Z0,& + FPI, XIN, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SIN3 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + ICE, XIN, DIA, LLWS, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SIN4 ( A, CG, WN2, UABS, USTAR, & + DAIR/DWAT, ASO(J), UDIRR, & + Z0, CD, TAUWX, TAUWY,TAUWNX, TAUWNY, & + XIN, DIA, LLWS, IX, IY, LAMBDA ) +#endif +#ifdef W3_ST6 + CALL W3SIN6 (A, CG, WN2, UABS, USTAR, UDIRR, CD, DAIR, & + TAUWX, TAUWY, TAUWNX, TAUWNY, XIN, DIA ) +#endif END IF IF ( FLSRCE(3) ) THEN -!/NL1 CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) -!/NL2 CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) -!/NL3 CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) -!/NL4 CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#ifdef W3_NL1 + CALL W3SNL1 ( A, CG, WNMEAN*DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL2 + CALL W3SNL2 ( A, CG, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL3 + CALL W3SNL3 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif +#ifdef W3_NL4 + CALL W3SNL4 ( A, CG, WN, DEPTH, XNL, DIA ) +#endif END IF IF ( FLSRCE(4) ) THEN -!/ST1 CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & -!/ST1 XDS, DIA ) -!/ST2 CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & -!/ST2 ALPHA, XDS, DIA ) -!/ST3 CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & -!/ST3 USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) -!/ST4 CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & -!/ST4 DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) -!/ST6 CALL W3SDS6 ( A, CG, WN, XDS, DIA ) -!/ST6 IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) -! -!/DB1 CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & -!/DB1 WNMEAN, CG, LBREAK, XDB, DIA ) +#ifdef W3_ST1 + CALL W3SDS1 ( A, WN2, EMEAN, FMEAN, WNMEAN, & + XDS, DIA ) +#endif +#ifdef W3_ST2 + CALL W3SDS2 ( A, CG, WN, FPI, USTAR, & + ALPHA, XDS, DIA ) +#endif +#ifdef W3_ST3 + CALL W3SDS3 ( A, WN, CG, EMEAN, FMEANS, WNMEAN, & + USTAR, USTD, DEPTH, XDS, DIA, IX, IY ) +#endif +#ifdef W3_ST4 + CALL W3SDS4 ( A, WN, CG, USTAR, USTD, DEPTH, DAIR, XDS, & + DIA, IX, IY, LAMBDA, WHITECAP, DLWMEAN ) +#endif +#ifdef W3_ST6 + CALL W3SDS6 ( A, CG, WN, XDS, DIA ) + IF (SWL6S6) CALL W3SWL6 ( A, CG, WN, XWL, DIA ) +#endif +! +#ifdef W3_DB1 + CALL W3SDB1 ( I, A, DEPTH, EMEAN, FMEAN, & + WNMEAN, CG, LBREAK, XDB, DIA ) +#endif END IF IF ( FLSRCE(5) ) THEN -!/BT1 CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) -!/BT2 SBTC2 = 2. * -0.067 / GRAV -!/BT2 CALL W3SBT2 ( A, CG, WN, DEPTH, XBT, DIA, SBTC2 ) -!/BT4 IX=1 ! to be fixed later -!/BT4 IY=1 ! to be fixed later -!/BT4 ISEA=1 ! to be fixed later -!/BT4 D50 = SED_D50(ISEA) -!/BT4 PSIC= SED_PSIC(ISEA) +#ifdef W3_BT1 + CALL W3SBT1 ( A, CG, WN, DEPTH, XBT, DIA ) +#endif +#ifdef W3_BT2 + SBTC2 = 2. * -0.067 / GRAV + CALL W3SBT2 ( A, CG, WN, DEPTH, XBT, DIA, SBTC2 ) +#endif +#ifdef W3_BT4 + IX=1 ! to be fixed later + IY=1 ! to be fixed later + ISEA=1 ! to be fixed later + D50 = SED_D50(ISEA) + PSIC= SED_PSIC(ISEA) +#endif -!/BT4 CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & -!/BT4 BEDFORM, XBT, DIA, IX, IY ) +#ifdef W3_BT4 + CALL W3SBT4 ( A, CG, WN, DEPTH, D50, PSIC, TAUBBL, & + BEDFORM, XBT, DIA, IX, IY ) +#endif BT8MSG='ww3_outp: ITYPE=3 with BT8 or BT9: Sbot out'//& 'put is not yet supported. Use "F" for the 5'//& 'th T/F flag.' -!/BT8 CALL EXTCDE( 516,MSG=BT8MSG) -!/BT9 CALL EXTCDE( 516,MSG=BT8MSG) +#ifdef W3_BT8 + CALL EXTCDE( 516,MSG=BT8MSG) +#endif +#ifdef W3_BT9 + CALL EXTCDE( 516,MSG=BT8MSG) +#endif ! For info on this issue, see : "BT8&9 issues" in "Remarks" section above. @@ -1687,25 +2015,33 @@ SUBROUTINE W3EXPO ! -!/BS1 CALL W3SBS1 ( A, CG, WN, DEPTH, & -!/BS1 CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & -!/BS1 TAUSCX, TAUSCY, XBS, DIA ) +#ifdef W3_BS1 + CALL W3SBS1 ( A, CG, WN, DEPTH, & + CAO(J)*COS(CDO(J)), CAO(J)*SIN(CDO(J)), & + TAUSCX, TAUSCY, XBS, DIA ) +#endif END IF ! IF ( FLSRCE(6) ) THEN -!/IS2 IF (IICEDISP) THEN -!/IS2 CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & -!/IS2 SIG,WN_R,CG_ICE,ALPHA_LIU) -!/IS2 ELSE -!/IS2 WN_R=WN -!/IS2 CG_ICE=CG -!/IS2 END IF -! -!/IS2 CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & -!/IS2 IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#ifdef W3_IS2 + IF (IICEDISP) THEN + CALL LIU_FORWARD_DISPERSION (ICETHICK,0.,DEPTH, & + SIG,WN_R,CG_ICE,ALPHA_LIU) + ELSE + WN_R=WN + CG_ICE=CG + END IF +#endif +! +#ifdef W3_IS2 + CALL W3SIS2(A, DEPTH, ICECON, ICETHICK, ICEF, ICEDMAX, & + IX, IY, XIS, DIA, DIA2, WN, CG, WN_R, CG_ICE, R) +#endif END IF ! -!/STAB2 UABS = UABS * ASFAC +#ifdef W3_STAB2 + UABS = UABS * ASFAC +#endif ! IF ( ISCALE.EQ.0 .OR. ISCALE.EQ.3 ) THEN FACF = TPIINV @@ -1736,7 +2072,9 @@ SUBROUTINE W3EXPO SWN(IK,ITH) = ( XLN(ITH,IK) + XIN(ITH,IK) ) * FACTOR SNL(IK,ITH) = ( XNL(ITH,IK) + XTR(ITH,IK) ) * FACTOR SDS(IK,ITH) = ( XDS(ITH,IK) + XDB(ITH,IK) ) * FACTOR -!/ST6 SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#ifdef W3_ST6 + SDS(IK,ITH) = SDS(IK,ITH) +(XWL(ITH,IK) * FACTOR) +#endif SBT(IK,ITH) = ( XBT(ITH,IK) * XBS(ITH,IK) ) * FACTOR SIS(IK,ITH) = XIS(ITH,IK) * FACTOR STT(IK,ITH) = SWN(IK,ITH) + SNL(IK,ITH)+SDS(IK,ITH)& @@ -2160,7 +2498,9 @@ SUBROUTINE W3EXPO ENDIF IF ( OTYPE .EQ. 2 .OR. OTYPE .EQ. 4 ) THEN NDSBUL=NDSTAB + (J - 1) -!/NCO NDSCBUL=NDSTAB + (J - 1) + NOPTS +#ifdef W3_NCO + NDSCBUL=NDSTAB + (J - 1) + NOPTS +#endif IF (IOUT .EQ. 1) THEN WRITE(HSTR,'(I2,1X,A)') TIMEV(2)/10000, & HTYPE @@ -2170,18 +2510,24 @@ SUBROUTINE W3EXPO WRITE (NDSBUL,971) WRITE (NDSBUL,972) WRITE (NDSBUL,971) -!/NCO WRITE (NDSCBUL,960) PTNME(J), Y, IDLAT, & -!/NCO X, IDLON, GNAME, TIMEV(1), HSTR -!/NCO WRITE (NDSCBUL,961) +#ifdef W3_NCO + WRITE (NDSCBUL,960) PTNME(J), Y, IDLAT, & + X, IDLON, GNAME, TIMEV(1), HSTR + WRITE (NDSCBUL,961) +#endif ENDIF WRITE (NDSBUL,973) ASCBLINE -!/NCO WRITE (NDSCBUL,963) CASCBLINE +#ifdef W3_NCO + WRITE (NDSCBUL,963) CASCBLINE +#endif ENDIF IF ( OTYPE .EQ. 3 .OR. OTYPE .EQ. 4 ) THEN ICSV = 0 IF ( NDSBUL .GT. 0 ) ICSV = NDSBUL -!/NCO IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL +#ifdef W3_NCO + IF ( NDSCBUL .GT. 0 ) ICSV = NDSCBUL +#endif NDSCSV = NDSTAB + (J - 1) + ICSV WRITE (NDSCSV,'(A664)') CSVBLINE ENDIF @@ -2242,14 +2588,16 @@ SUBROUTINE W3EXPO 942 FORMAT (I3,3F8.2,2F9.2,10F7.2) ! ! -!/NCO 960 FORMAT ( 'Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & -!/NCO 'Model : ',A/ & -!/NCO 'Cycle : ',I8,1X,A// & -!/NCO 'DDHH HS SS PP DDD SS PP DDD SS PP DDD', & -!/NCO ' SS PP DDD SS PP DDD SS PP DDD') -!/NCO 961 FORMAT ('----------------------------------------', & -!/NCO '---------------------------') -!/NCO 963 FORMAT (A) +#ifdef W3_NCO + 960 FORMAT ( 'Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & + 'Model : ',A/ & + 'Cycle : ',I8,1X,A// & + 'DDHH HS SS PP DDD SS PP DDD SS PP DDD', & + ' SS PP DDD SS PP DDD SS PP DDD') + 961 FORMAT ('----------------------------------------', & + '---------------------------') + 963 FORMAT (A) +#endif ! 970 FORMAT ( ' Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ & ' Model : ',A/ & @@ -2437,16 +2785,18 @@ SUBROUTINE W3EXPO 2931 FORMAT (1X,F6.4,7E11.3) 2940 FORMAT ( ' '/' ' ) ! -!/T 9000 FORMAT (' TEST W3EXPO : FLAGS :',40L2) -!/T 9001 FORMAT (' TEST W3EXPO : ITPYE :',I4/ & -!/T ' OTPYE :',I4/ & -!/T ' NREQ :',I4/ & -!/T ' SCALE1 :',E10.3/ & -!/T ' SCALE2 :',E10.3/ & -!/T ' FLSRCE :',7L2) -!/T 9002 FORMAT (' TEST W3EXPO : OUTPUT POINT : ',A) -!/T 9010 FORMAT (' TEST W3EXPO : DEPTH =',F7.1,' IK, T, K, CG :') -!/T 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#ifdef W3_T + 9000 FORMAT (' TEST W3EXPO : FLAGS :',40L2) + 9001 FORMAT (' TEST W3EXPO : ITPYE :',I4/ & + ' OTPYE :',I4/ & + ' NREQ :',I4/ & + ' SCALE1 :',E10.3/ & + ' SCALE2 :',E10.3/ & + ' FLSRCE :',7L2) + 9002 FORMAT (' TEST W3EXPO : OUTPUT POINT : ',A) + 9010 FORMAT (' TEST W3EXPO : DEPTH =',F7.1,' IK, T, K, CG :') + 9011 FORMAT (' ',I3,F8.2,F8.4,F8.2) +#endif !/ !/ End of W3EXPO ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_prep.ftn b/model/src/ww3_prep.F90 similarity index 81% rename from model/ftn/ww3_prep.ftn rename to model/src/ww3_prep.F90 index 4d579b43d..26cc22dfa 100644 --- a/model/ftn/ww3_prep.ftn +++ b/model/src/ww3_prep.F90 @@ -190,14 +190,22 @@ PROGRAM W3PREP USE CONSTANTS !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG -!/NL1 USE W3ADATMD,ONLY: W3NAUX, W3SETA +#ifdef W3_NL1 + USE W3ADATMD,ONLY: W3NAUX, W3SETA +#endif USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY : STME21 USE W3ARRYMD, ONLY : INA2R, INA2I -!/T2 USE W3ARRYMD, ONLY : PRTBLK -!/T3 USE W3ARRYMD, ONLY : PRTBLK +#ifdef W3_T2 + USE W3ARRYMD, ONLY : PRTBLK +#endif +#ifdef W3_T3 + USE W3ARRYMD, ONLY : PRTBLK +#endif USE W3IOGRMD, ONLY: W3IOGR USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD !/ @@ -219,17 +227,25 @@ PROGRAM W3PREP NDAT, JJ, IS(4), JS(4) INTEGER :: NXT, NYT INTEGER :: ILAND = -999 -!/O15 INTEGER :: NDSTIME +#ifdef W3_O15 + INTEGER :: NDSTIME +#endif INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & IY21(:,:), IY22(:,:), & JX21(:,:), JX22(:,:), & JY21(:,:), JY22(:,:), MAPOVR(:,:) INTEGER, ALLOCATABLE :: MASK(:,:) TYPE(T_GSU) :: GSI -!/S INTEGER, SAVE :: IENT = 0 -!/T2 INTEGER :: IXP0, IXPN, IXPWDT = 60 -!/T3 INTEGER :: IX0, IXN, IXWDT = 60 -!/T3 INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T2 + INTEGER :: IXP0, IXPN, IXPWDT = 60 +#endif +#ifdef W3_T3 + INTEGER :: IX0, IXN, IXWDT = 60 + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & X, Y, FACTOR, EFAC, NODATA, RW(4) REAL :: ACC = 0.05 @@ -244,7 +260,9 @@ PROGRAM W3PREP LOGICAL :: INGRID LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR INTEGER :: ICLO -!/T LOGICAL :: FLMOD +#ifdef W3_T + LOGICAL :: FLMOD +#endif CHARACTER :: COMSTR*1, IDFLD*3, IDTYPE*2, & IDTIME*23, FROMLL*4, FORMLL*16, & NAMELL*65, FROMF*4, NAMEF*65 @@ -277,15 +295,19 @@ PROGRAM W3PREP '2D spectra ' / NULLIFY ( ALA, ALO ) ! -!/NCO/! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') +#ifdef W3_NCO +! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1.a Set number of models ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -297,27 +319,33 @@ PROGRAM W3PREP NDST = 6 NDSM = 11 NDSDAT = 12 -!/O15 NDSTIME = 13 +#ifdef W3_O15 + NDSTIME = 13 +#endif ! NDSTRC = 6 NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSDAT = 51 -!/NCO NDSTRC = NDSO +#ifdef W3_NCO +! +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO +#endif ! ! 1.c Print header ! WRITE (NDSO,900) -!/S CALL STRACE (IENT, 'W3PREP') +#ifdef W3_S + CALL STRACE (IENT, 'W3PREP') +#endif ! J = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_prep.inp',STATUS='OLD', & @@ -403,18 +431,36 @@ PROGRAM W3PREP CALL EXTCDE ( 2 ) END IF ! -!/T IF (ITYPE.NE.1 .AND. ITYPE.NE.5) WRITE (NDST,9000) ACC +#ifdef W3_T + IF (ITYPE.NE.1 .AND. ITYPE.NE.5) WRITE (NDST,9000) ACC +#endif ! WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) IF ( ITYPE.NE.1 ) THEN -!/WNT0 IF (IFLD.EQ.3) WRITE (NDSO,1930) -!/WNT1 IF (IFLD.EQ.3) WRITE (NDSO,1930) -!/WNT2 IF (IFLD.EQ.3) WRITE (NDSO,2930) -!/CRT1 IF (IFLD.EQ.4) WRITE (NDSO,1930) -!/CRT2 IF (IFLD.EQ.4) WRITE (NDSO,2930) -!/WNT0 IF (IFLD.EQ.6) WRITE (NDSO,1930) -!/WNT1 IF (IFLD.EQ.6) WRITE (NDSO,1930) -!/WNT2 IF (IFLD.EQ.6) WRITE (NDSO,2930) +#ifdef W3_WNT0 + IF (IFLD.EQ.3) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT1 + IF (IFLD.EQ.3) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT2 + IF (IFLD.EQ.3) WRITE (NDSO,2930) +#endif +#ifdef W3_CRT1 + IF (IFLD.EQ.4) WRITE (NDSO,1930) +#endif +#ifdef W3_CRT2 + IF (IFLD.EQ.4) WRITE (NDSO,2930) +#endif +#ifdef W3_WNT0 + IF (IFLD.EQ.6) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT1 + IF (IFLD.EQ.6) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT2 + IF (IFLD.EQ.6) WRITE (NDSO,2930) +#endif END IF IF ( FLBERG ) WRITE (NDSO,938) IF ( FLSTAB ) WRITE (NDSO,939) @@ -556,7 +602,9 @@ PROGRAM W3PREP ! ! ... construct interpolation data ! -!/T1 WRITE (NDST,9045) +#ifdef W3_T1 + WRITE (NDST,9045) +#endif IF (GTYPE .NE. UNGTYPE) THEN DO IY=1,NY DO IX=1,NX @@ -595,9 +643,11 @@ PROGRAM W3PREP RD21(IX,IY) = RW(2) RD12(IX,IY) = RW(4) RD22(IX,IY) = RW(3) -!/T1 WRITE (NDST,9046) IX, IY, & -!/T1 IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & -!/T1 RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) +#ifdef W3_T1 + WRITE (NDST,9046) IX, IY, & + IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & + RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) +#endif END DO END DO ELSE @@ -628,7 +678,9 @@ PROGRAM W3PREP WRITE (NDSO,1044) Y ELSE IF (RW(2).LT.0.) THEN RW(2) = 0. -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -637,7 +689,9 @@ PROGRAM W3PREP WRITE (NDSO,1044) Y ELSE IF (RW(2).GT.1.) THEN RW(2) = 1. -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -704,7 +758,9 @@ PROGRAM W3PREP ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL -!/NCO NDSLL = 20 + NFCOMP +#ifdef W3_NCO + NDSLL = 20 + NFCOMP +#endif WRITE (NDSO,947) NDSLL IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL IF (NDSLL.EQ.NDSI) THEN @@ -764,7 +820,9 @@ PROGRAM W3PREP ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL -!/NCO NDSLL = 22 + NFCOMP +#ifdef W3_NCO + NDSLL = 22 + NFCOMP +#endif WRITE (NDSO,947) NDSLL IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL WRITE (NDSO,*) ' ' @@ -804,13 +862,15 @@ PROGRAM W3PREP NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) ! -!/T1a WRITE (NDST,9050) -!/T1a DO IY=1, NYJ(J) -!/T1a DO IX=1,NXJ(J) -!/T1a WRITE (NDST,9051) IX, IY, ALA(IX,IY), & -!/T1a ALO(IX,IY), MASK(IX,IY) -!/T1a END DO -!/T1a END DO +#ifdef W3_T1a + WRITE (NDST,9050) + DO IY=1, NYJ(J) + DO IX=1,NXJ(J) + WRITE (NDST,9051) IX, IY, ALA(IX,IY), & + ALO(IX,IY), MASK(IX,IY) + END DO + END DO +#endif ! ! ... generate interpolation data ! @@ -878,7 +938,9 @@ PROGRAM W3PREP ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSF(J), NAMEF -!/NCO NDSF(J) = 24 + NFCOMP +#ifdef W3_NCO + NDSF(J) = 24 + NFCOMP +#endif WRITE (NDSO,966) NDSF(J) IF (FROMF.EQ.'NAME') WRITE (NDSO,967) NAMEF ! @@ -975,9 +1037,11 @@ PROGRAM W3PREP !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 6 Begin loop over input fields ! -!/O15 J = LEN_TRIM(FNMPRE) -!/O15 OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & -!/O15 ERR=870,IOSTAT=IERR ) +#ifdef W3_O15 + J = LEN_TRIM(FNMPRE) + OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & + ERR=870,IOSTAT=IERR ) +#endif ! WRITE (NDSO,972) DO @@ -1011,8 +1075,12 @@ PROGRAM W3PREP ! CALL STME21 ( TIME , IDTIME ) WRITE (NDSO,973) IDTIME -!/O15 WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME -!/O3 WRITE (NDSO,974) +#ifdef W3_O15 + WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME +#endif +#ifdef W3_O3 + WRITE (NDSO,974) +#endif ! ! ... Input ! @@ -1021,57 +1089,63 @@ PROGRAM W3PREP CALL INA2R (XC, MXM, MYM, 1, NXJ(1), 1, NYJ(1), & NDSF(1), NDST, NDSE, IDFMF(1), FORMF(1), IDLAF(1), 1., 0.) ! -!/T2 WRITE (NDST,9060) 1 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& -!/T2 IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') -!/T2 IF (IXPN.NE.NXJ(1)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 1 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) + DO + CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& + IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') + IF (IXPN.NE.NXJ(1)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) + ELSE + EXIT + END IF + END DO +#endif ! IF (NFCOMP.EQ.2 .OR. IFLD.GE.3 .OR. FLBERG) THEN CALL INA2R (YC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & IDLAF(2), 1., 0.) ! -!/T2 WRITE (NDST,9060) 2 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & -!/T2 IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') -!/T2 IF (IXPN.NE.NXJ(2)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 2 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & + IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO +#endif ! IF ( FLSTAB ) THEN CALL INA2R (AC, MXM, MYM, 1, NXJ(2), 1, NYJ(2), & NDSF(2), NDST, NDSE, IDFMF(2), FORMF(2), & IDLAF(2), 1., 0. ) ! -!/T2 WRITE (NDST,9060) 3 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& -!/T2 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') -!/T2 IF (IXPN.NE.NXJ(2)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 3 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& + 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO +#endif ! END IF ! @@ -1084,7 +1158,9 @@ PROGRAM W3PREP ELSE READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT END IF -!/O3 WRITE (NDSO,975) NDAT +#ifdef W3_O3 + WRITE (NDSO,975) NDAT +#endif IF ( NDAT.GT.0 ) THEN ALLOCATE ( DATA(RECLDT,NDAT) ) DO IDAT=1, NDAT @@ -1101,12 +1177,14 @@ PROGRAM W3PREP END DO END IF ! -!/T2 WRITE (NDST,9061) -!/T2 DO IDAT=1, NDAT -!/T2 IX = MIN(6,RECLDT) -!/T2 WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) -!/T2 IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9061) + DO IDAT=1, NDAT + IX = MIN(6,RECLDT) + WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) + IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) + END DO +#endif ! END IF ! @@ -1135,7 +1213,9 @@ PROGRAM W3PREP ! ! ... One-component fields ! -!/O3 WRITE (NDSO,976) ' ' +#ifdef W3_O3 + WRITE (NDSO,976) ' ' +#endif IF (( IFLD.LE.2 ).AND.( .NOT. FLBERG )) THEN ! DO IY=1,NY @@ -1149,7 +1229,9 @@ PROGRAM W3PREP END DO ! IF (NFCOMP.EQ.2) THEN -!/O3 WRITE (NDSO,976) ' (2) ' +#ifdef W3_O3 + WRITE (NDSO,976) ' (2) ' +#endif DO IY=1,NY DO IX=1,NX FA(IX,IY) = FA(IX,IY) & @@ -1219,147 +1301,167 @@ PROGRAM W3PREP ! ! ... Winds, correct for velocity or energy conservation ! -!/WNT1 IF (IFLD.EQ.3) THEN -!/WNT1 DO IY=1,NY -!/WNT1 DO IX=1,NX -!/WNT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/WNT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT1 END DO -!/WNT1 END DO -!/WNT1 END IF -! -!/WNT2 IF (IFLD.EQ.3) THEN -!/WNT2 DO IY=1,NY -!/WNT2 DO IX=1,NX -!/WNT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/WNT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT2 END DO -!/WNT2 END DO -!/WNT2 END IF +#ifdef W3_WNT1 + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_WNT2 + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif ! ! ... Currents, correct for velocity or energy conservation ! -!/CRT1 IF (IFLD.EQ.4) THEN -!/CRT1 DO IY=1,NY -!/CRT1 DO IX=1,NX -!/CRT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/CRT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/CRT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/CRT1 END DO -!/CRT1 END DO -!/CRT1 END IF -! -!/CRT2 IF (IFLD.EQ.4) THEN -!/CRT2 DO IY=1,NY -!/CRT2 DO IX=1,NX -!/CRT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/CRT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/CRT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/CRT2 END DO -!/CRT2 END DO -!/CRT2 END IF +#ifdef W3_CRT1 + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_CRT2 + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif ! ! ... Momentum, correct for velocity or energy conservation ! -!/WNT1 IF (IFLD.EQ.6) THEN -!/WNT1 DO IY=1,NY -!/WNT1 DO IX=1,NX -!/WNT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/WNT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT1 END DO -!/WNT1 END DO -!/WNT1 END IF -! -!/WNT2 IF (IFLD.EQ.6) THEN -!/WNT2 DO IY=1,NY -!/WNT2 DO IX=1,NX -!/WNT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/WNT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT2 END DO -!/WNT2 END DO -!/WNT2 END IF +#ifdef W3_WNT1 + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_WNT2 + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif END IF ! END IF ! ! ... Test output ! -!/T3 IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) -!/T3 WRITE (NDST,9065) -!/T3 DO IX=1, NX -!/T3 DO IY=1, NY -!/T3 MAPOUT(IX,IY) = MAPSTA(IY,IX) -!/T3 END DO -!/T3 END DO -!/T3 IX0 = 1 -!/T3 IXN = MIN ( IX0+IXWDT-1 , NX ) -!/T3 DO -!/T3 IF (IFLD.EQ.-7) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'ice param 1', '(-)') -!/T3 ELSE IF (IFLD.EQ.-6) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'ice param 2', '(-)') -!/T3 ELSE IF (IFLD.EQ.-5) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'ice param 3', '(-)') -!/T3 ELSE IF (IFLD.EQ.-4) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'ice param 4', '(-)') -!/T3 ELSE IF (IFLD.EQ.-3) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'ice param 5', '(-)') -!/T3 ELSE IF (IFLD.EQ.-2) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Mud Density', 'kg/m3') -!/T3 ELSE IF (IFLD.EQ.-1) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Mud Thkness', '(-)') -!/T3 ELSE IF (IFLD.EQ.0) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Mud Kin.Visc', 'm2/s') -!/T3 ELSE IF (IFLD.EQ.1) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') -!/T3 IF ( FLBERG ) & -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') -!/T3 ELSE IF (IFLD.EQ.2) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') -!/T3 ELSE -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') -!/T3 IF ( FLSTAB ) & -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') -!/T3 END IF -!/T3 IF (IXN.NE.NX) THEN -!/T3 IX0 = IX0 + IXWDT -!/T3 IXN = MIN ( IXN+IXWDT , NX ) -!/T3 ELSE -!/T3 EXIT -!/T3 END IF -!/T3 END DO +#ifdef W3_T3 + IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) + WRITE (NDST,9065) + DO IX=1, NX + DO IY=1, NY + MAPOUT(IX,IY) = MAPSTA(IY,IX) + END DO + END DO + IX0 = 1 + IXN = MIN ( IX0+IXWDT-1 , NX ) + DO + IF (IFLD.EQ.-7) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 1', '(-)') + ELSE IF (IFLD.EQ.-6) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 2', '(-)') + ELSE IF (IFLD.EQ.-5) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 3', '(-)') + ELSE IF (IFLD.EQ.-4) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 4', '(-)') + ELSE IF (IFLD.EQ.-3) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'ice param 5', '(-)') + ELSE IF (IFLD.EQ.-2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Density', 'kg/m3') + ELSE IF (IFLD.EQ.-1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Thkness', '(-)') + ELSE IF (IFLD.EQ.0) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Mud Kin.Visc', 'm2/s') + ELSE IF (IFLD.EQ.1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') + IF ( FLBERG ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') + ELSE IF (IFLD.EQ.2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') + ELSE + CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') + CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') + IF ( FLSTAB ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') + END IF + IF (IXN.NE.NX) THEN + IX0 = IX0 + IXWDT + IXN = MIN ( IXN+IXWDT , NX ) + ELSE + EXIT + END IF + END DO +#endif ! ! 6.c Write fields ! IF ( ITYPE .LE. 4 ) THEN -!/O3 WRITE (NDSO,977) +#ifdef W3_O3 + WRITE (NDSO,977) +#endif CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & FX, FY, FA, IERR) ELSE IF ( ITYPE .EQ. 5 ) THEN IF ( NDAT .EQ. 0 ) THEN -!/O3 WRITE (NDSO,978) +#ifdef W3_O3 + WRITE (NDSO,978) +#endif ELSE -!/O3 WRITE (NDSO,977) +#ifdef W3_O3 + WRITE (NDSO,977) +#endif CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& TIME, RECLDT, NDAT, IDAT, DATA, IERR ) DEALLOCATE ( DATA ) @@ -1417,18 +1519,24 @@ PROGRAM W3PREP WRITE (NDSE,1063) IDAT, IERR CALL EXTCDE ( 53 ) ! -!/O15 870 CONTINUE -!/O15 WRITE (NDSE,1070) IDFLD, IERR -!/O15 CALL EXTCDE ( 54 ) +#ifdef W3_O15 + 870 CONTINUE + WRITE (NDSE,1070) IDFLD, IERR + CALL EXTCDE ( 54 ) +#endif ! -!/O15 871 CONTINUE -!/O15 WRITE (NDSE,1071) IDTIME, IERR -!/O15 CALL EXTCDE ( 54 ) +#ifdef W3_O15 + 871 CONTINUE + WRITE (NDSE,1071) IDTIME, IERR + CALL EXTCDE ( 54 ) +#endif ! 888 CONTINUE WRITE (NDSO,999) ! -!/NCO/! CALL W3TAGE('WAVEPREP') +#ifdef W3_NCO +! CALL W3TAGE('WAVEPREP') +#endif ! ! Formats ! @@ -1494,13 +1602,17 @@ PROGRAM W3PREP 972 FORMAT (//' Processing data'/ & ' --------------------------------------------------') 973 FORMAT ( ' Time : ',A) -!/O3 974 FORMAT ( ' reading ....') -!/O3 975 FORMAT ( ' number of data records :',I6) -!/O3 976 FORMAT ( ' interpolating',A,'....') -!/O3 977 FORMAT ( ' writing ....') -!/O3 978 FORMAT ( ' skipping ....') -! -!/O15 979 FORMAT (1X,I8.8,1X,I6.6) +#ifdef W3_O3 + 974 FORMAT ( ' reading ....') + 975 FORMAT ( ' number of data records :',I6) + 976 FORMAT ( ' interpolating',A,'....') + 977 FORMAT ( ' writing ....') + 978 FORMAT ( ' skipping ....') +#endif +! +#ifdef W3_O15 + 979 FORMAT (1X,I8.8,1X,I6.6) +#endif ! 999 FORMAT(//' End of program '/ & ' ========================================='/ & @@ -1582,33 +1694,47 @@ PROGRAM W3PREP 1063 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & ' ERROR IN READING DATA RECORD',I6,' FROM FILE'/ & ' IOSTAT =',I5/) -!/O15 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & -!/O15 ' ERROR IN CREATING A TIMES FILE FOR ',A/ & -!/O15 ' IOSTAT =',I5/) -!/O15 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & -!/O15 ' ERROR IN WRITING TIME OUTPUT ',A/ & -!/O15 ' IOSTAT =',I5/) -! -!/T 9000 FORMAT (' TEST W3PREP : ACC : ',F6.3) -! -!/T 9040 FORMAT (' TEST W3PREP : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & -!/T ' LON / X : ',3F10.2, & -!/T ' (GLOBAL=',L1,')'/ & -!/T ' LAT / Y : ',3F10.2) -!/T 9041 FORMAT (' TEST W3PREP : INTERPOLATION DATA FOR ',A) -!/T 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) -!/T 9043 FORMAT (' TEST W3PREP : GRID SHIFTED BY ',F5.0,' DEGREES / M') -!/T1 9045 FORMAT (' TEST W3PREP : IX, IY, IXI(2), IYI(2), RD(4)') -!/T1 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) -! -!/T1a 9050 FORMAT (' TEST W3PREP : LAT-LONG OF INPUT FILE ') -!/T1a 9051 FORMAT (' ',2I4,2F8.2,I4) -! -!/T2 9060 FORMAT (' TEST W3PREP : INPUT FIELD (',I1,') :'/) -!/T2 9061 FORMAT (' TEST W3PREP : INPUT DATA RECORDS :') -!/T2 9062 FORMAT (' ',I6,' : ',6E11.3) -!/T2 9063 FORMAT (' ',6E11.3) -!/T3 9065 FORMAT (' TEST W3PREP : OUTPUT FIELD(S) :'/) +#ifdef W3_O15 + 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN CREATING A TIMES FILE FOR ',A/ & + ' IOSTAT =',I5/) + 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PREP : '/ & + ' ERROR IN WRITING TIME OUTPUT ',A/ & + ' IOSTAT =',I5/) +#endif +! +#ifdef W3_T + 9000 FORMAT (' TEST W3PREP : ACC : ',F6.3) +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3PREP : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & + ' LON / X : ',3F10.2, & + ' (GLOBAL=',L1,')'/ & + ' LAT / Y : ',3F10.2) + 9041 FORMAT (' TEST W3PREP : INTERPOLATION DATA FOR ',A) + 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) + 9043 FORMAT (' TEST W3PREP : GRID SHIFTED BY ',F5.0,' DEGREES / M') +#endif +#ifdef W3_T1 + 9045 FORMAT (' TEST W3PREP : IX, IY, IXI(2), IYI(2), RD(4)') + 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) +#endif +! +#ifdef W3_T1a + 9050 FORMAT (' TEST W3PREP : LAT-LONG OF INPUT FILE ') + 9051 FORMAT (' ',2I4,2F8.2,I4) +#endif +! +#ifdef W3_T2 + 9060 FORMAT (' TEST W3PREP : INPUT FIELD (',I1,') :'/) + 9061 FORMAT (' TEST W3PREP : INPUT DATA RECORDS :') + 9062 FORMAT (' ',I6,' : ',6E11.3) + 9063 FORMAT (' ',6E11.3) +#endif +#ifdef W3_T3 + 9065 FORMAT (' TEST W3PREP : OUTPUT FIELD(S) :'/) +#endif !/ !/ End of W3PREP ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_prnc.ftn b/model/src/ww3_prnc.F90 similarity index 82% rename from model/ftn/ww3_prnc.ftn rename to model/src/ww3_prnc.F90 index 67135a553..42d142380 100644 --- a/model/ftn/ww3_prnc.ftn +++ b/model/src/ww3_prnc.F90 @@ -178,14 +178,22 @@ PROGRAM W3PRNC USE CONSTANTS !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG -!/NL1 USE W3ADATMD,ONLY: W3NAUX, W3SETA +#ifdef W3_NL1 + USE W3ADATMD,ONLY: W3NAUX, W3SETA +#endif USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3ARRYMD, ONLY : INA2R, INA2I -!/T2 USE W3ARRYMD, ONLY : PRTBLK -!/T3 USE W3ARRYMD, ONLY : PRTBLK +#ifdef W3_T2 + USE W3ARRYMD, ONLY : PRTBLK +#endif +#ifdef W3_T3 + USE W3ARRYMD, ONLY : PRTBLK +#endif USE W3IOGRMD, ONLY: W3IOGR USE W3FLDSMD, ONLY: W3FLDO, W3FLDP, W3FLDG, W3FLDD, & W3FLDTIDE1, W3FLDTIDE2 @@ -201,7 +209,9 @@ PROGRAM W3PRNC ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -228,11 +238,21 @@ PROGRAM W3PRNC IS(4), JS(4), VARIDF(50), DIMSVAR(4),& DIMLN(5), REFDATE(8),CURDATE(8), & STARTDATE(8),STPDATE(8) -!/MPI INTEGER :: IERR_MPI, IND, REST, SLICE -!/O15 INTEGER :: NDSTIME -!/S INTEGER, SAVE :: IENT = 0 -!/T2 INTEGER :: IXP0, IXPN, IXPWDT = 60 -!/T3 INTEGER :: IX0, IXN, IXWDT = 60 +#ifdef W3_MPI + INTEGER :: IERR_MPI, IND, REST, SLICE +#endif +#ifdef W3_O15 + INTEGER :: NDSTIME +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_T2 + INTEGER :: IXP0, IXPN, IXPWDT = 60 +#endif +#ifdef W3_T3 + INTEGER :: IX0, IXN, IXWDT = 60 +#endif ! INTEGER, ALLOCATABLE :: IX21(:,:), IX22(:,:), & IY21(:,:), IY22(:,:), & @@ -240,7 +260,9 @@ PROGRAM W3PRNC JY21(:,:), JY22(:,:), & MAPOVR(:,:), MASK(:,:), & NELEM(:), CUMUL(:) -!/T3 INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#ifdef W3_T3 + INTEGER, ALLOCATABLE :: MAPOUT(:,:) +#endif ! REAL :: X0I, XNI, Y0I, YNI, SXI, SYI, & X, Y, FACTOR, EFAC, NODATA, & @@ -279,7 +301,9 @@ PROGRAM W3PRNC ! LOGICAL :: INGRID, FLGNML LOGICAL :: FLSTAB, FLBERG, CLO(2), FLTIME, FLHDR -!/T LOGICAL :: FLMOD +#ifdef W3_T + LOGICAL :: FLMOD +#endif @@ -288,9 +312,11 @@ PROGRAM W3PRNC ! INTEGER :: K, L, TIDEFLAG, & TIDE_NDEF, TIDE_ITREND -!/T INTEGER, PARAMETER :: LRB = 4 -!/T INTEGER(KIND=8) :: RPOS -!/T INTEGER :: LRECL, NREC +#ifdef W3_T + INTEGER, PARAMETER :: LRB = 4 + INTEGER(KIND=8) :: RPOS + INTEGER :: LRECL, NREC +#endif ! INTEGER, ALLOCATABLE :: IMAX(:) ! @@ -298,8 +324,12 @@ PROGRAM W3PRNC ! REAL, ALLOCATABLE :: TIDE_DATA_ALL(:,:,:), & SSQ(:), RES(:) -!/MPI REAL, ALLOCATABLE :: TIDE1DL(:), TIDE1D(:) -!/T REAL(KIND=LRB), ALLOCATABLE :: NULLBUFF(:) +#ifdef W3_MPI + REAL, ALLOCATABLE :: TIDE1DL(:), TIDE1D(:) +#endif +#ifdef W3_T + REAL(KIND=LRB), ALLOCATABLE :: NULLBUFF(:) +#endif ! DOUBLE PRECISION, ALLOCATABLE :: ALLTIMES(:), & SDEV0(:), SDEV(:), RMSR(:), & @@ -310,7 +340,9 @@ PROGRAM W3PRNC ! LOGICAL, ALLOCATABLE :: TIDALCOMP(:,:) ! -!/T CHARACTER*21 :: FNAMETXT +#ifdef W3_T + CHARACTER*21 :: FNAMETXT +#endif ! EQUIVALENCE ( NXI , NXJ(1) ) , ( NYI , NYJ(1) ) !/ @@ -330,15 +362,19 @@ PROGRAM W3PRNC DATA IDSTR3 / 'mean parameters', '1D spectra ', & '2D spectra ' / ! -!/NCO/! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') +#ifdef W3_NCO +! CALL W3TAGB('WAVEPREP',1998,0007,0050,'NP21 ') +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1.a Set number of models ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -350,35 +386,45 @@ PROGRAM W3PRNC NDST = 6 NDSM = 11 NDSDAT = 12 -!/O15 NDSTIME = 13 +#ifdef W3_O15 + NDSTIME = 13 +#endif ! NDSTRC = 6 NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSDAT = 51 -!/NCO NDSTRC = NDSO +#ifdef W3_NCO ! -!/S CALL STRACE (IENT, 'W3PRNC') +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO +#endif +! +#ifdef W3_S + CALL STRACE (IENT, 'W3PRNC') +#endif ! ! ! 1.c MPP initializations ! -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 +#ifdef W3_SHRD + NAPROC = 1 + IAPROC = 1 +#endif ! -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#endif ! IF ( IAPROC .EQ. NAPERR ) THEN NDSEN = NDSE @@ -667,14 +713,30 @@ PROGRAM W3PRNC ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) IDSTR1(IFLD), IDSTR2(ITYPE) IF ( ITYPE.NE.1 .AND. ITYPE.NE.6 ) THEN -!/WNT0 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) -!/WNT1 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) -!/WNT2 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,2930) -!/CRT1 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,1930) -!/CRT2 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,2930) -!/WNT0 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) -!/WNT1 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) -!/WNT2 IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,2930) +#ifdef W3_WNT0 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT1 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT2 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.3) WRITE (NDSO,2930) +#endif +#ifdef W3_CRT1 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,1930) +#endif +#ifdef W3_CRT2 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.4) WRITE (NDSO,2930) +#endif +#ifdef W3_WNT0 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT1 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,1930) +#endif +#ifdef W3_WNT2 + IF ( IAPROC .EQ. NAPOUT .AND.IFLD.EQ.6) WRITE (NDSO,2930) +#endif END IF IF (FLGNML) THEN IF(TIMESTART(1).NE.19000101 .OR. TIMESTART(2).NE.0) THEN @@ -931,7 +993,9 @@ PROGRAM W3PRNC ! ! ... construct Interpolation data ! -!/T1 WRITE (NDST,9045) +#ifdef W3_T1 + WRITE (NDST,9045) +#endif IF (GTYPE .NE. UNGTYPE) THEN DO IY=1,NY DO IX=1,NX @@ -958,9 +1022,11 @@ PROGRAM W3PRNC RD21(IX,IY) = RW(2) RD12(IX,IY) = RW(4) RD22(IX,IY) = RW(3) -!/T1 WRITE (NDST,9046) IX, IY, & -!/T1 IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & -!/T1 RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) +#ifdef W3_T1 + WRITE (NDST,9046) IX, IY, & + IX21(IX,IY),IX22(IX,IY),IY21(IX,IY),IY22(IX,IY), & + RD11(IX,IY),RD12(IX,IY),RD21(IX,IY),RD22(IX,IY) +#endif END DO END DO ELSE ! GTYPE .NE. UNGTYPE @@ -991,7 +1057,9 @@ PROGRAM W3PRNC IF (RW(1).LT.0.) THEN RW(1) = 0. IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -999,7 +1067,9 @@ PROGRAM W3PRNC IF (RW(1).GT.1.) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1043) X RW(1) = 1. -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -1007,7 +1077,9 @@ PROGRAM W3PRNC IF (RW(2).LT.0.) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y RW(2) = 0. -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -1015,7 +1087,9 @@ PROGRAM W3PRNC IF (RW(2).GT.1) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,1044) Y RW(2) = 1. -!/T FLMOD = .TRUE. +#ifdef W3_T + FLMOD = .TRUE. +#endif END IF END IF ! @@ -1081,7 +1155,9 @@ PROGRAM W3PRNC ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL -!/NCO NDSLL = 20 + NFCOMP +#ifdef W3_NCO + NDSLL = 20 + NFCOMP +#endif IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL IF ( IAPROC .EQ. NAPOUT.AND.FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL IF (NDSLL.EQ.NDSI) THEN @@ -1142,7 +1218,9 @@ PROGRAM W3PRNC ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) NDSLL, NAMELL -!/NCO NDSLL = 22 + NFCOMP +#ifdef W3_NCO + NDSLL = 22 + NFCOMP +#endif IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,947) NDSLL IF (FROMLL.EQ.'NAME') WRITE (NDSO,948) NAMELL IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' @@ -1182,13 +1260,15 @@ PROGRAM W3PRNC NDSLL, NDST, NDSE, IDFMLL, FORMLL, IDLALL, 1, 0) IF ( NDSLL .NE. NDSI ) CLOSE (NDSLL) ! -!/T1a WRITE (NDST,9050) -!/T1a DO IY=1, NYJ(J) -!/T1a DO IX=1,NXJ(J) -!/T1a WRITE (NDST,9051) IX, IY, ALA(IX,IY), & -!/T1a ALO(IX,IY), MASK(IX,IY) -!/T1a END DO -!/T1a END DO +#ifdef W3_T1a + WRITE (NDST,9050) + DO IY=1, NYJ(J) + DO IX=1,NXJ(J) + WRITE (NDST,9051) IX, IY, ALA(IX,IY), & + ALO(IX,IY), MASK(IX,IY) + END DO + END DO +#endif ! ! ... generate interpolation data ! @@ -1288,16 +1368,18 @@ PROGRAM W3PRNC RECLDT, 0, GTYPEDUM, IERR, FPRE=FNMPRE(:J) ) END IF -!/T IF (TIDEFLAG.GT.0) THEN -!/T LRECL = TIDE_MF*LRB*NFIELDS*2 -!/T NREC = LRECL / LRB -!/T ALLOCATE(NULLBUFF(NREC)) -!/T NULLBUFF(1:NREC) = 0. -!/T OPEN (990,FILE='tidana.dat',FORM='UNFORMATTED', ACCESS='STREAM') -!/T FNAMETXT = 'tidanaNNN.txt' -!/T WRITE (FNAMETXT(7:9),'(I3.3)') IAPROC -!/T OPEN (989,FILE=FNAMETXT,status='unknown') -!/T ENDIF +#ifdef W3_T + IF (TIDEFLAG.GT.0) THEN + LRECL = TIDE_MF*LRB*NFIELDS*2 + NREC = LRECL / LRB + ALLOCATE(NULLBUFF(NREC)) + NULLBUFF(1:NREC) = 0. + OPEN (990,FILE='tidana.dat',FORM='UNFORMATTED', ACCESS='STREAM') + FNAMETXT = 'tidanaNNN.txt' + WRITE (FNAMETXT(7:9),'(I3.3)') IAPROC + OPEN (989,FILE=FNAMETXT,status='unknown') + ENDIF +#endif ! ! 7.c Initialize fields @@ -1332,17 +1414,21 @@ PROGRAM W3PRNC ! Reads in the full time vector ! IF (NX*NY.GT.4000) THEN -!/MPI IF ((NX*NY)/NAPROC.LT.4000) THEN -!/MPI IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis ... ' -!/MPI ELSE -!/MPI IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis for ',NX*NY, & -!/MPI ' points. This can take hours ...' -!/MPI ENDIF -!/MPI IF (NX*NY.LT.4000) THEN +#ifdef W3_MPI + IF ((NX*NY)/NAPROC.LT.4000) THEN + IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis ... ' + ELSE + IF (IAPROC.EQ.NAPOUT) WRITE(NDSE,*) 'Starting tidal analysis for ',NX*NY, & + ' points. This can take hours ...' + ENDIF + IF (NX*NY.LT.4000) THEN +#endif WRITE(NDSE,'(A,I8,A)') 'Starting tidal analysis for ',NX*NY, ' points.' IF (NAPROC.EQ.1) WRITE(NDSE,'(A)') 'This can take hours ...Consider running this with MPI ' END IF -!/MPI END IF +#ifdef W3_MPI + END IF +#endif IRET=NF90_INQ_VARID(NCID,"time",VARIDTMP) IF ( IRET/=NF90_NOERR ) IRET=NF90_INQ_VARID(NCID,"MT",VARIDTMP) CALL CHECK_ERR(IRET) @@ -1396,34 +1482,44 @@ PROGRAM W3PRNC CALL EXTCDE (30) END IF -!/MPI SLICE=NX/NAPROC -!/MPI REST=MOD(NX,NAPROC) -!/MPI IF(REST.GE.IAPROC) SLICE=SLICE+1 +#ifdef W3_MPI + SLICE=NX/NAPROC + REST=MOD(NX,NAPROC) + IF(REST.GE.IAPROC) SLICE=SLICE+1 +#endif -!/MPI ! set total 1D array (nx) -!/MPI ALLOCATE (TIDE1D(NX * TIDE_MF * NFIELDS * 2)) -!/MPI TIDE1D(:)=0. +#ifdef W3_MPI + ! set total 1D array (nx) + ALLOCATE (TIDE1D(NX * TIDE_MF * NFIELDS * 2)) + TIDE1D(:)=0. +#endif -!/MPI ! set local 1D array (slice) -!/MPI ALLOCATE(TIDE1DL(SLICE * TIDE_MF * NFIELDS * 2)) -!/MPI TIDE1DL(:)=0. +#ifdef W3_MPI + ! set local 1D array (slice) + ALLOCATE(TIDE1DL(SLICE * TIDE_MF * NFIELDS * 2)) + TIDE1DL(:)=0. +#endif ! set arrays for number of elements per MPI proc ALLOCATE(CUMUL(NAPROC)) ALLOCATE(NELEM(NAPROC)) CUMUL(1) = 0 NELEM(1) = NX / NAPROC -!/MPI IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 -!/MPI DO I=2,NAPROC -!/MPI CUMUL(I)=CUMUL(I-1)+NELEM(I-1) -!/MPI NELEM(I) = NX / NAPROC -!/MPI IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 -!/MPI END DO +#ifdef W3_MPI + IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 + DO I=2,NAPROC + CUMUL(I)=CUMUL(I-1)+NELEM(I-1) + NELEM(I) = NX / NAPROC + IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 + END DO +#endif -!/MPIT WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX -!/MPIT WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX -!/MPIT WRITE(100+IAPROC,*) "Slice of values per processor ", SLICE +#ifdef W3_MPIT + WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Slice of values per processor ", SLICE +#endif ALLOCATE(TIDE_DATA_ALL(NELEM(IAPROC),NTI,NFIELDS)) @@ -1438,7 +1534,9 @@ PROGRAM W3PRNC TIDALCOMP=.TRUE. ! DO IY=1,NY -!/MPI IND=0 +#ifdef W3_MPI + IND=0 +#endif ! IF (NDIMSGRID.EQ.1) THEN DO I=1,NFIELDS @@ -1468,8 +1566,12 @@ PROGRAM W3PRNC ! DO JX=1,NELEM(IAPROC) -!/MPI IX=CUMUL(IAPROC)+JX -!/SHRD IX=JX +#ifdef W3_MPI + IX=CUMUL(IAPROC)+JX +#endif +#ifdef W3_SHRD + IX=JX +#endif ! TIDE_NTI=0 @@ -1506,11 +1608,13 @@ PROGRAM W3PRNC TIDE_NDEF, TIDE_ITREND, RES, SSQ, RMSR0, & SDEV0, RMSR, RESMAX, IMAX, 0) -!/T WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_AMPC(1:TIDE_MF,1:NFIELDS) -!/T WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_PHG(1:TIDE_MF,1:NFIELDS) -!/T RPOS = 1_8 + LRECL*(IX-1_8) -!/T WRITE (990,POS=RPOS),NULLBUFF(1:NREC) -!/T WRITE (990,POS=RPOS),TIDE_AMPC(1:TIDE_MF,1:NFIELDS),TIDE_PHG(1:TIDE_MF,1:NFIELDS) +#ifdef W3_T + WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_AMPC(1:TIDE_MF,1:NFIELDS) + WRITE (989,'(2I10,X,176F10.3)'),IX,TIDE_NTI,TIDE_PHG(1:TIDE_MF,1:NFIELDS) + RPOS = 1_8 + LRECL*(IX-1_8) + WRITE (990,POS=RPOS),NULLBUFF(1:NREC) + WRITE (990,POS=RPOS),TIDE_AMPC(1:TIDE_MF,1:NFIELDS),TIDE_PHG(1:TIDE_MF,1:NFIELDS) +#endif ELSE TIDALCOMP(IX,IY)=.FALSE. @@ -1523,19 +1627,25 @@ PROGRAM W3PRNC ! Save tidal amplitude and phase ! -!/MPIT IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I6,A,I6,A,I6)') 'IY, JX = ', & -!/MPIT IY,',',JX, ' out of ', NELEM(IAPROC) -!/MPI DO J=1,TIDE_MF -!/MPI DO K=1,NFIELDS -!/MPI IND=IND+1 -!/MPI TIDE1DL(IND)=TIDE_AMPC(J,K) -!/MPI IND=IND+1 -!/MPI TIDE1DL(IND)=TIDE_PHG(J,K) -!/MPI END DO -!/MPI END DO +#ifdef W3_MPIT + IF (IAPROC.EQ.NAPOUT) WRITE(NDSO,'(A,I6,A,I6,A,I6)') 'IY, JX = ', & + IY,',',JX, ' out of ', NELEM(IAPROC) +#endif +#ifdef W3_MPI + DO J=1,TIDE_MF + DO K=1,NFIELDS + IND=IND+1 + TIDE1DL(IND)=TIDE_AMPC(J,K) + IND=IND+1 + TIDE1DL(IND)=TIDE_PHG(J,K) + END DO + END DO +#endif -!/SHRD TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,1)=TIDE_AMPC(1:TIDE_MF,1:NFIELDS) -!/SHRD TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,2)=TIDE_PHG(1:TIDE_MF,1:NFIELDS) +#ifdef W3_SHRD + TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,1)=TIDE_AMPC(1:TIDE_MF,1:NFIELDS) + TIDAL_CONST(IX,IY,1:TIDE_MF,1:NFIELDS,2)=TIDE_PHG(1:TIDE_MF,1:NFIELDS) +#endif END DO ! JX=1,NELEM(IAPROC) @@ -1543,55 +1653,71 @@ PROGRAM W3PRNC ! Gather from other MPI tasks ! -!/MPI IF (NAPROC.GT.1) THEN -!/MPI CALL MPI_GATHERV(TIDE1DL, SLICE * TIDE_MF * NFIELDS * 2, MPI_REAL, & -!/MPI TIDE1D, NELEM * TIDE_MF * NFIELDS * 2, CUMUL * TIDE_MF * NFIELDS * 2, & -!/MPI MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) +#ifdef W3_MPI + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(TIDE1DL, SLICE * TIDE_MF * NFIELDS * 2, MPI_REAL, & + TIDE1D, NELEM * TIDE_MF * NFIELDS * 2, CUMUL * TIDE_MF * NFIELDS * 2, & + MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) +#endif -!/MPI IF (IAPROC.EQ.NAPOUT) THEN -!/MPI CALL MPI_GATHERV(MPI_IN_PLACE,NELEM(IAPROC), & -!/MPI MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & -!/MPI MPI_COMM_WORLD, IERR_MPI) -!/MPI ELSE -!/MPI CALL MPI_GATHERV(TIDALCOMP(CUMUL(IAPROC)+1:CUMUL(IAPROC)+NELEM(IAPROC),IY),NELEM(IAPROC), & -!/MPI MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & -!/MPI MPI_COMM_WORLD, IERR_MPI) -!/MPI END IF +#ifdef W3_MPI + IF (IAPROC.EQ.NAPOUT) THEN + CALL MPI_GATHERV(MPI_IN_PLACE,NELEM(IAPROC), & + MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & + MPI_COMM_WORLD, IERR_MPI) + ELSE + CALL MPI_GATHERV(TIDALCOMP(CUMUL(IAPROC)+1:CUMUL(IAPROC)+NELEM(IAPROC),IY),NELEM(IAPROC), & + MPI_LOGICAL, TIDALCOMP(:,IY), NELEM, CUMUL, MPI_LOGICAL, NAPOUT-1, & + MPI_COMM_WORLD, IERR_MPI) + END IF +#endif -!/MPI ELSE -!/MPI TIDE1D = TIDE1DL -!/MPI END IF +#ifdef W3_MPI + ELSE + TIDE1D = TIDE1DL + END IF +#endif ! ! Convert from 1D to 2D array ! -!/MPI IF (IAPROC .EQ. NAPOUT) THEN -!/MPI IND=0 -!/MPI DO IX=1,NX -!/MPI DO J=1,TIDE_MF -!/MPI DO K=1,NFIELDS -!/MPI DO L=1,2 -!/MPI IND=IND+1 -!/MPI TIDAL_CONST(IX,IY,J,K,L)=TIDE1D(IND) -!/MPI END DO -!/MPI END DO -!/MPI END DO -!/MPI END DO -!/MPI END IF +#ifdef W3_MPI + IF (IAPROC .EQ. NAPOUT) THEN + IND=0 + DO IX=1,NX + DO J=1,TIDE_MF + DO K=1,NFIELDS + DO L=1,2 + IND=IND+1 + TIDAL_CONST(IX,IY,J,K,L)=TIDE1D(IND) + END DO + END DO + END DO + END DO + END IF +#endif END DO ! IY=1,NY -!/T CLOSE (990) -!/T CLOSE (989) -!/T IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,1,1) -!/T IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,2,1) - -!/MPI IF (IAPROC .NE. NAPOUT ) THEN -!/MPI GOTO 888 -!/MPIT ELSE -!/MPIT WRITE(NDSO,'(A)') "parallelization done" -!/MPI END IF +#ifdef W3_T + CLOSE (990) + CLOSE (989) + IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,1,1) + IF (IDFLD.EQ.'CUR') WRITE(986,'(F10.3,/)') TIDAL_CONST(:,1,15,2,1) +#endif + +#ifdef W3_MPI + IF (IAPROC .NE. NAPOUT ) THEN + GOTO 888 +#endif +#ifdef W3_MPIT + ELSE + WRITE(NDSO,'(A)') "parallelization done" +#endif +#ifdef W3_MPI + END IF +#endif ! @@ -1641,9 +1767,11 @@ PROGRAM W3PRNC END IF END IF ! -!/O15 J = LEN_TRIM(FNMPRE) -!/O15 OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & -!/O15 ERR=870,IOSTAT=IERR ) +#ifdef W3_O15 + J = LEN_TRIM(FNMPRE) + OPEN (NDSTIME,FILE=FNMPRE(:J)//'times.'//IDFLD, & + ERR=870,IOSTAT=IERR ) +#endif ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) TIMEDELAY = 0 @@ -1685,8 +1813,12 @@ PROGRAM W3PRNC ELSE IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,2973) IDTIME END IF -!/O15 WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) +#ifdef W3_O15 + WRITE (NDSTIME, 979, ERR=871,IOSTAT=IERR) TIME +#endif +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) +#endif ! ! ... Input ! @@ -1706,19 +1838,21 @@ PROGRAM W3PRNC WHERE (XC.NE.FILLVALUE) XC=XC*XCFAC+XCOFF ! -!/T2 WRITE (NDST,9060) 1 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& -!/T2 IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') -!/T2 IF (IXPN.NE.NXJ(1)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 1 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(1) ) + DO + CALL PRTBLK ( NDST, NXJ(1), NYJ(1), MXM, XC, MASK, 0, 0.,& + IXP0, IXPN, 1, 1, NYJ(1), 1, 'Field 1', ' ') + IF (IXPN.NE.NXJ(1)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(1) ) + ELSE + EXIT + END IF + END DO +#endif ! IF (NFCOMP.EQ.2 .OR. (IFLD.GE.3 .AND. IFLD.NE.7) .OR. FLBERG) THEN @@ -1738,19 +1872,21 @@ PROGRAM W3PRNC WHERE(YC.NE.YC) YC = FILLVALUE WHERE (YC.NE.FILLVALUE) YC=YC*YCFAC+YCOFF ! -!/T2 WRITE (NDST,9060) 2 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & -!/T2 IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') -!/T2 IF (IXPN.NE.NXJ(2)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 2 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, YC, MASK, 0, 0., & + IXP0, IXPN, 1, 1, NYJ(2), 1, 'Field 2', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO +#endif ! IF (FLSTAB) THEN ! This is a quick fix that works if the lon,lat,level,time dimensions are in that order @@ -1767,19 +1903,21 @@ PROGRAM W3PRNC CALL CHECK_ERR(IRET) !AC(:,:)=AC(:,MYM:1:-1) ! -!/T2 WRITE (NDST,9060) 3 -!/T2 IXP0 = 1 -!/T2 IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) -!/T2 DO -!/T2 CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& -!/T2 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') -!/T2 IF (IXPN.NE.NXJ(2)) THEN -!/T2 IXP0 = IXP0 + IXPWDT -!/T2 IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) -!/T2 ELSE -!/T2 EXIT -!/T2 END IF -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9060) 3 + IXP0 = 1 + IXPN = MIN ( IXP0+IXPWDT-1 , NXJ(2) ) + DO + CALL PRTBLK ( NDST, NXJ(2), NYJ(2), MXM, AC, MASK, 0,& + 0., IXP0, IXPN, 1,1, NYJ(2), 1, 'Field 3', ' ') + IF (IXPN.NE.NXJ(2)) THEN + IXP0 = IXP0 + IXPWDT + IXPN = MIN ( IXPN+IXPWDT , NXJ(2) ) + ELSE + EXIT + END IF + END DO +#endif ! END IF ! @@ -1793,7 +1931,9 @@ PROGRAM W3PRNC ELSE READ (NDSF(1),*,END=862,ERR=862,IOSTAT=IERR) NDAT END IF -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) NDAT +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,975) NDAT +#endif IF ( NDAT.GT.0 ) THEN ALLOCATE ( DATA(RECLDT,NDAT) ) DO IDAT=1, NDAT @@ -1810,12 +1950,14 @@ PROGRAM W3PRNC END DO END IF ! -!/T2 WRITE (NDST,9061) -!/T2 DO IDAT=1, NDAT -!/T2 IX = MIN(6,RECLDT) -!/T2 WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) -!/T2 IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) -!/T2 END DO +#ifdef W3_T2 + WRITE (NDST,9061) + DO IDAT=1, NDAT + IX = MIN(6,RECLDT) + WRITE (NDST,9062) IDAT, DATA(1:IX,IDAT) + IF ( IX.LT.RECLDT ) WRITE (NDST,9063) DATA(IX+1:,:) + END DO +#endif ! END IF ! @@ -1852,14 +1994,18 @@ PROGRAM W3PRNC ! ! ... One-component fields ! -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' ' +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' ' +#endif IF (( IFLD.LE.2 .OR. IFLD.EQ.7 ).AND.( .NOT. FLBERG )) THEN ! CALL INTERP(MXM, MYM, XC, IX21, IX22, IY21, IY22, & RD11, RD12, RD21, RD22, FILLVALUE, FA) ! IF (NFCOMP.EQ.2) THEN -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' (2) ' +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,976) ' (2) ' +#endif CALL INTERP(MXM, MYM, YC, JX21, JX22, JY21, JY22, & XD11, XD12, XD21, XD22, FILLVALUE, FA) END IF @@ -1905,69 +2051,81 @@ PROGRAM W3PRNC ! ! ... Winds, correct for velocity or energy conservation ! -!/WNT1 IF (IFLD.EQ.3) THEN -!/WNT1 DO IY=1,NY -!/WNT1 DO IX=1,NX -!/WNT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/WNT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT1 END DO -!/WNT1 END DO -!/WNT1 END IF -! -!/WNT2 IF (IFLD.EQ.3) THEN -!/WNT2 DO IY=1,NY -!/WNT2 DO IX=1,NX -!/WNT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/WNT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT2 END DO -!/WNT2 END DO -!/WNT2 END IF +#ifdef W3_WNT1 + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_WNT2 + IF (IFLD.EQ.3) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif ! ! ... Currents, correct for velocity or energy conservation ! -!/CRT1 IF (IFLD.EQ.4) THEN -!/CRT1 DO IY=1,NY -!/CRT1 DO IX=1,NX -!/CRT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/CRT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/CRT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/CRT1 END DO -!/CRT1 END DO -!/CRT1 END IF -! -!/CRT2 IF (IFLD.EQ.4) THEN -!/CRT2 DO IY=1,NY -!/CRT2 DO IX=1,NX -!/CRT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/CRT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/CRT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/CRT2 END DO -!/CRT2 END DO -!/CRT2 END IF +#ifdef W3_CRT1 + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_CRT2 + IF (IFLD.EQ.4) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif ! ! ... Momentum, correct for velocity or energy conservation ! -!/WNT1 IF (IFLD.EQ.6) THEN -!/WNT1 DO IY=1,NY -!/WNT1 DO IX=1,NX -!/WNT1 FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) -!/WNT1 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT1 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT1 END DO -!/WNT1 END DO -!/WNT1 END IF -! -!/WNT2 IF (IFLD.EQ.6) THEN -!/WNT2 DO IY=1,NY -!/WNT2 DO IX=1,NX -!/WNT2 FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) -!/WNT2 FX(IX,IY) = FACTOR * FX(IX,IY) -!/WNT2 FY(IX,IY) = FACTOR * FY(IX,IY) -!/WNT2 END DO -!/WNT2 END DO -!/WNT2 END IF +#ifdef W3_WNT1 + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A2(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif +! +#ifdef W3_WNT2 + IF (IFLD.EQ.6) THEN + DO IY=1,NY + DO IX=1,NX + FACTOR = MIN ( 1.5 , A3(IX,IY)/A1(IX,IY) ) + FX(IX,IY) = FACTOR * FX(IX,IY) + FY(IX,IY) = FACTOR * FY(IX,IY) + END DO + END DO + END IF +#endif ! END IF ! @@ -1975,58 +2133,66 @@ PROGRAM W3PRNC ! ! ... Test output ! -!/T3 IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) -!/T3 WRITE (NDST,9065) -!/T3 DO IX=1, NX -!/T3 DO IY=1, NY -!/T3 MAPOUT(IX,IY) = MAPSTA(IY,IX) -!/T3 END DO -!/T3 END DO -!/T3 IX0 = 1 -!/T3 IXN = MIN ( IX0+IXWDT-1 , NX ) -!/T3 DO -!/T3 IF (IFLD.EQ.1) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') -!/T3 IF ( FLBERG ) & -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') -!/T3 ELSE IF (IFLD.EQ.2) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') -!/T3 ELSE IF (IFLD.EQ.7) THEN -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Air density', 'kg/m3') -!/T3 ELSE -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') -!/T3 IF ( FLSTAB ) & -!/T3 CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & -!/T3 IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') -!/T3 END IF -!/T3 IF (IXN.NE.NX) THEN -!/T3 IX0 = IX0 + IXWDT -!/T3 IXN = MIN ( IXN+IXWDT , NX ) -!/T3 ELSE -!/T3 EXIT -!/T3 END IF -!/T3 END DO +#ifdef W3_T3 + IF ( .NOT. ALLOCATED(MAPOUT) ) ALLOCATE ( MAPOUT(NX,NY) ) + WRITE (NDST,9065) + DO IX=1, NX + DO IY=1, NY + MAPOUT(IX,IY) = MAPSTA(IY,IX) + END DO + END DO + IX0 = 1 + IXN = MIN ( IX0+IXWDT-1 , NX ) + DO + IF (IFLD.EQ.1) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Fraction ice', '(-)') + IF ( FLBERG ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Iceberg a', '0.1/km') + ELSE IF (IFLD.EQ.2) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Water level', 'm') + ELSE IF (IFLD.EQ.7) THEN + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Air density', 'kg/m3') + ELSE + CALL PRTBLK (NDSO, NX, NY, NX, FX, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. X-comp', 'm/s') + CALL PRTBLK (NDSO, NX, NY, NX, FY, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Cart. Y-comp', 'm/s') + IF ( FLSTAB ) & + CALL PRTBLK (NDSO, NX, NY, NX, FA, MAPOUT, 0, 0., & + IX0, IXN, 1, 1, NY, 1, 'Tair-Tsea', 'degr') + END IF + IF (IXN.NE.NX) THEN + IX0 = IX0 + IXWDT + IXN = MIN ( IXN+IXWDT , NX ) + ELSE + EXIT + END IF + END DO +#endif ! ! 8.c Write fields ! IF ( ITYPE .LE. 4 .OR. ITYPE.EQ.6 ) THEN -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) +#endif IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDG ('WRITE', IDFLD, NDSDAT, NDST, NDSE, NX, NY, & NX, NY, TIME, TIME, TIME, FX, FY, FA, TIME, & FX, FY, FA, IERR) ELSE IF ( ITYPE .EQ. 5 ) THEN IF ( NDAT .EQ. 0 ) THEN -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,978) +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,978) +#endif ELSE -!/O3 IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) +#ifdef W3_O3 + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,977) +#endif IF ( IAPROC .EQ. NAPOUT ) CALL W3FLDD ('WRITE', IDFLD, NDSDAT, NDST, NDSE, TIME,& TIME, RECLDT, NDAT, IDAT, DATA, IERR ) DEALLOCATE ( DATA ) @@ -2090,20 +2256,28 @@ PROGRAM W3PRNC WRITE (NDSE,1064) TRIM(STRDIMSNAME) CALL EXTCDE ( 56 ) ! -!/O15 870 CONTINUE -!/O15 WRITE (NDSE,1070) IDFLD, IERR -!/O15 CALL EXTCDE ( 57 ) +#ifdef W3_O15 + 870 CONTINUE + WRITE (NDSE,1070) IDFLD, IERR + CALL EXTCDE ( 57 ) +#endif ! -!/O15 871 CONTINUE -!/O15 WRITE (NDSE,1071) IDTIME, IERR -!/O15 CALL EXTCDE ( 58 ) +#ifdef W3_O15 + 871 CONTINUE + WRITE (NDSE,1071) IDTIME, IERR + CALL EXTCDE ( 58 ) +#endif ! 888 CONTINUE IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! -!/NCO/! CALL W3TAGE('WAVEPREP') +#ifdef W3_NCO +! CALL W3TAGE('WAVEPREP') +#endif ! @@ -2172,13 +2346,17 @@ PROGRAM W3PRNC 1973 FORMAT ( ' Shifted Time : ',A,' (File time : ',A,')') 2973 FORMAT ( ' Time : ',A) -!/O3 974 FORMAT ( ' reading ....') -!/O3 975 FORMAT ( ' number of data records :',I6) -!/O3 976 FORMAT ( ' interpolating',A,'....') -!/O3 977 FORMAT ( ' writing ....') -!/O3 978 FORMAT ( ' skipping ....') +#ifdef W3_O3 + 974 FORMAT ( ' reading ....') + 975 FORMAT ( ' number of data records :',I6) + 976 FORMAT ( ' interpolating',A,'....') + 977 FORMAT ( ' writing ....') + 978 FORMAT ( ' skipping ....') +#endif ! -!/O15 979 FORMAT (1X,I8.8,1X,I6.6) +#ifdef W3_O15 + 979 FORMAT (1X,I8.8,1X,I6.6) +#endif ! 999 FORMAT(//' End of program '/ & ' ========================================='/ & @@ -2269,31 +2447,43 @@ PROGRAM W3PRNC 1064 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & ' GRID DIMENSIONS ', A,' NOT FOUND... CHECK DIMENSION NAMES') ! -!/O15 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & -!/O15 ' ERROR IN CREATING A TIMES FILE FOR ',A/ & -!/O15 ' IOSTAT =',I5/) -!/O15 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & -!/O15 ' ERROR IN WRITING TIME OUTPUT ',A/ & -!/O15 ' IOSTAT =',I5/) -! -!/T 9040 FORMAT (' TEST W3PRNC : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & -!/T ' LON / X : ',3F10.2, & -!/T ' (GLOBAL=',L1,')'/ & -!/T ' LAT / Y : ',3F10.2) -!/T 9041 FORMAT (' TEST W3PRNC : INTERPOLATION DATA FOR ',A) -!/T 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) -!/T 9043 FORMAT (' TEST W3PRNC : GRID SHIFTED BY ',F5.0,' DEGREES / M') -!/T1 9045 FORMAT (' TEST W3PRNC : IX, IY, IXI(2), IYI(2), RD(4)') -!/T1 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) -! -!/T1a 9050 FORMAT (' TEST W3PRNC : LAT-LONG OF INPUT FILE ') -!/T1a 9051 FORMAT (' ',2I4,2F8.2,I4) -! -!/T2 9060 FORMAT (' TEST W3PRNC : INPUT FIELD (',I1,') :'/) -!/T2 9061 FORMAT (' TEST W3PRNC : INPUT DATA RECORDS :') -!/T2 9062 FORMAT (' ',I6,' : ',6E11.3) -!/T2 9063 FORMAT (' ',6E11.3) -!/T3 9065 FORMAT (' TEST W3PRNC : OUTPUT FIELD(S) :'/) +#ifdef W3_O15 + 1070 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN CREATING A TIMES FILE FOR ',A/ & + ' IOSTAT =',I5/) + 1071 FORMAT (/' *** WAVEWATCH III ERROR IN W3PRNC : '/ & + ' ERROR IN WRITING TIME OUTPUT ',A/ & + ' IOSTAT =',I5/) +#endif +! +#ifdef W3_T + 9040 FORMAT (' TEST W3PRNC : INPUT GRID RANGES AND INCR. AFTER CORR.'/ & + ' LON / X : ',3F10.2, & + ' (GLOBAL=',L1,')'/ & + ' LAT / Y : ',3F10.2) + 9041 FORMAT (' TEST W3PRNC : INTERPOLATION DATA FOR ',A) + 9042 FORMAT (' ',I4,F8.2,2I4,2F8.2,1X,F6.3,1X,A) + 9043 FORMAT (' TEST W3PRNC : GRID SHIFTED BY ',F5.0,' DEGREES / M') +#endif +#ifdef W3_T1 + 9045 FORMAT (' TEST W3PRNC : IX, IY, IXI(2), IYI(2), RD(4)') + 9046 FORMAT (' ',2I4,2X,4I4,2X,4F6.2) +#endif +! +#ifdef W3_T1a + 9050 FORMAT (' TEST W3PRNC : LAT-LONG OF INPUT FILE ') + 9051 FORMAT (' ',2I4,2F8.2,I4) +#endif +! +#ifdef W3_T2 + 9060 FORMAT (' TEST W3PRNC : INPUT FIELD (',I1,') :'/) + 9061 FORMAT (' TEST W3PRNC : INPUT DATA RECORDS :') + 9062 FORMAT (' ',I6,' : ',6E11.3) + 9063 FORMAT (' ',6E11.3) +#endif +#ifdef W3_T3 + 9065 FORMAT (' TEST W3PRNC : OUTPUT FIELD(S) :'/) +#endif !/ !/ End of W3PRNC ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_prtide.ftn b/model/src/ww3_prtide.F90 similarity index 82% rename from model/ftn/ww3_prtide.ftn rename to model/src/ww3_prtide.F90 index 4b9233c54..6813c7798 100644 --- a/model/ftn/ww3_prtide.ftn +++ b/model/src/ww3_prtide.F90 @@ -108,11 +108,15 @@ PROGRAM W3PRTIDE USE CONSTANTS !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG -!/NL1 USE W3ADATMD,ONLY: W3NAUX, W3SETA +#ifdef W3_NL1 + USE W3ADATMD,ONLY: W3NAUX, W3SETA +#endif USE W3ODATMD, ONLY: IAPROC, NAPROC, NAPERR, NAPOUT USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE, STRSPLIT -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD USE W3ARRYMD, ONLY : INA2R, INA2I USE W3IOGRMD, ONLY: W3IOGR @@ -126,7 +130,9 @@ PROGRAM W3PRTIDE ! IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -139,12 +145,16 @@ PROGRAM W3PRTIDE INTEGER :: K, ICON, IX2, SUMOK, NBAD, ITER INTEGER :: IE, IP, IP2, II, IFOUND, ALREADYFOUND INTEGER :: TIDE_KD0, INT24, INTDYS ! "Gregorian day constant" -!/MPI INTEGER :: IERR_MPI, IND, REST, SLICE +#ifdef W3_MPI + INTEGER :: IERR_MPI, IND, REST, SLICE +#endif INTEGER :: TIME(2), TIDE_START(2), TIDE_END(2) INTEGER :: INDMAX(70), PR_INDS(70) ! INTEGER, ALLOCATABLE :: BADPOINTS(:,:), VNEIGH(:,:), CONN(:) -!/MPI INTEGER, ALLOCATABLE :: NELEM(:), CUMUL(:) +#ifdef W3_MPI + INTEGER, ALLOCATABLE :: NELEM(:), CUMUL(:) +#endif ! REAL :: WCURTIDEX, WCURTIDEY, TIDE_ARGX, TIDE_ARGY REAL :: AMPCOS, AMPSIN @@ -152,8 +162,10 @@ PROGRAM W3PRTIDE REAL :: TIDE_FX(44),UX(44),VX(44), MAXVALCON(70) ! REAL, ALLOCATABLE :: FX(:,:), FY(:,:), FA(:,:) -!/MPI REAL, ALLOCATABLE :: FX1D(:), FY1D(:), FA1D(:) -!/MPI REAL, ALLOCATABLE :: FX1DL(:), FY1DL(:), FA1DL(:) +#ifdef W3_MPI + REAL, ALLOCATABLE :: FX1D(:), FY1D(:), FA1D(:) + REAL, ALLOCATABLE :: FX1DL(:), FY1DL(:), FA1DL(:) +#endif ! DOUBLE PRECISION :: d1,h,TIDE_HOUR,HH,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau ! @@ -182,8 +194,10 @@ PROGRAM W3PRTIDE ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! @@ -202,29 +216,37 @@ PROGRAM W3PRTIDE TIDEFILL =.TRUE. CALL ITRACE ( NDSTRC, NTRACE ) ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSM = 12 -!/NCO NDSDAT = 51 -!/NCO NDSTRC = NDSO +#ifdef W3_NCO +! +! Redo according to NCO +! + NDSI = 11 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSM = 12 + NDSDAT = 51 + NDSTRC = NDSO +#endif -!/S CALL STRACE (IENT, 'W3PRTIDE') +#ifdef W3_S + CALL STRACE (IENT, 'W3PRTIDE') +#endif ! ! 1.c MPP initializations ! -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 +#ifdef W3_SHRD + NAPROC = 1 + IAPROC = 1 +#endif ! -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 ! this is to have IAPROC between 1 and NAPROC +#endif ! IF ( IAPROC .EQ. NAPERR ) THEN NDSEN = NDSE @@ -422,39 +444,49 @@ PROGRAM W3PRTIDE ! !========================================================== -!/MPI SLICE=NX/NAPROC -!/MPI REST=MOD(NX,NAPROC) -!/MPI IF(REST.GE.IAPROC) SLICE=SLICE+1 - -!/MPI ! set total 1D array (nx) -!/MPI ALLOCATE ( FX1D(NX), FY1D(NX), FA1D(NX)) -!/MPI FX1D(:)=0. -!/MPI FY1D(:)=0. -!/MPI FA1D(:)=0. - -!/MPI ! set local 1D array (slice) -!/MPI ALLOCATE(FX1DL(SLICE)) -!/MPI ALLOCATE(FY1DL(SLICE)) -!/MPI ALLOCATE(FA1DL(SLICE)) -!/MPI FX1DL(:)=0. -!/MPI FY1DL(:)=0. -!/MPI FA1DL(:)=0. - - -!/MPI ! set arrays for number of elements per MPI proc -!/MPI ALLOCATE(NELEM(NAPROC)) -!/MPI ALLOCATE(CUMUL(NAPROC)) -!/MPI NELEM(1) = NX / NAPROC -!/MPI IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 -!/MPI CUMUL(1) = 0 -!/MPI DO I=2,NAPROC -!/MPI CUMUL(I)=CUMUL(I-1)+NELEM(I-1) -!/MPI NELEM(I) = NX / NAPROC -!/MPI IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 -!/MPI END DO +#ifdef W3_MPI + SLICE=NX/NAPROC + REST=MOD(NX,NAPROC) + IF(REST.GE.IAPROC) SLICE=SLICE+1 +#endif + +#ifdef W3_MPI + ! set total 1D array (nx) + ALLOCATE ( FX1D(NX), FY1D(NX), FA1D(NX)) + FX1D(:)=0. + FY1D(:)=0. + FA1D(:)=0. +#endif + +#ifdef W3_MPI + ! set local 1D array (slice) + ALLOCATE(FX1DL(SLICE)) + ALLOCATE(FY1DL(SLICE)) + ALLOCATE(FA1DL(SLICE)) + FX1DL(:)=0. + FY1DL(:)=0. + FA1DL(:)=0. +#endif + + +#ifdef W3_MPI + ! set arrays for number of elements per MPI proc + ALLOCATE(NELEM(NAPROC)) + ALLOCATE(CUMUL(NAPROC)) + NELEM(1) = NX / NAPROC + IF (REST .GT. 0) NELEM(1) = NELEM(1) + 1 + CUMUL(1) = 0 + DO I=2,NAPROC + CUMUL(I)=CUMUL(I-1)+NELEM(I-1) + NELEM(I) = NX / NAPROC + IF (REST .GT. I-1) NELEM(I) = NELEM(I) + 1 + END DO +#endif -!/MPIT WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX -!/MPIT WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX +#ifdef W3_MPIT + WRITE(100+IAPROC,*) "Number of points for this processor ", IAPROC, " : ", NELEM(IAPROC), ' / ', NX + WRITE(100+IAPROC,*) "Cumul of points for this processor ", IAPROC, " : ", CUMUL(IAPROC), ' / ', NX +#endif !========================================================== ! @@ -581,9 +613,13 @@ PROGRAM W3PRTIDE IF (IFLD.EQ.4) THEN DO IY = 1, NY -!/MPI IND=0 -!/MPI DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) -!/SHRD DO IX=1,NX +#ifdef W3_MPI + IND=0 + DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) +#endif +#ifdef W3_SHRD + DO IX=1,NX +#endif CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),TIDE_FX,UX,VX) WCURTIDEX = 0. WCURTIDEY = 0. @@ -605,44 +641,52 @@ PROGRAM W3PRTIDE IX, WCURTIDEX, WCURTIDEY , TIDAL_CONST(IX,IY,:,1,1),'##',TIDAL_CONST(IX,IY,:,2,1) STOP END IF -!/MPI IND=IND+1 -!/MPI FX1DL(IND) = WCURTIDEX -!/MPI FY1DL(IND) = WCURTIDEY -!/MPI FA1DL(IND) = 0. -!/SHRD FX(IX,IY) = WCURTIDEX -!/SHRD FY(IX,IY) = WCURTIDEY -!/SHRD FA(IX,IY) = 0. +#ifdef W3_MPI + IND=IND+1 + FX1DL(IND) = WCURTIDEX + FY1DL(IND) = WCURTIDEY + FA1DL(IND) = 0. +#endif +#ifdef W3_SHRD + FX(IX,IY) = WCURTIDEX + FY(IX,IY) = WCURTIDEY + FA(IX,IY) = 0. +#endif END DO ! NX ! ! Gather from other MPI tasks ! -!/MPI IF (NAPROC.GT.1) THEN -!/MPI CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM, & -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM, & -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM, & -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI ELSE -!/MPI FX1D = FX1DL -!/MPI FY1D = FY1DL -!/MPI FA1D = FA1DL -!/MPI END IF +#ifdef W3_MPI + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM, & + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + ELSE + FX1D = FX1DL + FY1D = FY1DL + FA1D = FA1DL + END IF +#endif ! ! Convert from 1D to 2D array ! -!/MPI IF (IAPROC .EQ. NAPOUT) THEN -!/MPI IND=0 -!/MPI DO IX=1,NX -!/MPI IND=IND+1 -!/MPI FX(IX,IY)=FX1D(IND) -!/MPI FY(IX,IY)=FY1D(IND) -!/MPI FA(IX,IY)=FA1D(IND) -!/MPI END DO -!/MPI END IF +#ifdef W3_MPI + IF (IAPROC .EQ. NAPOUT) THEN + IND=0 + DO IX=1,NX + IND=IND+1 + FX(IX,IY)=FX1D(IND) + FY(IX,IY)=FY1D(IND) + FA(IX,IY)=FA1D(IND) + END DO + END IF +#endif END DO ! NY END IF ! IFLD.EQ.4 @@ -656,9 +700,13 @@ PROGRAM W3PRTIDE IF (IFLD.EQ.2) THEN DO IY = 1, NY -!/MPI IND=0 -!/MPI DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) -!/SHRD DO IX=1,NX +#ifdef W3_MPI + IND=0 + DO IX=CUMUL(IAPROC)+1,CUMUL(IAPROC)+NELEM(IAPROC) +#endif +#ifdef W3_SHRD + DO IX=1,NX +#endif CALL SETVUF_FAST(h,pp,s,p,enp,dh,dpp,ds,dp,dnp,tau,YGRD(IY,IX),TIDE_FX,UX,VX) ! ! Removes unlikely values ... @@ -685,13 +733,17 @@ PROGRAM W3PRTIDE WCURTIDEX = WCURTIDEX+TIDE_FX(J)*TIDAL_CONST(IX,IY,J,1,1)*COS(TIDE_ARGX) END IF END DO -!/MPI IND=IND+1 -!/MPI FX1DL(IND) = 0. -!/MPI FY1DL(IND) = 0. -!/MPI FA1DL(IND) = WCURTIDEX -!/SHRD FX(IX,IY) = 0. -!/SHRD FY(IX,IY) = 0. -!/SHRD FA(IX,IY) = WCURTIDEX +#ifdef W3_MPI + IND=IND+1 + FX1DL(IND) = 0. + FY1DL(IND) = 0. + FA1DL(IND) = WCURTIDEX +#endif +#ifdef W3_SHRD + FX(IX,IY) = 0. + FY(IX,IY) = 0. + FA(IX,IY) = WCURTIDEX +#endif END DO ! NX @@ -699,31 +751,35 @@ PROGRAM W3PRTIDE ! Gather from other MPI tasks ! -!/MPI IF (NAPROC.GT.1) THEN -!/MPI CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM,& -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM,& -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM,& -!/MPI CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) -!/MPI ELSE -!/MPI FX1D = FX1DL -!/MPI FY1D = FY1DL -!/MPI FA1D = FA1DL -!/MPI END IF +#ifdef W3_MPI + IF (NAPROC.GT.1) THEN + CALL MPI_GATHERV(FX1DL, SLICE, MPI_REAL, FX1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FY1DL, SLICE, MPI_REAL, FY1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + CALL MPI_GATHERV(FA1DL, SLICE, MPI_REAL, FA1D, NELEM,& + CUMUL, MPI_REAL, NAPOUT-1, MPI_COMM_WORLD, IERR_MPI) + ELSE + FX1D = FX1DL + FY1D = FY1DL + FA1D = FA1DL + END IF +#endif ! ! Convert from 1D to 2D array ! -!/MPI IF (IAPROC .EQ. NAPOUT) THEN -!/MPI IND=0 -!/MPI DO IX=1,NX -!/MPI IND=IND+1 -!/MPI FX(IX,IY)=FX1D(IND) -!/MPI FY(IX,IY)=FY1D(IND) -!/MPI FA(IX,IY)=FA1D(IND) -!/MPI END DO -!/MPI END IF +#ifdef W3_MPI + IF (IAPROC .EQ. NAPOUT) THEN + IND=0 + DO IX=1,NX + IND=IND+1 + FX(IX,IY)=FX1D(IND) + FY(IX,IY)=FY1D(IND) + FA(IX,IY)=FA1D(IND) + END DO + END IF +#endif END DO ! NY END IF ! IFLD.EQ.2 @@ -779,7 +835,9 @@ PROGRAM W3PRTIDE ! 888 CONTINUE IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! ! Formats diff --git a/model/ftn/ww3_sbs1.ftn b/model/src/ww3_sbs1.F90 similarity index 92% rename from model/ftn/ww3_sbs1.ftn rename to model/src/ww3_sbs1.F90 index 107beb603..dfec342ed 100644 --- a/model/ftn/ww3_sbs1.ftn +++ b/model/src/ww3_sbs1.F90 @@ -146,7 +146,9 @@ PROGRAM W3SBS1 !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -154,7 +156,9 @@ PROGRAM W3SBS1 INTEGER :: MPI_COMM = -99, IERR, NDST1, NDST2 = -1,& NXW = -1, NYW = -1, TNEXT(2), TOLD(2), & I -!/MPI INTEGER :: IERR_MPI +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif INTEGER, PARAMETER :: SLEEP1 = 10 , SLEEP2 = 10 INTEGER, ALLOCATABLE :: TEND(:,:) REAL :: DTTST @@ -168,11 +172,13 @@ PROGRAM W3SBS1 ! ! 0.b MPI environment: Here, we use MPI_COMM_WORLD ! -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/MPI MPI_COMM = MPI_COMM_WORLD -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) -!/MPI IMPROC = IMPROC + 1 +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) + MPI_COMM = MPI_COMM_WORLD + CALL MPI_COMM_SIZE ( MPI_COMM, NMPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM, IMPROC, IERR_MPI ) + IMPROC = IMPROC + 1 +#endif ! ! 0.c Identifying output to "screen" unit ! @@ -207,7 +213,9 @@ PROGRAM W3SBS1 NAME='times.inp', & DESC='times file for sbs driver' ) OPEN (NDST1,FILE='times.inp',STATUS='OLD',ERR=820,IOSTAT=IERR) -!/T WRITE (MDST,9020) +#ifdef W3_T + WRITE (MDST,9020) +#endif ! DO I=-1, -NAUXGR, -1 CALL W3SETG ( I, MDSE, MDST ) @@ -224,8 +232,10 @@ PROGRAM W3SBS1 IF ( NXW .EQ. -1 ) GOTO 825 IF ( NDST2 .EQ. -1 ) GOTO 825 ! -!/T WRITE (MDST,9021) -!/T WRITE (MDST,9022) NXW, NYW, NDST2, I +#ifdef W3_T + WRITE (MDST,9021) + WRITE (MDST,9022) NXW, NYW, NDST2, I +#endif ! !/ ------------------------------------------------------------------- / ! 3. Run the wave model @@ -277,7 +287,9 @@ PROGRAM W3SBS1 TEND(:,I) = TNEXT(:) END DO ! -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif CALL WMWAVE ( TEND ) ! DTTST = DSEC21 ( TNEXT , ETIME ) @@ -297,8 +309,10 @@ PROGRAM W3SBS1 ! IF ( IMPROC .EQ. NMPSCR ) WRITE (*,999) ! -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! GO TO 888 ! @@ -333,9 +347,11 @@ PROGRAM W3SBS1 1025 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1 : '/ & ' WIND FILE NOT FOUND, NDST2 = ',I8/) ! -!/T 9020 FORMAT ( ' TEST W3SBS1: TIMES FILE SUCCESSFULLY OPENED') -!/T 9021 FORMAT ( ' TEST W3SBS1: WINDS FILE SUCCESSFULLY OPENED') -!/T 9022 FORMAT ( ' TEST DATA : ',2I8,2I4) +#ifdef W3_T + 9020 FORMAT ( ' TEST W3SBS1: TIMES FILE SUCCESSFULLY OPENED') + 9021 FORMAT ( ' TEST W3SBS1: WINDS FILE SUCCESSFULLY OPENED') + 9022 FORMAT ( ' TEST DATA : ',2I8,2I4) +#endif !/ !/ Internal subroutines RDTIME and RDWIND ---------------------------- / !/ @@ -377,7 +393,9 @@ SUBROUTINE RDTIME ( NDS, TIME ) !/ ------------------------------------------------------------------- / !/ Local parameters !/ -!/SBS CHARACTER(LEN=10) :: COMMAND +#ifdef W3_SBS + CHARACTER(LEN=10) :: COMMAND +#endif !/ ! -------------------------------------------------------------------- / ! 1. Reading loop @@ -391,8 +409,10 @@ SUBROUTINE RDTIME ( NDS, TIME ) IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS, 911 ) BACKSPACE NDS ! -!/SBS WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP1 -!/SBS CALL SYSTEM ( COMMAND ) +#ifdef W3_SBS + WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP1 + CALL SYSTEM ( COMMAND ) +#endif ! END DO ! @@ -460,7 +480,9 @@ SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) INTEGER :: TTIME(2), IX, IY INTEGER, SAVE :: NREW = 0 REAL :: DTTST, XXX(NX,NY) -!/SBS CHARACTER(LEN=10) :: COMMAND +#ifdef W3_SBS + CHARACTER(LEN=10) :: COMMAND +#endif ! ! -------------------------------------------------------------------- / ! 1. Loops @@ -473,20 +495,28 @@ SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) ! NREW = NREW + 1 READ (NDS,END=140,ERR=140) TTIME -!/T WRITE (MDST,9000) TTIME +#ifdef W3_T + WRITE (MDST,9000) TTIME +#endif ! NREW = NREW + 1 READ (NDS,END=130,ERR=130) ((XXX(IX,IY),IX=1,NX),IY=1,NY) -!/T WRITE (MDST,9001) 'U' +#ifdef W3_T + WRITE (MDST,9001) 'U' +#endif ! NREW = NREW + 1 READ (NDS,END=120,ERR=120) ((XXX(IX,IY),IX=1,NX),IY=1,NY) -!/T WRITE (MDST,9001) 'V' +#ifdef W3_T + WRITE (MDST,9001) 'V' +#endif ! IF ( TYPE .EQ. 'WNS' ) THEN NREW = NREW + 1 READ (NDS,END=110,ERR=110) ((XXX(IX,IY),IX=1,NX),IY=1,NY) -!/T WRITE (MDST,9001) 'DT' +#ifdef W3_T + WRITE (MDST,9001) 'DT' +#endif END IF ! EXIT @@ -506,8 +536,10 @@ SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) ! IF ( IMPROC .EQ. NMPSCR ) WRITE (MDSS,900) ! -!/SBS WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP2 -!/SBS CALL SYSTEM ( COMMAND ) +#ifdef W3_SBS + WRITE (COMMAND,'(A5,1X,I4)') 'sleep ', SLEEP2 + CALL SYSTEM ( COMMAND ) +#endif ! END DO ! @@ -556,8 +588,10 @@ SUBROUTINE RDWIND ( NDS, TIME, NX, NY, REWIND ) 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3SBS1/RDWIND : '/ & ' FILE READ PAST EXPECTED TIME '/) ! -!/T 9000 FORMAT ( ' TEST RDWIND: TIME READ ',I8.8,1X,I6.6) -!/T 9001 FORMAT ( ' FIELD READ ',A) +#ifdef W3_T + 9000 FORMAT ( ' TEST RDWIND: TIME READ ',I8.8,1X,I6.6) + 9001 FORMAT ( ' FIELD READ ',A) +#endif !/ !/ End of RDWIND ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_shel.ftn b/model/src/ww3_shel.F90 similarity index 72% rename from model/ftn/ww3_shel.ftn rename to model/src/ww3_shel.F90 index e6d3956dd..97290696e 100644 --- a/model/ftn/ww3_shel.ftn +++ b/model/src/ww3_shel.F90 @@ -235,15 +235,25 @@ PROGRAM W3SHEL ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/PDLIB USE CONSTANTS, ONLY: LPDLIB +#ifdef W3_PDLIB + USE CONSTANTS, ONLY: LPDLIB +#endif USE W3GDATMD USE W3WDATMD, ONLY: TIME, VA, W3NDAT, W3DIMW, W3SETW -!/OASIS USE W3WDATMD, ONLY: TIME00, TIMEEND -!/NL5 USE W3WDATMD, ONLY: QI5TBEG +#ifdef W3_OASIS + USE W3WDATMD, ONLY: TIME00, TIMEEND +#endif +#ifdef W3_NL5 + USE W3WDATMD, ONLY: QI5TBEG +#endif USE W3ADATMD, ONLY: W3NAUX, W3DIMA, W3SETA -!/MEMCHECK USE W3ADATMD, ONLY: MALLINFOS +#ifdef W3_MEMCHECK + USE W3ADATMD, ONLY: MALLINFOS +#endif USE W3IDATMD -!/OASIS USE W3ODATMD, ONLY: DTOUT, FLOUT +#ifdef W3_OASIS + USE W3ODATMD, ONLY: DTOUT, FLOUT +#endif USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3ODATMD, ONLY: NAPROC, IAPROC, NAPOUT, NAPERR, NOGRP, & NGRPP, IDOUT, FNMPRE, IOSTYP, NOTYPE @@ -260,24 +270,38 @@ PROGRAM W3SHEL USE W3IOPOMD USE W3SERVMD, ONLY : NEXTLN, EXTCDE USE W3TIMEMD -!/MEMCHECK USE MallocInfo_m +#ifdef W3_MEMCHECK + USE MallocInfo_m +#endif !/NETCDF_QAD USE W3NETCDF, only : TIME0_NETCDF_QAD !/NETCDF_QAD USE W3NETCDF, only : TIMEN_NETCDF_QAD -!/OASIS USE W3OACPMD, ONLY: CPL_OASIS_INIT, CPL_OASIS_GRID, & -!/OASIS CPL_OASIS_DEFINE, CPL_OASIS_FINALIZE, & -!/OASIS ID_OASIS_TIME, CPLT0 -!/OASOCM USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN -!/OASACM USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS -!/OASICM USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE - -!/TIDE USE W3TIDEMD +#ifdef W3_OASIS + USE W3OACPMD, ONLY: CPL_OASIS_INIT, CPL_OASIS_GRID, & + CPL_OASIS_DEFINE, CPL_OASIS_FINALIZE, & + ID_OASIS_TIME, CPLT0 +#endif +#ifdef W3_OASOCM + USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN +#endif +#ifdef W3_OASACM + USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS +#endif +#ifdef W3_OASICM + USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE +#endif + +#ifdef W3_TIDE + USE W3TIDEMD +#endif ! USE W3NMLSHELMD IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local PARAMETER statements @@ -304,10 +328,16 @@ PROGRAM W3SHEL NODATA(7:9), ODAT(40), IPRT(6) = 0, & STARTDATE(8), STOPDATE(8), IHH(-7:10) ! -!/OASIS INTEGER :: OASISED -!/COU INTEGER :: OFL +#ifdef W3_OASIS + INTEGER :: OASISED +#endif +#ifdef W3_COU + INTEGER :: OFL +#endif INTEGER :: CLKDT1(8), CLKDT2(8), CLKDT3(8) -!/MPI INTEGER :: IERR_MPI +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif ! REAL :: FACTOR, DTTST, XX, YY, & HA(NHMAX,-7:10), HD(NHMAX,-7:10), & @@ -335,7 +365,9 @@ PROGRAM W3SHEL CHARACTER(LEN=80) :: LINEIN CHARACTER(LEN=8) :: WORDS(7)='' -!/COU CHARACTER(LEN=30) :: OFILE +#ifdef W3_COU + CHARACTER(LEN=30) :: OFILE +#endif ! LOGICAL :: FLLSTL, FLLSTI, FLLSTR, FLFLG, FLHOM, & TFLAGI, PRTFRM, FLAGSCI, FLGNML @@ -343,9 +375,15 @@ PROGRAM W3SHEL FLGR2(NOGRP,NGRPP), FLG2(NOGRP), & FLAGSTIDE(4), FLH(-7:10), FLGDAS(3), & FLLST_ALL(-7:10) -!/MPI LOGICAL :: FLHYBR = .FALSE. -!/OMPH INTEGER :: THRLEV -!/OASIS LOGICAL :: L_MASTER +#ifdef W3_MPI + LOGICAL :: FLHYBR = .FALSE. +#endif +#ifdef W3_OMPH + INTEGER :: THRLEV +#endif +#ifdef W3_OASIS + LOGICAL :: L_MASTER +#endif ! !/ !/ ------------------------------------------------------------------- / @@ -376,15 +414,21 @@ PROGRAM W3SHEL FLAGSTIDE(:) = .FALSE. FLH(:) = .FALSE. ! -!/T PRTFRM = .TRUE. +#ifdef W3_T + PRTFRM = .TRUE. +#endif ! CALL DATE_AND_TIME ( VALUES=CLKDT1 ) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 0. Set up data structures ! -!/OASIS OASISED=1 -!/PDLIB LPDLIB = .TRUE. +#ifdef W3_OASIS + OASISED=1 +#endif +#ifdef W3_PDLIB + LPDLIB = .TRUE. +#endif ! CALL W3NMOD ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) @@ -398,57 +442,93 @@ PROGRAM W3SHEL CALL W3SETO ( 1, 6, 6 ) CALL W3SETI ( 1, 6, 6 ) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 1' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 -! -!/OMPH FLHYBR = .TRUE. - -!/OASIS IF (OASISED.EQ.1) THEN -!/OASIS CALL CPL_OASIS_INIT(MPI_COMM) -!/OASIS ELSE -!/DEBUGINIT write(740+IAPROC,*), 'Before MPI_INIT, ww3_shel' -!/OMPH ! For hybrid MPI-OpenMP specify required thread level. JGLi06Sep2019 -!/OMPH IF( FLHYBR ) THEN -!/OMPH CALL MPI_INIT_THREAD( MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) -!/OMPH ELSE -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/OMPH ENDIF -!/DEBUGINIT write(740+IAPROC,*), 'After MPI_INIT, ww3_shel' -!/MPI MPI_COMM = MPI_COMM_WORLD -!/OASIS END IF -! -! -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM, NAPROC, IERR_MPI ) -!/DEBUGINIT write(740+IAPROC,*) 'After MPI_COMM_SIZE, NAPROC=', NAPROC -!/MPI CALL MPI_COMM_RANK ( MPI_COMM, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 -! -!/NCO/! IF ( IAPROC .EQ. 1 ) CALL W3TAGB & -!/NCO/! ('WAVEFCST',1998,0007,0050,'NP21 ') - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 1' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! +#ifdef W3_SHRD + NAPROC = 1 + IAPROC = 1 +#endif +! +#ifdef W3_OMPH + FLHYBR = .TRUE. +#endif + +#ifdef W3_OASIS + IF (OASISED.EQ.1) THEN + CALL CPL_OASIS_INIT(MPI_COMM) + ELSE +#endif +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before MPI_INIT, ww3_shel' +#endif +#ifdef W3_OMPH + ! For hybrid MPI-OpenMP specify required thread level. JGLi06Sep2019 + IF( FLHYBR ) THEN + CALL MPI_INIT_THREAD( MPI_THREAD_FUNNELED, THRLEV, IERR_MPI) + ELSE +#endif +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) +#endif +#ifdef W3_OMPH + ENDIF +#endif +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'After MPI_INIT, ww3_shel' +#endif +#ifdef W3_MPI + MPI_COMM = MPI_COMM_WORLD +#endif +#ifdef W3_OASIS + END IF +#endif +! +! +#ifdef W3_MPI + CALL MPI_COMM_SIZE ( MPI_COMM, NAPROC, IERR_MPI ) +#endif +#ifdef W3_DEBUGINIT + write(740+IAPROC,*) 'After MPI_COMM_SIZE, NAPROC=', NAPROC +#endif +#ifdef W3_MPI + CALL MPI_COMM_RANK ( MPI_COMM, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 +#endif +! +#ifdef W3_NCO +! IF ( IAPROC .EQ. 1 ) CALL W3TAGB & +! ('WAVEFCST',1998,0007,0050,'NP21 ') +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. IO set-up ! 1.a For shell ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'ww3_shel, step 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ww3_shel, step 1' + FLUSH(740+IAPROC) +#endif NDSI = 10 NDSS = 90 NDSO = 6 NDSE = 6 NDST = 6 NDSL = 50 -!/COU NDSO = 333 -!/COU NDSE = 333 -!/COU NDST = 333 +#ifdef W3_COU + NDSO = 333 + NDSE = 333 + NDST = 333 +#endif NDSF(-7) = 1008 @@ -469,35 +549,41 @@ PROGRAM W3SHEL NDSF(7) = 17 NDSF(8) = 18 NDSF(9) = 19 -!/DEBUGINIT WRITE(740+IAPROC,*) 'ww3_shel, step 2' -!/DEBUGINIT FLUSH(740+IAPROC) -! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDSI = 11 -!/NCO NDSS = 90 -!/NCO NDSO = 6 -!/NCO NDSE = NDSO -!/NCO NDST = NDSO -!/NCO NDSF(1) = 12 -!/NCO NDSF(2) = 13 -!/NCO NDSF(3) = 14 -!/NCO NDSF(4) = 15 -!/NCO NDSF(5) = 16 -!/NCO NDSF(6) = 17 -!/NCO NDSF(7) = 18 -!/NCO NDSF(8) = 19 -!/NCO NDSF(9) = 20 +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ww3_shel, step 2' + FLUSH(740+IAPROC) +#endif +! +#ifdef W3_NCO +! +! Redo according to NCO +! + NDSI = 11 + NDSS = 90 + NDSO = 6 + NDSE = NDSO + NDST = NDSO + NDSF(1) = 12 + NDSF(2) = 13 + NDSF(3) = 14 + NDSF(4) = 15 + NDSF(5) = 16 + NDSF(6) = 17 + NDSF(7) = 18 + NDSF(8) = 19 + NDSF(9) = 20 +#endif ! NAPOUT = 1 NAPERR = 1 ! -!/COU OFILE = 'output.ww3' -!/COU OFL = LEN_TRIM(OFILE) -!/COU J = LEN_TRIM(FNMPRE) -!/COU IF ( IAPROC .EQ. NAPOUT ) & -!/COU OPEN (333,FILE=FNMPRE(:J)//OFILE(:OFL),ERR=2008,IOSTAT=IERR) +#ifdef W3_COU + OFILE = 'output.ww3' + OFL = LEN_TRIM(OFILE) + J = LEN_TRIM(FNMPRE) + IF ( IAPROC .EQ. NAPOUT ) & + OPEN (333,FILE=FNMPRE(:J)//OFILE(:OFL),ERR=2008,IOSTAT=IERR) +#endif IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,900) ! @@ -506,8 +592,10 @@ PROGRAM W3SHEL ELSE NDSEN = -1 END IF -!/OMPH IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,905) & -!/OMPH MPI_THREAD_FUNNELED, THRLEV +#ifdef W3_OMPH + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,905) & + MPI_THREAD_FUNNELED, THRLEV +#endif ! ! @@ -530,26 +618,30 @@ PROGRAM W3SHEL NTRACE(1) = NDS(3) NTRACE(2) = 10 ! -!/NCO/! -!/NCO/! Redo according to NCO -!/NCO/! -!/NCO NDS( 1) = 51 -!/NCO NDS( 2) = NDSO -!/NCO NDS( 3) = NDSO -!/NCO NDS( 4) = NDSO -!/NCO NDS( 5) = 20 -!/NCO NDS( 6) = 21 -!/NCO NDS( 7) = 52 -!/NCO NDS( 8) = 53 -!/NCO NDS( 9) = 22 -!/NCO NDS(10) = 71 -!/NCO NDS(11) = 23 -!/NCO NDS(12) = 54 -!/NCO NDS(13) = 55 -!/NCO NTRACE(1) = NDSO -! -!/T WRITE (NDST,9000) (NDS(I),I=1,12) -!/T WRITE (NDST,9001) (NTRACE(I),I=1,2) +#ifdef W3_NCO +! +! Redo according to NCO +! + NDS( 1) = 51 + NDS( 2) = NDSO + NDS( 3) = NDSO + NDS( 4) = NDSO + NDS( 5) = 20 + NDS( 6) = 21 + NDS( 7) = 52 + NDS( 8) = 53 + NDS( 9) = 22 + NDS(10) = 71 + NDS(11) = 23 + NDS(12) = 54 + NDS(13) = 55 + NTRACE(1) = NDSO +#endif +! +#ifdef W3_T + WRITE (NDST,9000) (NDS(I),I=1,12) + WRITE (NDST,9001) (NTRACE(I),I=1,2) +#endif ! ! 1.c Local parameters ! @@ -562,28 +654,50 @@ PROGRAM W3SHEL FLLSTI = .FALSE. ! This is associated with J.EQ.4 (ice) FLLSTR = .FALSE. ! This is associated with J.EQ.6 (rhoa) FLLST_ALL = .FALSE. ! For all -!/DEBUGINIT WRITE(740+IAPROC,*) 'ww3_shel, step 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ww3_shel, step 3' + FLUSH(740+IAPROC) +#endif ! If using experimental mud or ice physics, additional lines will ! be read in from ww3_shel.inp and applied, so JFIRST is changed from ! its initialization setting "JFIRST=1" to some lower value. -!/IC1 JFIRST=-7 -!/IC2 JFIRST=-7 -!/IS2 JFIRST=-7 -!/IC3 JFIRST=-7 -!/BT8 JFIRST=-7 -!/BT9 JFIRST=-7 -!/IC4 JFIRST=-7 -!/IC5 JFIRST=-7 - -!/DEBUGINIT WRITE(740+IAPROC,*) 'ww3_shel, step 4' -!/DEBUGINIT WRITE(740+IAPROC,*) 'JFIRST=', JFIRST -!/DEBUGINIT FLUSH(740+IAPROC) - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2a' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_IC1 + JFIRST=-7 +#endif +#ifdef W3_IC2 + JFIRST=-7 +#endif +#ifdef W3_IS2 + JFIRST=-7 +#endif +#ifdef W3_IC3 + JFIRST=-7 +#endif +#ifdef W3_BT8 + JFIRST=-7 +#endif +#ifdef W3_BT9 + JFIRST=-7 +#endif +#ifdef W3_IC4 + JFIRST=-7 +#endif +#ifdef W3_IC5 + JFIRST=-7 +#endif + +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ww3_shel, step 4' + WRITE(740+IAPROC,*) 'JFIRST=', JFIRST + FLUSH(740+IAPROC) +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2a' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -710,14 +824,24 @@ PROGRAM W3SHEL END IF IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG END DO -!/COU IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 -!/COU IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 +#ifdef W3_COU + IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 + IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 +#endif INFLAGS1(10) = .FALSE. -!/MGW INFLAGS1(10) = .TRUE. -!/MGP INFLAGS1(10) = .TRUE. -!/MGW FLH(10) = .TRUE. -!/MGP FLH(10) = .TRUE. +#ifdef W3_MGW + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGP + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGW + FLH(10) = .TRUE. +#endif +#ifdef W3_MGP + FLH(10) = .TRUE. +#endif IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' ! @@ -738,7 +862,9 @@ PROGRAM W3SHEL ! changed when model reads last record of ice.ww3 INFLAGS2=INFLAGS1 -!/T WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH +#ifdef W3_T + WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH +#endif @@ -806,21 +932,25 @@ PROGRAM W3SHEL ODAT(33) = MAX ( 0 , ODAT(33) ) ODAT(38) = MAX ( 0 , ODAT(38) ) ! -!/COU ! Test the validity of the coupling time step -!/COU IF (ODAT(33) == 0) THEN -!/COU IF ( IAPROC .EQ. NAPOUT ) THEN -!/COU WRITE(NDSO,1010) ODAT(33), INT(DTMAX) -!/COU END IF -!/COU ODAT(33) = INT(DTMAX) -!/COU ELSE IF (MOD(ODAT(33),INT(DTMAX)) .NE. 0) THEN -!/COU GOTO 2009 -!/COU END IF +#ifdef W3_COU + ! Test the validity of the coupling time step + IF (ODAT(33) == 0) THEN + IF ( IAPROC .EQ. NAPOUT ) THEN + WRITE(NDSO,1010) ODAT(33), INT(DTMAX) + END IF + ODAT(33) = INT(DTMAX) + ELSE IF (MOD(ODAT(33),INT(DTMAX)) .NE. 0) THEN + GOTO 2009 + END IF +#endif ! ! 2.5 Output types NPTS = 0 NOTYPE = 6 -!/COU NOTYPE = 7 +#ifdef W3_COU + NOTYPE = 7 +#endif DO J = 1, NOTYPE ! OUTPTS(I)%OFILES(J)=OFILES(J) IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN @@ -930,14 +1060,16 @@ PROGRAM W3SHEL WRITE (NDSO,6945) IPRT, YESXNO END IF -!/COU ! Type 7: coupling -!/COU ELSE IF ( J .EQ. 7 ) THEN -!/COU FLDOUT = NML_OUTPUT_TYPE%COUPLING%SENT -!/COU CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLG2, & -!/COU FLGR2, IAPROC, NAPOUT, IERR ) -!/COU IF ( IERR .NE. 0 ) GOTO 2222 -!/COU FLDIN = NML_OUTPUT_TYPE%COUPLING%RECEIVED -!/COU CPLT0 = NML_OUTPUT_TYPE%COUPLING%COUPLET0 +#ifdef W3_COU + ! Type 7: coupling + ELSE IF ( J .EQ. 7 ) THEN + FLDOUT = NML_OUTPUT_TYPE%COUPLING%SENT + CALL W3FLGRDFLAG ( NDSO, NDSO, NDSE, FLDOUT, FLG2, & + FLGR2, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + FLDIN = NML_OUTPUT_TYPE%COUPLING%RECEIVED + CPLT0 = NML_OUTPUT_TYPE%COUPLING%COUPLET0 +#endif END IF ! J END IF ! ODAT @@ -1028,25 +1160,27 @@ PROGRAM W3SHEL END DO END IF -!/O7 DO J=JFIRST, 10 -!/O7 IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN -!/O7 WRITE (NDSO,952) NH(J), IDFLDS(J) -!/O7 DO I=1, NH(J) -!/O7 IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & -!/O7 ( J .EQ. 6 ) ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J) -!/O7 ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & -!/O7 ( J .EQ. 10 ) ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J), HD(I,J) -!/O7 ELSE IF ( J .EQ. 3 ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J), HD(I,J), HS(I,J) -!/O7 END IF -!/O7 END DO -!/O7 END IF -!/O7 END DO +#ifdef W3_O7 + DO J=JFIRST, 10 + IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN + WRITE (NDSO,952) NH(J), IDFLDS(J) + DO I=1, NH(J) + IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & + ( J .EQ. 6 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J) + ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & + ( J .EQ. 10 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J) + ELSE IF ( J .EQ. 3 ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J), HS(I,J) + END IF + END DO + END IF + END DO +#endif ! IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & ( FLH(-6) .AND. (NH(-6).EQ.0) ) .OR. & @@ -1076,17 +1210,23 @@ PROGRAM W3SHEL ! IF (.NOT. FLGNML) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) ' FNMPRE=', TRIM(FNMPRE) -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' FNMPRE=', TRIM(FNMPRE) + FLUSH(740+IAPROC) +#endif OPEN (NDSI,FILE=TRIM(FNMPRE)//'ww3_shel.inp',STATUS='OLD',IOSTAT=IERR) REWIND (NDSI) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before read 2002, case 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before read 2002, case 1' + FLUSH(740+IAPROC) +#endif !AR: I changed the error handling for err=2002, see commit message ... READ (NDSI,'(A)') COMSTR -!/DEBUGINIT WRITE(740+IAPROC,*) ' COMSTR=', COMSTR -!/DEBUGINIT WRITE(740+IAPROC,*) ' After read 2002, case 1' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' COMSTR=', COMSTR + WRITE(740+IAPROC,*) ' After read 2002, case 1' + FLUSH(740+IAPROC) +#endif IF (COMSTR.EQ.' ') COMSTR = '$' IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,901) COMSTR @@ -1096,19 +1236,27 @@ PROGRAM W3SHEL DO J=JFIRST, 9 CALL NEXTLN ( COMSTR , NDSI , NDSEN ) IF ( J .LE. 6 ) THEN -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before read 2002, case 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before read 2002, case 2' + FLUSH(740+IAPROC) +#endif READ (NDSI,*) FLAGTFC(J), FLH(J) -!/DEBUGINIT WRITE(740+IAPROC,*) ' J=', J, ' FLAGTFC=', FLAGTFC(J), ' FLH=', FLH(J) -!/DEBUGINIT WRITE(740+IAPROC,*) ' After read 2002, case 2' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' J=', J, ' FLAGTFC=', FLAGTFC(J), ' FLH=', FLH(J) + WRITE(740+IAPROC,*) ' After read 2002, case 2' + FLUSH(740+IAPROC) +#endif ELSE -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before read 2002, case 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before read 2002, case 3' + FLUSH(740+IAPROC) +#endif READ (NDSI,*) FLAGTFC(J) -!/DEBUGINIT WRITE(740+IAPROC,*) ' J=', J, ' FLAGTFC=', FLAGTFC(J) -!/DEBUGINIT WRITE(740+IAPROC,*) ' After read 2002, case 3' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' J=', J, ' FLAGTFC=', FLAGTFC(J) + WRITE(740+IAPROC,*) ' After read 2002, case 3' + FLUSH(740+IAPROC) +#endif END IF END DO @@ -1143,21 +1291,35 @@ PROGRAM W3SHEL END IF IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,921) IDFLDS(J), YESXNO, STRNG END DO -!/COU IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 -!/COU IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 - -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2b' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) - -!/DEBUGINIT WRITE(740+IAPROC,*) 'ww3_shel, step 5' -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_COU + IF (FLAGSC(1) .AND. INFLAGS1(2) .AND. .NOT. FLAGSC(2)) GOTO 2102 + IF (FLAGSC(2) .AND. INFLAGS1(1) .AND. .NOT. FLAGSC(1)) GOTO 2102 +#endif + +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2b' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif + +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ww3_shel, step 5' + FLUSH(740+IAPROC) +#endif ! INFLAGS1(10) = .FALSE. -!/MGW INFLAGS1(10) = .TRUE. -!/MGP INFLAGS1(10) = .TRUE. -!/MGW FLH(10) = .TRUE. -!/MGP FLH(10) = .TRUE. +#ifdef W3_MGW + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGP + INFLAGS1(10) = .TRUE. +#endif +#ifdef W3_MGW + FLH(10) = .TRUE. +#endif +#ifdef W3_MGP + FLH(10) = .TRUE. +#endif IF ( INFLAGS1(10) .AND. IAPROC.EQ.NAPOUT ) & WRITE (NDSO,921) IDFLDS(10), 'YES/--', ' ' ! @@ -1178,41 +1340,63 @@ PROGRAM W3SHEL ! changed when model reads last record of ice.ww3 INFLAGS2=INFLAGS1 -!/T WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH +#ifdef W3_T + WRITE (NDST,9020) FLFLG, INFLAGS1, FLHOM, FLH +#endif ! 2.2 Time setup CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 4' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 4' +#endif READ (NDSI,*) TIME0 -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 4' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 4' +#endif !/NETCDF_QAD TIME0_NETCDF_QAD = TIME0 -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2c' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2c' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 5' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 5' +#endif READ (NDSI,*) TIMEN -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 5' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 5' +#endif !/NETCDF_QAD TIMEN_NETCDF_QAD = TIMEN -!/DEBUGINIT write(740+IAPROC,*), 'ww3_shel, step 6' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'ww3_shel, step 6' +#endif ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2d' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 2d' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! 2.3 Domain setup -!/DEBUGINIT write(740+IAPROC,*), 'ww3_shel, step 7' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'ww3_shel, step 7' +#endif CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 6' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 6' +#endif READ (NDSI,*) IOSTYP -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 6' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 6' +#endif CALL W3IOGR ( 'GRID', NDSF(7) ) IF ( FLAGLL ) THEN FACTOR = 1. @@ -1220,18 +1404,28 @@ PROGRAM W3SHEL FACTOR = 1.E-3 END IF -!/DEBUGINIT write(740+IAPROC,*), 'ww3_shel, step 8' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'ww3_shel, step 8' +#endif ! 2.4 Output dates NPTS = 0 NOTYPE = 6 -!/COU NOTYPE = 7 -!/DEBUGINIT write(740+IAPROC,*), 'Before NOTYPE loop' +#ifdef W3_COU + NOTYPE = 7 +#endif +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before NOTYPE loop' +#endif DO J = 1, NOTYPE -!/DEBUGINIT write(740+IAPROC,*), 'J=', J, '/ NOTYPE=', NOTYPE +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'J=', J, '/ NOTYPE=', NOTYPE +#endif CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 7' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 7' +#endif ! ! CHECKPOINT IF(J .EQ. 4) THEN @@ -1288,34 +1482,40 @@ PROGRAM W3SHEL END IF -!/COU ELSE IF(J .EQ. 7) THEN -!/COU WORDS(1:6)='' -!/COU READ (NDSI,'(A)') LINEIN -!/COU READ(LINEIN,*,iostat=ierr) WORDS -!/COU -!/COU READ(WORDS( 1 ), * ) ODAT(31) -!/COU READ(WORDS( 2 ), * ) ODAT(32) -!/COU READ(WORDS( 3 ), * ) ODAT(33) -!/COU READ(WORDS( 4 ), * ) ODAT(34) -!/COU READ(WORDS( 5 ), * ) ODAT(35) -!/COU -!/COU IF (WORDS(6) .EQ. 'T') THEN -!/COU CPLT0 = .TRUE. -!/COU ELSE -!/COU CPLT0 = .FALSE. -!/COU END IF +#ifdef W3_COU + ELSE IF(J .EQ. 7) THEN + WORDS(1:6)='' + READ (NDSI,'(A)') LINEIN + READ(LINEIN,*,iostat=ierr) WORDS + + READ(WORDS( 1 ), * ) ODAT(31) + READ(WORDS( 2 ), * ) ODAT(32) + READ(WORDS( 3 ), * ) ODAT(33) + READ(WORDS( 4 ), * ) ODAT(34) + READ(WORDS( 5 ), * ) ODAT(35) + + IF (WORDS(6) .EQ. 'T') THEN + CPLT0 = .TRUE. + ELSE + CPLT0 = .FALSE. + END IF +#endif ELSE OFILES(J)=0 READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(J-1)+1,5*J) END IF ! WRITE(*,*) 'OFILES(J)= ', OFILES(J),J ! -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 7' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 7' +#endif ODAT(5*(J-1)+3) = MAX ( 0 , ODAT(5*(J-1)+3) ) ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL NOTTYPE', J -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL NOTTYPE', J + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! 2.5 Output types @@ -1323,7 +1523,9 @@ PROGRAM W3SHEL IF ( ODAT(5*(J-1)+3) .NE. 0 ) THEN ! Type 1: fields of mean wave parameters -!/DEBUGINIT write(740+IAPROC,*), 'Case analysis' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Case analysis' +#endif IF ( J .EQ. 1 ) THEN CALL W3READFLGRD ( NDSI, NDSO, 9, NDSEN, COMSTR, FLGD, & FLGRD, IAPROC, NAPOUT, IERR ) @@ -1340,7 +1542,9 @@ PROGRAM W3SHEL (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') ELSE NDSI2 = NDSS -!/MPI CALL MPI_BARRIER (MPI_COMM,IERR_MPI) +#ifdef W3_MPI + CALL MPI_BARRIER (MPI_COMM,IERR_MPI) +#endif OPEN (NDSS,FILE=TRIM(FNMPRE)//'ww3_shel.scratch') REWIND (NDSS) ! @@ -1357,9 +1561,13 @@ PROGRAM W3SHEL NPTS = 0 DO CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 8' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 8' +#endif READ (NDSI2,*) XX, YY, PN -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 8' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 8' +#endif IF ( ILOOP.EQ.1 .AND. IAPROC.EQ.1 ) THEN BACKSPACE (NDSI) READ (NDSI,'(A)') LINE @@ -1398,11 +1606,15 @@ PROGRAM W3SHEL IF ( NPTS.EQ.0 .AND. IAPROC.EQ.NAPOUT ) & WRITE (NDSO,2947) IF ( IAPROC .EQ. 1 ) THEN -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif CLOSE (NDSS,STATUS='DELETE') ELSE CLOSE (NDSS) -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif END IF ! @@ -1410,9 +1622,13 @@ PROGRAM W3SHEL ! Type 3: track output ELSE IF ( J .EQ. 3 ) THEN CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 9' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 9' +#endif READ (NDSI,*) TFLAGI -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 9' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 9' +#endif ! IF ( .NOT. TFLAGI ) NDS(11) = -NDS(11) IF ( IAPROC .EQ. NAPOUT ) THEN @@ -1428,10 +1644,14 @@ PROGRAM W3SHEL ELSE IF ( J .EQ. 6 ) THEN ! IPRT: IX0, IXN, IXS, IY0, IYN, IYS CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before reading IPRT' -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 10' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before reading IPRT' + write(740+IAPROC,*), 'Before read 2002, case 10' +#endif READ (NDSI,*) IPRT, PRTFRM -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 10' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 10' +#endif ! IF ( IAPROC .EQ. NAPOUT ) THEN IF ( PRTFRM ) THEN @@ -1443,13 +1663,15 @@ PROGRAM W3SHEL END IF -!/COU ! Type 7: coupling -!/COU ELSE IF ( J .EQ. 7 ) THEN -!/COU CALL W3READFLGRD ( NDSI, NDSO, NDSS, NDSEN, COMSTR, FLG2, & -!/COU FLGR2, IAPROC, NAPOUT, IERR ) -!/COU IF ( IERR .NE. 0 ) GOTO 2222 -!/COU CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/COU READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) FLDIN +#ifdef W3_COU + ! Type 7: coupling + ELSE IF ( J .EQ. 7 ) THEN + CALL W3READFLGRD ( NDSI, NDSO, NDSS, NDSEN, COMSTR, FLG2, & + FLGR2, IAPROC, NAPOUT, IERR ) + IF ( IERR .NE. 0 ) GOTO 2222 + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,'(A)',END=2001,ERR=2002,IOSTAT=IERR) FLDIN +#endif END IF ! J END IF ! ODAT @@ -1469,9 +1691,13 @@ PROGRAM W3SHEL ! Start of loop DO CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 11' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 11' +#endif READ (NDSI,*) IDTST -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 11' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 11' +#endif ! Exit if illegal id @@ -1497,76 +1723,108 @@ PROGRAM W3SHEL NH(J) = NH(J) + 1 IF ( NH(J) .GT. NHMAX ) GOTO 2006 IF ( J .LE. 1 ) THEN ! water levels, etc. : get HA -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 12' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 12' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 12' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 12' +#endif ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 13' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 13' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J), HD(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 13' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 13' +#endif ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 14' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 14' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J), HD(NH(J),J), HS(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 14' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 14' +#endif ELSE IF ( J .EQ. 4 ) THEN ! ice -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 15' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 15' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 15' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 15' +#endif ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 16' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 16' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J), HD(NH(J),j) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 16' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 16' +#endif ELSE IF ( J .EQ. 6 ) THEN ! air density -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 17' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 17' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 16' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 16' +#endif ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD -!/DEBUGINIT write(740+IAPROC,*), 'Before read 2002, case 18' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'Before read 2002, case 18' +#endif READ (NDSI,*) IDTST, & THO(1,J,NH(J)), THO(2,J,NH(J)), & HA(NH(J),J), HD(NH(J),J) -!/DEBUGINIT write(740+IAPROC,*), ' After read 2002, case 18' +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), ' After read 2002, case 18' +#endif END IF END IF END DO END DO -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 3' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) -! - -!/O7 DO J=JFIRST, 10 -!/O7 IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN -!/O7 WRITE (NDSO,952) NH(J), IDFLDS(J) -!/O7 DO I=1, NH(J) -!/O7 IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & -!/O7 ( J .EQ. 6 ) ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J) -!/O7 ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & -!/O7 ( J .EQ. 10 ) ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J), HD(I,J) -!/O7 ELSE IF ( J .EQ. 3 ) THEN -!/O7 WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & -!/O7 HA(I,J), HD(I,J), HS(I,J) -!/O7 END IF -!/O7 END DO -!/O7 END IF -!/O7 END DO +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 3' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif +! + +#ifdef W3_O7 + DO J=JFIRST, 10 + IF ( FLH(J) .AND. IAPROC.EQ.NAPOUT ) THEN + WRITE (NDSO,952) NH(J), IDFLDS(J) + DO I=1, NH(J) + IF ( ( J .LE. 1 ) .OR. ( J .EQ. 4 ) .OR. & + ( J .EQ. 6 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J) + ELSE IF ( ( J .EQ. 2 ) .OR. ( J .EQ. 5 ) .OR. & + ( J .EQ. 10 ) ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J) + ELSE IF ( J .EQ. 3 ) THEN + WRITE (NDSO,953) I, THO(1,J,I), THO(2,J,I), & + HA(I,J), HD(I,J), HS(I,J) + END IF + END DO + END IF + END DO +#endif ! ! IF ( ( FLH(-7) .AND. (NH(-7).EQ.0) ) .OR. & @@ -1608,7 +1866,9 @@ PROGRAM W3SHEL ! DO J=JFIRST, 6 -!/DEBUGINIT write(740+IAPROC,*), 'J=',J,'INFLAGS1(J)=',INFLAGS1(J), 'FLAGSC(J)=', FLAGSC(J) +#ifdef W3_DEBUGINIT + write(740+IAPROC,*), 'J=',J,'INFLAGS1(J)=',INFLAGS1(J), 'FLAGSC(J)=', FLAGSC(J) +#endif IF ( INFLAGS1(J) .AND. .NOT. FLAGSC(J)) THEN IF ( FLH(J) ) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,954) IDFLDS(J) @@ -1618,8 +1878,10 @@ PROGRAM W3SHEL NDSEN, NX, NY, GTYPE, & IERR, FPRE=TRIM(FNMPRE), TIDEFLAGIN=FLAGTIDE ) IF ( IERR .NE. 0 ) GOTO 2222 -!/TIDE IF (FLAGTIDE.GT.0.AND.J.EQ.1) FLAGSTIDE(1)=.TRUE. -!/TIDE IF (FLAGTIDE.GT.0.AND.J.EQ.2) FLAGSTIDE(2)=.TRUE. +#ifdef W3_TIDE + IF (FLAGTIDE.GT.0.AND.J.EQ.1) FLAGSTIDE(1)=.TRUE. + IF (FLAGTIDE.GT.0.AND.J.EQ.2) FLAGSTIDE(2)=.TRUE. +#endif IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,955) IDFLDS(J) END IF ELSE @@ -1643,9 +1905,11 @@ PROGRAM W3SHEL END IF ! FLFLG -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 4' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 4' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! 2.2 Time setup @@ -1656,9 +1920,13 @@ PROGRAM W3SHEL TIME = TIME0 CALL STME21 ( TIMEN , DTME21 ) IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,932) DTME21 -!/OASIS TIME00 = TIME0 -!/OASIS TIMEEND = TIMEN -!/NL5 QI5TBEG = TIME0 +#ifdef W3_OASIS + TIME00 = TIME0 + TIMEEND = TIMEN +#endif +#ifdef W3_NL5 + QI5TBEG = TIME0 +#endif ! DTTST = DSEC21 ( TIME0 , TIMEN ) IF ( DTTST .LE. 0. ) GOTO 2003 @@ -1749,9 +2017,11 @@ PROGRAM W3SHEL ! ! 2.5 Output types -!/T WRITE (NDST,9040) ODAT -!/T WRITE (NDST,9041) FLGRD -!/T WRITE (NDST,9042) IPRT, PRTFRM +#ifdef W3_T + WRITE (NDST,9040) ODAT + WRITE (NDST,9041) FLGRD + WRITE (NDST,9042) IPRT, PRTFRM +#endif ! ! For outputs with non-zero time step, check dates : @@ -1790,9 +2060,11 @@ PROGRAM W3SHEL CONTINUE END IF ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Initializations @@ -1800,21 +2072,25 @@ PROGRAM W3SHEL IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) 'Wave model ...' ! -!/TIDE IF (FLAGSTIDE(1).OR.FLAGSTIDE(2)) THEN -!/TIDE CALL VUF_SET_PARAMETERS -!/TIDE IF (FLAGSTIDE(1)) CALL W3FLDTIDE1 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), IERR ) -!/TIDE IF (FLAGSTIDE(2)) CALL W3FLDTIDE1 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), IERR ) -!/TIDE END IF +#ifdef W3_TIDE + IF (FLAGSTIDE(1).OR.FLAGSTIDE(2)) THEN + CALL VUF_SET_PARAMETERS + IF (FLAGSTIDE(1)) CALL W3FLDTIDE1 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), IERR ) + IF (FLAGSTIDE(2)) CALL W3FLDTIDE1 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), IERR ) + END IF +#endif ! -!/COU ! Sent coupled fields must be written in the restart when coupling at T+0 -!/COU IF (CPLT0) THEN -!/COU DO J=1, NOGRP -!/COU FLOGR(J) = FLOGR(J) .OR. FLG2(J) -!/COU DO I=1, NGRPP -!/COU FLOGRR(J,I) = FLOGRR(J,I) .OR. FLGR2(J,I) -!/COU END DO -!/COU END DO -!/COU ENDIF +#ifdef W3_COU + ! Sent coupled fields must be written in the restart when coupling at T+0 + IF (CPLT0) THEN + DO J=1, NOGRP + FLOGR(J) = FLOGR(J) .OR. FLG2(J) + DO I=1, NGRPP + FLOGRR(J,I) = FLOGRR(J,I) .OR. FLGR2(J,I) + END DO + END DO + ENDIF +#endif ! OARST = ANY(FLOGR) ! @@ -1834,36 +2110,44 @@ PROGRAM W3SHEL ! ENDIF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 5' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! -!/TIDE IF (FLAGSTIDE(1)) CALL W3FLDTIDE2 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), 1, IERR ) -!/TIDE IF (FLAGSTIDE(2)) CALL W3FLDTIDE2 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), 1, IERR ) -!/TIDE ALLOCATE(V_ARG(170,1),F_ARG(170,1),U_ARG(170,1)) ! to be removed later ... +#ifdef W3_TIDE + IF (FLAGSTIDE(1)) CALL W3FLDTIDE2 ( 'READ', NDSF(1), NDST, NDSEN, NX, NY, IDSTR(1), 1, IERR ) + IF (FLAGSTIDE(2)) CALL W3FLDTIDE2 ( 'READ', NDSF(2), NDST, NDSEN, NX, NY, IDSTR(2), 1, IERR ) + ALLOCATE(V_ARG(170,1),F_ARG(170,1),U_ARG(170,1)) ! to be removed later ... +#endif ! ALLOCATE ( XXX(NX,NY) ) ! ! -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif ! IF ( IAPROC .EQ. NAPOUT ) THEN CALL DATE_AND_TIME ( VALUES=CLKDT2 ) END IF !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! -!/OASIS ! Initialize L_MASTER, COUPL_COMM -!/OASIS IF ( IAPROC .EQ. 1) THEN -!/OASIS L_MASTER = .TRUE. -!/OASIS ELSE -!/OASIS L_MASTER = .FALSE. -!/OASIS ENDIF -!/OASIS ! Estimate the weights for the spatial interpolation -!/OASIS IF (DTOUT(7).NE.0) THEN -!/OASIS CALL CPL_OASIS_GRID(L_MASTER,MPI_COMM) -!/OASIS CALL CPL_OASIS_DEFINE(NDSO, FLDIN, FLDOUT) -!/OASIS END IF +#ifdef W3_OASIS + ! Initialize L_MASTER, COUPL_COMM + IF ( IAPROC .EQ. 1) THEN + L_MASTER = .TRUE. + ELSE + L_MASTER = .FALSE. + ENDIF + ! Estimate the weights for the spatial interpolation + IF (DTOUT(7).NE.0) THEN + CALL CPL_OASIS_GRID(L_MASTER,MPI_COMM) + CALL CPL_OASIS_DEFINE(NDSO, FLDIN, FLDOUT) + END IF +#endif !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1880,15 +2164,19 @@ PROGRAM W3SHEL ! CALL EXTCDE(666) ! ENDIF -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 6' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 6' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif IF ( .NOT. FLFLG ) THEN ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,960) CALL W3WAVE ( 1, ODAT, TIMEN & -!/OASIS , .TRUE., .FALSE., MPI_COMM, TIMEN & +#ifdef W3_OASIS + , .TRUE., .FALSE., MPI_COMM, TIMEN & +#endif ) ! GOTO 2222 @@ -1900,12 +2188,22 @@ PROGRAM W3SHEL IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,970) ! -!/OASIS ! Send coupling fields at the initial time step -!/OASIS IF ( FLOUT(7) .AND. CPLT0 ) THEN -!/OASACM CALL SND_FIELDS_TO_ATMOS() -!/OASOCM CALL SND_FIELDS_TO_OCEAN() -!/OASICM CALL SND_FIELDS_TO_ICE() -!/OASIS END IF +#ifdef W3_OASIS + ! Send coupling fields at the initial time step + IF ( FLOUT(7) .AND. CPLT0 ) THEN +#endif +#ifdef W3_OASACM + CALL SND_FIELDS_TO_ATMOS() +#endif +#ifdef W3_OASOCM + CALL SND_FIELDS_TO_OCEAN() +#endif +#ifdef W3_OASICM + CALL SND_FIELDS_TO_ICE() +#endif +#ifdef W3_OASIS + END IF +#endif 700 CONTINUE ! @@ -1918,36 +2216,42 @@ PROGRAM W3SHEL CALL STME21 ( TIME0 , DTME21 ) IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,971) DTME21 ! -!/T WRITE (NDST,9070) '0-N', TIME0, TTIME, & -!/T IDSTR(-7), INFLAGS1(-7), TI1, & -!/T IDSTR(-6), INFLAGS1(-6), TI2, & -!/T IDSTR(-5), INFLAGS1(-5), TI3, & -!/T IDSTR(-4), INFLAGS1(-4), TI4, & -!/T IDSTR(-3), INFLAGS1(-3), TI5, & -!/T IDSTR(-2), INFLAGS1(-2), TZN, & -!/T IDSTR(-1), INFLAGS1(-1), TTN, & -!/T IDSTR(0), INFLAGS1(0), TVN, & -!/T IDSTR(1), INFLAGS1(1), TLN, & -!/T IDSTR(2), INFLAGS1(2), TC0, TCN, & -!/T IDSTR(3), INFLAGS1(3), TW0, TWN, & -!/T IDSTR(4), INFLAGS1(4), TIN, & -!/T IDSTR(5), INFLAGS1(5), TU0, TUN, & -!/T IDSTR(6), INFLAGS1(6), TR0, TRN, & -!/T IDSTR(7), INFLAGS1(7), T0N, & -!/T IDSTR(8), INFLAGS1(8), T1N, & -!/T IDSTR(9), INFLAGS1(9), T2N, & -!/T IDSTR(10), INFLAGS1(10), TG0, TGN -! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 7' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_T + WRITE (NDST,9070) '0-N', TIME0, TTIME, & + IDSTR(-7), INFLAGS1(-7), TI1, & + IDSTR(-6), INFLAGS1(-6), TI2, & + IDSTR(-5), INFLAGS1(-5), TI3, & + IDSTR(-4), INFLAGS1(-4), TI4, & + IDSTR(-3), INFLAGS1(-3), TI5, & + IDSTR(-2), INFLAGS1(-2), TZN, & + IDSTR(-1), INFLAGS1(-1), TTN, & + IDSTR(0), INFLAGS1(0), TVN, & + IDSTR(1), INFLAGS1(1), TLN, & + IDSTR(2), INFLAGS1(2), TC0, TCN, & + IDSTR(3), INFLAGS1(3), TW0, TWN, & + IDSTR(4), INFLAGS1(4), TIN, & + IDSTR(5), INFLAGS1(5), TU0, TUN, & + IDSTR(6), INFLAGS1(6), TR0, TRN, & + IDSTR(7), INFLAGS1(7), T0N, & + IDSTR(8), INFLAGS1(8), T1N, & + IDSTR(9), INFLAGS1(9), T2N, & + IDSTR(10), INFLAGS1(10), TG0, TGN +#endif +! +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 7' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif DO J=JFIRST,10 ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL UPDATE', J -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL UPDATE', J + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif IF ( INFLAGS1(J) ) THEN ! @@ -1961,24 +2265,32 @@ PROGRAM W3SHEL ELSE DTTST = DSEC21 ( TIME0 , TTT ) END IF -!/OASIS ELSE -!/OASIS ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) -!/OASIS IF ( (DTOUT(7).NE.0) .AND. & -!/OASIS (MOD(ID_OASIS_TIME, NINT(DTOUT(7))) .EQ. 0 ) .AND. & -!/OASIS (DSEC21 (TIME, TIMEEND) .GT. 0.0)) DTTST=0. +#ifdef W3_OASIS + ELSE + ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + IF ( (DTOUT(7).NE.0) .AND. & + (MOD(ID_OASIS_TIME, NINT(DTOUT(7))) .EQ. 0 ) .AND. & + (DSEC21 (TIME, TIMEEND) .GT. 0.0)) DTTST=0. +#endif END IF ! -!/T WRITE (NDST,9071) IDSTR(J), DTTST +#ifdef W3_T + WRITE (NDST,9071) IDSTR(J), DTTST +#endif ! ! 7.a.3 Update time and fields / data ! IF ( DTTST .LE. 0. ) THEN -!/TIDE IF ((FLLEVTIDE .AND.(J.EQ.1)).OR.(FLCURTIDE.AND.(J.EQ.2))) THEN -!/TIDE IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) IDFLDS(J) -!/TIDE ELSE +#ifdef W3_TIDE + IF ((FLLEVTIDE .AND.(J.EQ.1)).OR.(FLCURTIDE.AND.(J.EQ.2))) THEN + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,974) IDFLDS(J) + ELSE +#endif IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,972) IDFLDS(J) -!/TIDE END IF +#ifdef W3_TIDE + END IF +#endif ! ! IC1 : (in context of IC3 & IC2, this is ice thickness) IF ( J .EQ. -7 ) THEN @@ -1987,14 +2299,20 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, IERR) ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASICM IF (FLAGSC(J)) FLAGSCI = .TRUE. -!/OASICM IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASICM + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TTT, XXX, XXX, XXX, TI1, XXX, XXX, ICEP1, & IERR, FLAGSC(J) & -!/OASICM , COUPL_COMM & +#ifdef W3_OASICM + , COUPL_COMM & +#endif ) END IF IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. @@ -2048,14 +2366,20 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, IERR) ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASICM IF (FLAGSC(J)) FLAGSCI = .TRUE. -!/OASICM IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASICM + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TTT, XXX, XXX, XXX, TI5, XXX, XXX, ICEP5, & IERR, FLAGSC(J) & -!/OASICM , COUPL_COMM & +#ifdef W3_OASICM + , COUPL_COMM & +#endif ) END IF IF ( IERR .LT. 0 )FLLST_ALL(J) = .TRUE. @@ -2109,23 +2433,33 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, IERR) ELSE -!/TIDE IF ( FLLEVTIDE ) THEN -!/TIDE IERR=0 -!/TIDE IF ( TLN(1) .EQ. -1 ) THEN -!/TIDE TLN = TIME -!/TIDE ELSE -!/TIDE CALL TICK21 ( TLN, TIDE_DT ) -!/TIDE END IF -!/TIDE ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASOCM IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#ifdef W3_TIDE + IF ( FLLEVTIDE ) THEN + IERR=0 + IF ( TLN(1) .EQ. -1 ) THEN + TLN = TIME + ELSE + CALL TICK21 ( TLN, TIDE_DT ) + END IF + ELSE +#endif +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASOCM + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TTT, XXX, XXX, XXX, TLN, XXX, XXX, WLEV, & IERR, FLAGSC(J) & -!/OASOCM , COUPL_COMM & +#ifdef W3_OASOCM + , COUPL_COMM & +#endif ) -!/TIDE END IF +#ifdef W3_TIDE + END IF +#endif END IF IF ( IERR .LT. 0 ) FLLSTL = .TRUE. !could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. @@ -2137,31 +2471,43 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) ! -!/SMC !!Li Reshape the CX0/N CY0/N space for sea-point only current. -!/SMC !!Li JGLi26Jun2018. -!/SMC ELSE IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & -!/SMC NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TC0, & -!/SMC CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) -!/SMC !!Li +#ifdef W3_SMC + !!Li Reshape the CX0/N CY0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TC0, & + CX0, CY0, XXX, TCN, CXN, CYN, XXX, IERR) + !!Li +#endif ELSE -!/TIDE IF ( FLCURTIDE ) THEN -!/TIDE IERR=0 -!/TIDE IF ( TCN(1) .EQ. -1 ) THEN -!/TIDE TCN = TIME -!/TIDE END IF -!/TIDE TC0(:) = TCN(:) -!/TIDE CALL TICK21 ( TCN, TIDE_DT ) -!/TIDE ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASOCM IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#ifdef W3_TIDE + IF ( FLCURTIDE ) THEN + IERR=0 + IF ( TCN(1) .EQ. -1 ) THEN + TCN = TIME + END IF + TC0(:) = TCN(:) + CALL TICK21 ( TCN, TIDE_DT ) + ELSE +#endif +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASOCM + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TC0, CX0, CY0, XXX, TCN, CXN, CYN, XXX, & IERR, FLAGSC(J) & -!/OASOCM , COUPL_COMM & +#ifdef W3_OASOCM + , COUPL_COMM & +#endif ) -!/TIDE END IF +#ifdef W3_TIDE + END IF +#endif END IF ! WND : winds @@ -2171,21 +2517,29 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) ! -!/SMC !!Li Reshape the WX0/N WY0/N space for sea-point only wind. -!/SMC !!Li JGLi26Jun2018. -!/SMC ELSE IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & -!/SMC NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TW0, & -!/SMC WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) -!/SMC !!Li +#ifdef W3_SMC + !!Li Reshape the WX0/N WY0/N space for sea-point only wind. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TW0, & + WX0, WY0, DT0, TWN, WXN, WYN, DTN, IERR) + !!Li +#endif ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASACM IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASACM + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TW0, WX0, WY0, DT0, TWN, WXN, WYN, DTN, & IERR, FLAGSC(J) & -!/OASACM , COUPL_COMM & +#ifdef W3_OASACM + , COUPL_COMM & +#endif ) END IF @@ -2196,14 +2550,20 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, IERR) ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASICM IF (FLAGSC(J)) FLAGSCI = .TRUE. -!/OASICM IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASICM + IF (FLAGSC(J)) FLAGSCI = .TRUE. + IF (.NOT.FLAGSCI) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TTT, XXX, XXX, XXX, TIN, XXX, BERGI, ICEI, & IERR, FLAGSC(J) & -!/OASICM , COUPL_COMM & +#ifdef W3_OASICM + , COUPL_COMM & +#endif ) IF ( IERR .LT. 0 ) FLLSTI = .TRUE. !could be: IF ( IERR .LT. 0 ) FLLST_ALL(J) = .TRUE. @@ -2216,21 +2576,29 @@ PROGRAM W3SHEL TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) ! -!/SMC !!Li Reshape the UX0/N UY0/N space for sea-point only current. -!/SMC !!Li JGLi26Jun2018. -!/SMC ELSE IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & -!/SMC NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TU0, & -!/SMC UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) -!/SMC !!Li +#ifdef W3_SMC + !!Li Reshape the UX0/N UY0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TU0, & + UX0, UY0, XXX, TUN, UXN, UYN, XXX, IERR) + !!Li +#endif ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASACM IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASACM + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TU0, UX0, UY0, XXX, TUN, UXN, UYN, XXX, & IERR, FLAGSC(J) & -!/OASACM , COUPL_COMM & +#ifdef W3_OASACM + , COUPL_COMM & +#endif ) END IF @@ -2240,21 +2608,29 @@ PROGRAM W3SHEL CALL W3FLDH (J, NDST, NDSEN, NX, NY, NX, NY, & TIME0, TIMEN, NH(J), NHMAX, THO, HA, HD, HS,& TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) -!/SMC !!Li Reshape the RH0/N space for sea-point only current. -!/SMC !!Li JGLi26Jun2018. -!/SMC ELSE IF( FSWND ) THEN -!/SMC CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & -!/SMC NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TR0, & -!/SMC XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) -!/SMC !!Li +#ifdef W3_SMC + !!Li Reshape the RH0/N space for sea-point only current. + !!Li JGLi26Jun2018. + ELSE IF( FSWND ) THEN + CALL W3FLDG ('READ', IDSTR(J), NDSF(J), NDST, & + NDSEN, NSEA, 1, NSEA, 1, TIME0, TIMEN, TR0, & + XXX, XXX, RH0, TRN, XXX, XXX, RHN, IERR) + !!Li +#endif ELSE -!/OASIS COUPL_COMM = MPI_COMM -!/OASACM IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#ifdef W3_OASIS + COUPL_COMM = MPI_COMM +#endif +#ifdef W3_OASACM + IF (.NOT.FLAGSC(J)) ID_OASIS_TIME = -1 +#endif CALL W3FLDG ('READ', IDSTR(J), NDSF(J), & NDST, NDSEN, NX, NY, NX, NY, TIME0, TIMEN, & TR0, XXX, XXX, RH0, TRN, XXX, XXX, RHN, & IERR, FLAGSC(J) & -!/OASASCM , COUPL_COMM & +#ifdef W3_OASASCM + , COUPL_COMM & +#endif ) IF ( IERR .LT. 0 ) FLLSTR = .TRUE. END IF @@ -2353,9 +2729,11 @@ PROGRAM W3SHEL ! update the next assimilation data time ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 8' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 8' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif TDN = TTIME CALL TICK21 ( TDN, 1. ) @@ -2367,25 +2745,27 @@ PROGRAM W3SHEL END IF END DO ! -!/T WRITE (NDST,9072) '0-N', TIME0, TTIME, & -!/T IDSTR(-7), INFLAGS1(-7), TI1, & -!/T IDSTR(-6), INFLAGS1(-6), TI2, & -!/T IDSTR(-5), INFLAGS1(-5), TI3, & -!/T IDSTR(-4), INFLAGS1(-4), TI4, & -!/T IDSTR(-3), INFLAGS1(-3), TI5, & -!/T IDSTR(-2), INFLAGS1(-2), TZN, & -!/T IDSTR(-1), INFLAGS1(-1), TTN, & -!/T IDSTR(0), INFLAGS1(0), TVN, & -!/T IDSTR(1), INFLAGS1(1), TLN, & -!/T IDSTR(2), INFLAGS1(2), TC0, TCN, & -!/T IDSTR(3), INFLAGS1(3), TW0, TWN, & -!/T IDSTR(4), INFLAGS1(4), TIN, & -!/T IDSTR(5), INFLAGS1(5), TU0, TUN, & -!/T IDSTR(6), INFLAGS1(6), TR0, TRN, & -!/T IDSTR(7), INFLAGS1(7), T0N, & -!/T IDSTR(8), INFLAGS1(8), T1N, & -!/T IDSTR(9), INFLAGS1(9), T2N, TDN, & -!/T IDSTR(10), INFLAGS1(10), TG0, TGN +#ifdef W3_T + WRITE (NDST,9072) '0-N', TIME0, TTIME, & + IDSTR(-7), INFLAGS1(-7), TI1, & + IDSTR(-6), INFLAGS1(-6), TI2, & + IDSTR(-5), INFLAGS1(-5), TI3, & + IDSTR(-4), INFLAGS1(-4), TI4, & + IDSTR(-3), INFLAGS1(-3), TI5, & + IDSTR(-2), INFLAGS1(-2), TZN, & + IDSTR(-1), INFLAGS1(-1), TTN, & + IDSTR(0), INFLAGS1(0), TVN, & + IDSTR(1), INFLAGS1(1), TLN, & + IDSTR(2), INFLAGS1(2), TC0, TCN, & + IDSTR(3), INFLAGS1(3), TW0, TWN, & + IDSTR(4), INFLAGS1(4), TIN, & + IDSTR(5), INFLAGS1(5), TU0, TUN, & + IDSTR(6), INFLAGS1(6), TR0, TRN, & + IDSTR(7), INFLAGS1(7), T0N, & + IDSTR(8), INFLAGS1(8), T1N, & + IDSTR(9), INFLAGS1(9), T2N, TDN, & + IDSTR(10), INFLAGS1(10), TG0, TGN +#endif ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' ! @@ -2394,12 +2774,16 @@ PROGRAM W3SHEL TIME0 = TTIME ! CALL W3WAVE ( 1, ODAT, TIME0 & -!/OASIS , .TRUE., .FALSE., MPI_COMM, TIMEN & +#ifdef W3_OASIS + , .TRUE., .FALSE., MPI_COMM, TIMEN & +#endif ) -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 9' -!/MEMCHECK call getMallocInfo(mallinfos) -!/MEMCHECK call printMallInfo(IAPROC,mallInfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 9' + call getMallocInfo(mallinfos) + call printMallInfo(IAPROC,mallInfos) +#endif ! ! The following lines prevents us from trying to read past the end ! of the files. This feature existed in v3.14. @@ -2438,15 +2822,19 @@ PROGRAM W3SHEL IF ( DTTST .EQ. 0. ) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,*) ' ' CALL W3WAVE ( 1, ODAT, TIME0 & -!/OASIS , .TRUE., .FALSE., MPI_COMM, TIMEN & +#ifdef W3_OASIS + , .TRUE., .FALSE., MPI_COMM, TIMEN & +#endif ) END IF END IF ! ! 7.e Check times ! -!/MEMCHECK write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 10' -!/MEMCHECK call getMallocInfo(mallinfos) +#ifdef W3_MEMCHECK + write(740+IAPROC,*) 'memcheck_____:', 'WW3_SHEL SECTION 10' + call getMallocInfo(mallinfos) +#endif DTTST = DSEC21 ( TIME0 , TIMEN ) @@ -2507,16 +2895,20 @@ PROGRAM W3SHEL IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) IERR CALL EXTCDE ( 1008 ) ! -!/COU 2009 CONTINUE -!/COU IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1009) ODAT(33), NINT(DTMAX) -!/COU CALL EXTCDE ( 1009 ) +#ifdef W3_COU + 2009 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1009) ODAT(33), NINT(DTMAX) + CALL EXTCDE ( 1009 ) +#endif ! 2054 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1054) CALL EXTCDE ( 1054 ) 2222 CONTINUE ! -!/MPI CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#ifdef W3_MPI + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) +#endif ! IF ( IAPROC .EQ. NAPOUT ) THEN CALL DATE_AND_TIME ( VALUES=CLKDT3 ) @@ -2531,12 +2923,20 @@ PROGRAM W3SHEL WRITE (NDSO,999) END IF ! -!/NCO/! IF ( IAPROC .EQ. 1 ) CALL W3TAGE('WAVEFCST') -!/OASIS IF (OASISED.EQ.1) THEN -!/OASIS CALL CPL_OASIS_FINALIZE -!/OASIS ELSE -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) -!/OASIS END IF +#ifdef W3_NCO +! IF ( IAPROC .EQ. 1 ) CALL W3TAGE('WAVEFCST') +#endif +#ifdef W3_OASIS + IF (OASISED.EQ.1) THEN + CALL CPL_OASIS_FINALIZE + ELSE +#endif +#ifdef W3_MPI + CALL MPI_FINALIZE ( IERR_MPI ) +#endif +#ifdef W3_OASIS + END IF +#endif ! ! ! Formats @@ -2545,9 +2945,11 @@ PROGRAM W3SHEL 15X,'==============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) ! -!/OMPH 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & -!/OMPH ' Requested: ', I2/ & -!/OMPH ' Provided: ', I2/ ) +#ifdef W3_OMPH + 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & + ' Requested: ', I2/ & + ' Provided: ', I2/ ) +#endif 920 FORMAT (/' Input fields : '/ & ' --------------------------------------------------') 921 FORMAT ( ' ',A,2X,A,2X,A) @@ -2583,8 +2985,10 @@ PROGRAM W3SHEL 950 FORMAT (/' Initializations :'/ & ' --------------------------------------------------') 951 FORMAT ( ' ',A) -!/O7 952 FORMAT ( ' ',I6,2X,A) -!/O7 953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) +#ifdef W3_O7 + 952 FORMAT ( ' ',I6,2X,A) + 953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) +#endif 954 FORMAT ( ' ',A,': file not needed') 955 FORMAT ( ' ',A,': file OK') 956 FORMAT ( ' ',A,': file OK, recl =',I3, & @@ -2598,7 +3002,9 @@ PROGRAM W3SHEL 971 FORMAT (/' Updating input at ',A) 972 FORMAT ( ' Updating ',A) 973 FORMAT ( ' Past last ',A) -!/TIDE 974 FORMAT ( ' Updating ',A,'using tidal constituents') +#ifdef W3_TIDE + 974 FORMAT ( ' Updating ',A,'using tidal constituents') +#endif 975 FORMAT (/' Data assimmilation at ',A) ! 997 FORMAT (/' Initialization time :',F10.2,' s') @@ -2650,68 +3056,80 @@ PROGRAM W3SHEL ' ERROR IN OPENING OUTPUT FILE'/ & ' IOSTAT =',I5/) ! -!/COU 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & -!/COU ' COUPLING TIME STEP NOT MULTIPLE OF'/ & -!/COU ' MODEL TIME STEP: ',I6, I6/) +#ifdef W3_COU + 1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT MULTIPLE OF'/ & + ' MODEL TIME STEP: ',I6, I6/) +#endif ! -!/COU 1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & -!/COU ' COUPLING TIME STEP NOT DEFINED, '/ & -!/COU ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & -!/COU ' FROM ',I6, ' TO ',I6/) +#ifdef W3_COU + 1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT DEFINED, '/ & + ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & + ' FROM ',I6, ' TO ',I6/) +#endif ! 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) ! ! -!/T 9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) -!/T 9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) -! -!/T 9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) -! -!/T 9040 FORMAT ( ' TEST W3SHEL : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & -!/T 4(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) -!/T 9041 FORMAT ( ' TEST W3SHEL : FLGRD : ',20L2) -!/T 9042 FORMAT ( ' TEST W3SHEL : IPR, PRFRM : ',6I6,1X,L1) -! -!/T 9070 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)) -!/T 9071 FORMAT ( ' TEST W3SHEL : ',A,', DTTST = ',E10.3) -!/T 9072 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,(I10.8,I7.6)/ & -!/T ' ',A,L3,17X,2(I10.8,I7.6)/ & -!/T ' ',A,L3,2(I10.8,I7.6)) +#ifdef W3_T + 9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) + 9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) +#endif +! +#ifdef W3_T + 9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) +#endif +! +#ifdef W3_T + 9040 FORMAT ( ' TEST W3SHEL : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 4(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) + 9041 FORMAT ( ' TEST W3SHEL : FLGRD : ',20L2) + 9042 FORMAT ( ' TEST W3SHEL : IPR, PRFRM : ',6I6,1X,L1) +#endif +! +#ifdef W3_T + 9070 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)) + 9071 FORMAT ( ' TEST W3SHEL : ',A,', DTTST = ',E10.3) + 9072 FORMAT ( ' TEST W3SHEL : ',A,3X,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,(I10.8,I7.6)/ & + ' ',A,L3,17X,2(I10.8,I7.6)/ & + ' ',A,L3,2(I10.8,I7.6)) +#endif !/ !/ End of W3SHEL ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_strt.ftn b/model/src/ww3_strt.F90 similarity index 80% rename from model/ftn/ww3_strt.ftn rename to model/src/ww3_strt.F90 index c2471c1bd..6da024019 100644 --- a/model/ftn/ww3_strt.ftn +++ b/model/src/ww3_strt.F90 @@ -177,13 +177,23 @@ PROGRAM W3STRT !/ ! USE W3GDATMD, ONLY: W3NMOD, W3SETG ! USE W3WDATMD, ONLY: W3NDAT, W3SETW, W3DIMW -!/NL1 USE W3ADATMD, ONLY: W3NAUX, W3SETA +#ifdef W3_NL1 + USE W3ADATMD, ONLY: W3NAUX, W3SETA +#endif USE W3ODATMD, ONLY: W3NOUT, W3SETO, FLOGRR USE W3SERVMD, ONLY: ITRACE, NEXTLN, EJ5P, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE -!/O4 USE W3ARRYMD, ONLY : PRT1DS -!/O5 USE W3ARRYMD, ONLY : PRT2DS -!/O6 USE W3ARRYMD, ONLY : PRTBLK +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif +#ifdef W3_O4 + USE W3ARRYMD, ONLY : PRT1DS +#endif +#ifdef W3_O5 + USE W3ARRYMD, ONLY : PRT2DS +#endif +#ifdef W3_O6 + USE W3ARRYMD, ONLY : PRTBLK +#endif USE W3DISPMD, ONLY : WAVNU1 USE W3IOGRMD, ONLY: W3IOGR USE W3IORSMD, ONLY: W3IORS @@ -193,11 +203,15 @@ PROGRAM W3STRT USE W3WDATMD USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NAPROC, IAPROC, & NAPOUT, NAPERR, FNMPRE -!/WRST USE W3IDATMD, ONLY: W3NINP +#ifdef W3_WRST + USE W3IDATMD, ONLY: W3NINP +#endif !/ IMPLICIT NONE ! -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -205,20 +219,32 @@ PROGRAM W3STRT INTEGER :: NDSI, NDSM, NDSR, NDSTRC, NTRACE, & NDSEN, IERR, ITYPE, NCOS, IKM, IK, & ITHM, ITH, JSEA, ISEA, IX, IY, J -!/MPI INTEGER :: IERR_MPI -!/S INTEGER, SAVE :: IENT = 0 -!/O6 INTEGER :: NSX, NSY -!/O6 INTEGER, ALLOCATABLE :: MAPO(:,:) +#ifdef W3_MPI + INTEGER :: IERR_MPI +#endif +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif +#ifdef W3_O6 + INTEGER :: NSX, NSY + INTEGER, ALLOCATABLE :: MAPO(:,:) +#endif REAL :: FP, SIP, THM, XM, SIX, YM, SIY, HMAX,& CHSIP, FRREL, ETOT, E1I, FACTOR, X, & Y, RDSQR, ALFA, GAMMA, SIGA, SIGB, & YLN, FR, BETA, FRR, S, SUMD, ANG, & ARG, FACS, DEPTH, WN, CG, HPQMAX REAL, ALLOCATABLE :: E1(:), DD(:), E2(:,:), E21(:), FINP(:,:) -!/O5 REAL, ALLOCATABLE :: E2OUT(:,:) -!/O6 REAL, ALLOCATABLE :: HSIG(:,:) +#ifdef W3_O5 + REAL, ALLOCATABLE :: E2OUT(:,:) +#endif +#ifdef W3_O6 + REAL, ALLOCATABLE :: HSIG(:,:) +#endif CHARACTER :: COMSTR*1, INXOUT*4 -!/EXPORTWWM INTEGER :: ISPEC +#ifdef W3_EXPORTWWM + INTEGER :: ISPEC +#endif LOGICAL :: FLONE,NOSIX !/ !/ ------------------------------------------------------------------- / @@ -229,11 +255,15 @@ PROGRAM W3STRT CALL W3SETG ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) CALL W3SETW ( 1, 6, 6 ) -!/NL1 CALL W3NAUX ( 6, 6 ) -!/NL1 CALL W3SETA ( 1, 6, 6 ) +#ifdef W3_NL1 + CALL W3NAUX ( 6, 6 ) + CALL W3SETA ( 1, 6, 6 ) +#endif CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) -!/WRST CALL W3NINP( 6, 6 ) +#ifdef W3_WRST + CALL W3NINP( 6, 6 ) +#endif ! ! 1.b IO set-up. ! @@ -247,17 +277,23 @@ PROGRAM W3STRT NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE (IENT, 'W3STRT') +#ifdef W3_S + CALL STRACE (IENT, 'W3STRT') +#endif ! ! 1.c MPP initializations ! -!/SHRD NAPROC = 1 -!/SHRD IAPROC = 1 +#ifdef W3_SHRD + NAPROC = 1 + IAPROC = 1 +#endif ! -!/MPI CALL MPI_INIT ( IERR_MPI ) -!/MPI CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) -!/MPI CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) -!/MPI IAPROC = IAPROC + 1 +#ifdef W3_MPI + CALL MPI_INIT ( IERR_MPI ) + CALL MPI_COMM_SIZE ( MPI_COMM_WORLD, NAPROC, IERR_MPI ) + CALL MPI_COMM_RANK ( MPI_COMM_WORLD, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 +#endif ! IF ( IAPROC .EQ. NAPERR ) THEN NDSEN = NDSE @@ -285,10 +321,14 @@ PROGRAM W3STRT ! ! 2.b MPP initializations ! -!/SHRD NSEAL = NSEA +#ifdef W3_SHRD + NSEAL = NSEA +#endif ! -!/DIST NSEAL = 1 + (NSEA-IAPROC)/NAPROC -!/DIST IF ( NSEA .LT. NAPROC ) GOTO 803 +#ifdef W3_DIST + NSEAL = 1 + (NSEA-IAPROC)/NAPROC + IF ( NSEA .LT. NAPROC ) GOTO 803 +#endif ! CALL W3DIMW ( 1, NDSE, NDST ) ALLOCATE ( E1(NK), DD(NTH), E2(NTH,NK), E21(NSPEC), & @@ -336,8 +376,12 @@ PROGRAM W3STRT HPQMAX=-999.0 DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF(HPFAC(IY,IX).GT.HPQMAX)THEN @@ -348,8 +392,12 @@ PROGRAM W3STRT HPQMAX=-999.0 DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF(HQFAC(IY,IX).GT.HPQMAX)THEN @@ -402,9 +450,11 @@ PROGRAM W3STRT END IF END DO ! -!/O4 IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & -!/O4 (NDSO, NK, E1, SIG(1:), ' ', 10, 0., & -!/O4 'Unscaled 1-D', ' ', 'TEST E(f)') +#ifdef W3_O4 + IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & + (NDSO, NK, E1, SIG(1:), ' ', 10, 0., & + 'Unscaled 1-D', ' ', 'TEST E(f)') +#endif ! ! 4.c Make directional distribution. ! @@ -438,17 +488,21 @@ PROGRAM W3STRT ! E2 = FACTOR * E2 ! -!/O5 ALLOCATE ( E2OUT(NK,NTH) ) -!/O5 DO ITH=1, NTH -!/O5 DO IK=1, NK -!/O5 E2OUT(IK,ITH) = TPI * E2(ITH,IK) -!/O5 END DO -!/O5 END DO +#ifdef W3_O5 + ALLOCATE ( E2OUT(NK,NTH) ) + DO ITH=1, NTH + DO IK=1, NK + E2OUT(IK,ITH) = TPI * E2(ITH,IK) + END DO + END DO +#endif ! -!/O5 IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & -!/O5 ( NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', DERA*TPI, & -!/O5 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') -!/O5 DEALLOCATE ( E2OUT ) +#ifdef W3_O5 + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + ( NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', DERA*TPI, & + 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') + DEALLOCATE ( E2OUT ) +#endif ! ! 4.e Distribute over grid. ! @@ -459,8 +513,12 @@ PROGRAM W3STRT ! DO JSEA=1, NSEAL ! -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IF (GTYPE .EQ. UNGTYPE) THEN IX = MAPSF(ISEA,1) X = XYB(IX,1) @@ -482,11 +540,15 @@ PROGRAM W3STRT FACTOR = EXP ( -0.5 * RDSQR ) END IF ! -!/EXPORTWWM FACTOR = 1. +#ifdef W3_EXPORTWWM + FACTOR = 1. +#endif VA(:,JSEA) = FACTOR * E21 -!/DEBUGINIT WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' FACTOR=', FACTOR -!/DEBUGINIT WRITE(740+IAPROC,*) ' sum(E21)=', sum(E21) -!/DEBUGINIT WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,JSEA)) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'JSEA=', JSEA, ' FACTOR=', FACTOR + WRITE(740+IAPROC,*) ' sum(E21)=', sum(E21) + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,JSEA)) +#endif ! ! @@ -519,8 +581,12 @@ PROGRAM W3STRT HPQMAX=-999.0 DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF(HPFAC(IY,IX).GT.HPQMAX)THEN @@ -531,8 +597,12 @@ PROGRAM W3STRT HPQMAX=-999.0 DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) IF(HQFAC(IY,IX).GT.HPQMAX)THEN @@ -572,9 +642,11 @@ PROGRAM W3STRT E1(IK) = EJ5P (FR, ALFA, FP, YLN, SIGA, SIGB ) END DO ! -!/O4 IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & -!/O4 (NDSO, NK, E1, SIG(1:), ' ', 18, 0., & -!/O4 'E(f)', ' ', 'TEST 1-D') +#ifdef W3_O4 + IF ( IAPROC .EQ. NAPOUT ) CALL PRT1DS & + (NDSO, NK, E1, SIG(1:), ' ', 18, 0., & + 'E(f)', ' ', 'TEST 1-D') +#endif ! ! 5.c 2-D energy spectrum. ! Factor 2pi to go to E(sigma,theta) @@ -604,17 +676,21 @@ PROGRAM W3STRT END DO END DO ! -!/O5 ALLOCATE ( E2OUT(NK,NTH) ) -!/O5 DO ITH=1, NTH -!/O5 DO IK=1, NK -!/O5 E2OUT(IK,ITH) = TPI * E2(ITH,IK) -!/O5 END DO -!/O5 END DO +#ifdef W3_O5 + ALLOCATE ( E2OUT(NK,NTH) ) + DO ITH=1, NTH + DO IK=1, NK + E2OUT(IK,ITH) = TPI * E2(ITH,IK) + END DO + END DO +#endif ! -!/O5 IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & -!/O5 (NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', 1., & -!/O5 0., 0.0001, 'E(f,theta)', 'm2s', 'TEST 2-D') -!/O5 DEALLOCATE ( E2OUT ) +#ifdef W3_O5 + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + (NDSO, NK, NK, NTH, E2OUT, SIG(1:), ' ', 1., & + 0., 0.0001, 'E(f,theta)', 'm2s', 'TEST 2-D') + DEALLOCATE ( E2OUT ) +#endif ! ! 5.d Distribute over grid. ! @@ -626,8 +702,12 @@ PROGRAM W3STRT ! DO JSEA=1, NSEAL ! -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif IF (GTYPE .EQ. UNGTYPE) THEN IX = MAPSF(ISEA,1) X = XYB(IX,1) @@ -681,16 +761,22 @@ PROGRAM W3STRT ! FINP = FINP * FACS / TPI ! -!/O5 IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & -!/O5 (NDSO, NK, NK, NTH, FINP, SIG(1:), ' ', TPI, & -!/O5 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') +#ifdef W3_O5 + IF ( IAPROC .EQ. NAPOUT ) CALL PRT2DS & + (NDSO, NK, NK, NTH, FINP, SIG(1:), ' ', TPI, & + 0., 0.0001, 'Energy', 'm2s', 'TEST 2-D') +#endif ! ! 7.c Distribute over grid. ! DO JSEA=1, NSEAL ! -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif DO IK=1, NK DO ITH=1, NTH VA(ITH+(IK-1)*NTH,JSEA) = FINP(IK,ITH) @@ -710,60 +796,96 @@ PROGRAM W3STRT !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 9. Convert E(sigma) to N(k) ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'ITYPE=', ITYPE +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'ITYPE=', ITYPE +#endif IF ( ITYPE.NE.3 .AND. ITYPE.NE.5 ) THEN IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,990) ! -!/O6 ALLOCATE ( HSIG(NX,NY) ) -!/O6 HSIG = 0. +#ifdef W3_O6 + ALLOCATE ( HSIG(NX,NY) ) + HSIG = 0. +#endif ! -!/DEBUGINIT WRITE(740+IAPROC,*) 'Doing rescaling operation' +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Doing rescaling operation' +#endif DO JSEA=1, NSEAL -!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC -!/SHRD ISEA = JSEA -!/DEBUGINIT WRITE(740+IAPROC,*) ' rescal ISEA=', ISEA, ' JSEA=', JSEA +#ifdef W3_DIST + ISEA = IAPROC + (JSEA-1)*NAPROC +#endif +#ifdef W3_SHRD + ISEA = JSEA +#endif +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) ' rescal ISEA=', ISEA, ' JSEA=', JSEA +#endif DEPTH = MAX ( DMIN , -ZB(ISEA) ) -!/O6 ETOT = 0. +#ifdef W3_O6 + ETOT = 0. +#endif DO IK=1, NK CALL WAVNU1 ( SIG(IK), DEPTH, WN, CG ) -!/O6 E1I = 0. +#ifdef W3_O6 + E1I = 0. +#endif DO ITH=1, NTH -!/O6 E1I = E1I + VA(ITH+(IK-1)*NTH,JSEA) +#ifdef W3_O6 + E1I = E1I + VA(ITH+(IK-1)*NTH,JSEA) +#endif VA(ITH+(IK-1)*NTH,JSEA) = VA(ITH+(IK-1)*NTH,JSEA) * & CG / SIG(IK) END DO -!/O6 ETOT = ETOT + E1I*DSIP(IK) +#ifdef W3_O6 + ETOT = ETOT + E1I*DSIP(IK) +#endif END DO -!/O6 IX = MAPSF(ISEA,1) -!/O6 IY = MAPSF(ISEA,2) -!/O6 HSIG(IX,IY) = 4. * SQRT ( ETOT * DTH ) -!/EXPORTWWM IF (JSEA .eq. 1) THEN -!/EXPORTWWM DO ITH=1,NTH -!/EXPORTWWM DO IK=1,NK -!/EXPORTWWM ISPEC = ITH + NTH * (IK-1) -!/EXPORTWWM WRITE(10003) ITH, IK, VA(ISPEC,JSEA) -!/EXPORTWWM END DO -!/EXPORTWWM END DO -!/EXPORTWWM WRITE(740+IAPROC,*) 'FINAL : sum(VA)=', sum(VA(:,JSEA)) -!/EXPORTWWM END IF +#ifdef W3_O6 + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + HSIG(IX,IY) = 4. * SQRT ( ETOT * DTH ) +#endif +#ifdef W3_EXPORTWWM + IF (JSEA .eq. 1) THEN + DO ITH=1,NTH + DO IK=1,NK + ISPEC = ITH + NTH * (IK-1) + WRITE(10003) ITH, IK, VA(ISPEC,JSEA) + END DO + END DO + WRITE(740+IAPROC,*) 'FINAL : sum(VA)=', sum(VA(:,JSEA)) + END IF +#endif END DO ! -!/O6 ALLOCATE ( MAPO(NX,NY) ) -!/O6 DO IX=1, NX -!/O6 DO IY=1, NY -!/O6 MAPO(IX,IY) = MAPSTA(IY,IX) -!/O6 END DO -!/O6 END DO -! -!/MPI IF ( NAPROC .EQ. 1 ) THEN -!/O6 NSX = 1 + NX/35 -!/O6 NSY = 1 + NY/35 -!/O6!/DEBUGINIT Print *, 'Before call to PRTBLK' -!/O6 IF ( IAPROC .EQ. NAPOUT ) CALL PRTBLK & -!/O6 (NDSO, NX, NY, NX, HSIG, MAPO, 0, 0., & -!/O6 1, NX, NSX, 1, NY, NSY, 'Hs', 'm') -!/O6!/DEBUGINIT Print *, 'After call to PRTBLK' -!/MPI END IF +#ifdef W3_O6 + ALLOCATE ( MAPO(NX,NY) ) + DO IX=1, NX + DO IY=1, NY + MAPO(IX,IY) = MAPSTA(IY,IX) + END DO + END DO +#endif +! +#ifdef W3_MPI + IF ( NAPROC .EQ. 1 ) THEN +#endif +#ifdef W3_O6 + NSX = 1 + NX/35 + NSY = 1 + NY/35 +#ifdef W3_DEBUGINIT + Print *, 'Before call to PRTBLK' +#endif + IF ( IAPROC .EQ. NAPOUT ) CALL PRTBLK & + (NDSO, NX, NY, NX, HSIG, MAPO, 0, 0., & + 1, NX, NSX, 1, NY, NSY, 'Hs', 'm') +#ifdef W3_DEBUGINIT + Print *, 'After call to PRTBLK' +#endif +#endif +#ifdef W3_MPI + END IF +#endif ! END IF ! @@ -771,16 +893,20 @@ PROGRAM W3STRT !10. Write restart file. ! IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,995) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before call to W3IORS' -!/DEBUGINIT WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before call to W3IORS' + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + FLUSH(740+IAPROC) +#endif CALL W3IORS ( INXOUT, NDSR, SIG(NK) ) -!/DEBUGINIT WRITE(740+IAPROC,*) 'Before call to W3IORS' -!/DEBUGINIT WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) -!/DEBUGINIT DO ISEA=1,NSEA -!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VA)=', sum(VA(:,ISEA)) -!/DEBUGINIT END DO -!/DEBUGINIT FLUSH(740+IAPROC) +#ifdef W3_DEBUGINIT + WRITE(740+IAPROC,*) 'Before call to W3IORS' + WRITE(740+IAPROC,*) 'min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + DO ISEA=1,NSEA + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VA)=', sum(VA(:,ISEA)) + END DO + FLUSH(740+IAPROC) +#endif ! GOTO 888 ! @@ -798,13 +924,17 @@ PROGRAM W3STRT IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR CALL EXTCDE ( 12 ) ! -!/DIST 803 CONTINUE -!/DIST IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) NSEA, NAPROC -!/DIST CALL EXTCDE ( 13 ) +#ifdef W3_DIST + 803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) NSEA, NAPROC + CALL EXTCDE ( 13 ) +#endif ! 888 CONTINUE IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,999) -!/MPI CALL MPI_FINALIZE ( IERR_MPI ) +#ifdef W3_MPI + CALL MPI_FINALIZE ( IERR_MPI ) +#endif ! ! Formats ! @@ -883,9 +1013,11 @@ PROGRAM W3STRT 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & ' ILLEGAL TYPE, ITYPE =',I4/) ! -!/DIST 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & -!/DIST ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & -!/DIST ' NSEA, NAPROC =',2I8/) +#ifdef W3_DIST + 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3STRT : '/ & + ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSEA, NAPROC =',2I8/) +#endif !/ !/ End of W3STRT ----------------------------------------------------- / !/ diff --git a/model/ftn/ww3_systrk.ftn b/model/src/ww3_systrk.F90 similarity index 60% rename from model/ftn/ww3_systrk.ftn rename to model/src/ww3_systrk.F90 index 4cc47285e..4e19bb144 100644 --- a/model/ftn/ww3_systrk.ftn +++ b/model/src/ww3_systrk.F90 @@ -32,8 +32,10 @@ PROGRAM WW3_SYSTRK USE W3STRKMD USE W3TIMEMD, ONLY: TDIFF IMPLICIT NONE -!/MPI -!/MPI INCLUDE "mpif.h" +#ifdef W3_MPI + + INCLUDE "mpif.h" +#endif ! ! 1. Purpose : ! @@ -75,12 +77,14 @@ PROGRAM WW3_SYSTRK INTEGER :: it, igrp, sysmatch, ind, ip INTEGER :: i, j, leng, ulimGroup REAL, ALLOCATABLE :: dum(:,:) -!/TRKNC REAL, ALLOCATABLE :: dum2nc(:,:,:,:) -!/TRKNC REAL, ALLOCATABLE :: hsprt_nc(:,:,:) -!/TRKNC REAL, ALLOCATABLE :: tpprt_nc(:,:,:) -!/TRKNC REAL, ALLOCATABLE :: dirprt_nc(:,:,:) -!/TRKNC REAL, ALLOCATABLE :: longitude_nc(:),latitude_nc(:) -!/TRKNC REAL, ALLOCATABLE :: lonprt_nc(:),latprt_nc(:) +#ifdef W3_TRKNC + REAL, ALLOCATABLE :: dum2nc(:,:,:,:) + REAL, ALLOCATABLE :: hsprt_nc(:,:,:) + REAL, ALLOCATABLE :: tpprt_nc(:,:,:) + REAL, ALLOCATABLE :: dirprt_nc(:,:,:) + REAL, ALLOCATABLE :: longitude_nc(:),latitude_nc(:) + REAL, ALLOCATABLE :: lonprt_nc(:),latprt_nc(:) +#endif INTEGER NTIME_NC INTEGER :: outputType LOGICAL :: outputCheck1 @@ -89,8 +93,10 @@ PROGRAM WW3_SYSTRK REAL :: dt REAL :: minlon, maxlon, minlat, maxlat INTEGER :: mxcwt, mycwt -!/MPI INTEGER :: rank, nproc, ierr -!/MPI CHARACTER :: rankstr*4 +#ifdef W3_MPI + INTEGER :: rank, nproc, ierr + CHARACTER :: rankstr*4 +#endif ! For point output (bilinear interpolation) REAL :: hsprt(10),tpprt(10),dirprt(10) @@ -131,21 +137,31 @@ PROGRAM WW3_SYSTRK ! !/ ------------------------------------------------------------------- / ! -!/MPI/! Start of parallel region -!/MPI CALL MPI_INIT(ierr) -!/MPI -!/MPI CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) -!/MPI CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) -!/MPI +#ifdef W3_MPI +! Start of parallel region + CALL MPI_INIT(ierr) + + CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc, ierr) + +#endif ! Open log file -!/MPI WRITE(rankstr,'(i4.4)') rank -!/MPI OPEN(unit=20,file='sys_log'//rankstr//'.ww3',status='unknown') -!/SHRD OPEN(unit=20,file='sys_log.ww3',status='unknown') +#ifdef W3_MPI + WRITE(rankstr,'(i4.4)') rank + OPEN(unit=20,file='sys_log'//rankstr//'.ww3',status='unknown') +#endif +#ifdef W3_SHRD + OPEN(unit=20,file='sys_log.ww3',status='unknown') +#endif ! Print code version -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif WRITE(6,900) -!/MPI END IF +#ifdef W3_MPI + END IF +#endif WRITE(20,900) 900 FORMAT (/15X,' *** WAVEWATCH III Wave system tracking *** '/ & 15X,'==============================================='/) @@ -160,7 +176,9 @@ PROGRAM WW3_SYSTRK tcur = 0 ! Read input parameter file -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif INQUIRE(FILE='ww3_systrk.inp', EXIST=file_exists) IF (.NOT.file_exists) THEN WRITE(20,2000) @@ -197,7 +215,9 @@ PROGRAM WW3_SYSTRK ELSEIF (outputType.EQ.3) THEN !NetCDF 3 - requrires !/TRKNC switch outputCheck1 = .TRUE. -!/TRKNC outputCheck1 = .FALSE. +#ifdef W3_TRKNC + outputCheck1 = .FALSE. +#endif IF(outputCheck1) THEN WRITE(6,993) STOP @@ -205,7 +225,9 @@ PROGRAM WW3_SYSTRK ELSEIF (outputType.EQ.4) THEN !NetCDF 4 - requrires !/TRKNC switch outputCheck1 = .TRUE. -!/TRKNC outputCheck1 = .FALSE. +#ifdef W3_TRKNC + outputCheck1 = .FALSE. +#endif IF(outputCheck1) THEN WRITE(6,994) STOP @@ -288,35 +310,41 @@ PROGRAM WW3_SYSTRK CALL DATE_AND_TIME ( VALUES=CLKDT0 ) -!/MPI END IF - -!/MPI/! MPI communication block -!/MPI CALL MPI_BCAST(filename,80,MPI_CHARACTER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(tstart,1,MPI_DOUBLE_PRECISION,0, & -!/MPI MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(tend,1,MPI_DOUBLE_PRECISION,0, & -!/MPI MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(dt,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(ntint,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(minlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(maxlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(minlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(maxlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(mxcwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(mycwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(dirKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(perKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(hsKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(wetPts,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(dirTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(tpTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(seedLon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(seedLat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(noutp,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(lonout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) -!/MPI CALL MPI_BCAST(latout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) - -!/MPI CALL MPI_Barrier(MPI_COMM_WORLD,IERR) +#ifdef W3_MPI + END IF +#endif + +#ifdef W3_MPI +! MPI communication block + CALL MPI_BCAST(filename,80,MPI_CHARACTER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tstart,1,MPI_DOUBLE_PRECISION,0, & + MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tend,1,MPI_DOUBLE_PRECISION,0, & + MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dt,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(ntint,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(minlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxlon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(minlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(maxlat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(mxcwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(mycwt,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dirKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(perKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(hsKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(wetPts,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(dirTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(tpTimeKnob,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(seedLon,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(seedLat,1,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(noutp,1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(lonout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(latout,100,MPI_REAL,0,MPI_COMM_WORLD,IERR) +#endif + +#ifdef W3_MPI + CALL MPI_Barrier(MPI_COMM_WORLD,IERR) +#endif CALL waveTracking_NWS_V2 (intype ,tmax , & tcur ,filename , & @@ -333,7 +361,9 @@ PROGRAM WW3_SYSTRK sysA ,wsdat , & maxSys ,maxGroup ) -!/MPI IF (rank.EQ.0) THEN +#ifdef W3_MPI + IF (rank.EQ.0) THEN +#endif CALL DATE_AND_TIME ( VALUES=CLKDT1 ) CLKFEL = TDIFF ( CLKDT0,CLKDT1 ) @@ -356,14 +386,18 @@ PROGRAM WW3_SYSTRK WRITE(21,'(I6,69X,A)') maxJ,'Number of rows' WRITE(21,'(I6,69X,A)') maxI,'Number of cols' -!/TRKNC ALLOCATE( longitude_nc(maxI) ) -!/TRKNC ALLOCATE( latitude_nc(maxJ) ) +#ifdef W3_TRKNC + ALLOCATE( longitude_nc(maxI) ) + ALLOCATE( latitude_nc(maxJ) ) +#endif WRITE(21,*) 'Longitude =' DO j = maxJ,1,-1 DO i = 1,maxI WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lon(i,j) -!/TRKNC longitude_nc(i)=wsdat(1)%lon(i,1) +#ifdef W3_TRKNC + longitude_nc(i)=wsdat(1)%lon(i,1) +#endif END DO WRITE(21,'(A)',ADVANCE='YES') '' END DO @@ -372,7 +406,9 @@ PROGRAM WW3_SYSTRK DO j = maxJ,1,-1 DO i = 1,maxI WRITE(21,'(F7.2)',ADVANCE='NO') wsdat(1)%lat(i,j) -!/TRKNC latitude_nc(j)=wsdat(1)%lat(1,j) +#ifdef W3_TRKNC + latitude_nc(j)=wsdat(1)%lat(1,j) +#endif END DO WRITE(21,'(A)',ADVANCE='YES') '' END DO @@ -389,9 +425,11 @@ PROGRAM WW3_SYSTRK NTIME_NC=SIZE(sysA) ALLOCATE( dum(maxI,maxJ) ) -!/TRKNC IF(outputType == 3 .OR. outputType == 4) THEN -!/TRKNC ALLOCATE( dum2nc(maxI,maxJ,maxGroup,NTIME_NC) ) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType == 3 .OR. outputType == 4) THEN + ALLOCATE( dum2nc(maxI,maxJ,maxGroup,NTIME_NC) ) + ENDIF +#endif DO it = 1,SIZE(sysA) ! Loop through identified groups, limiting the output in file to ulimGroup @@ -431,20 +469,24 @@ PROGRAM WW3_SYSTRK WRITE(22,'(A)',ADVANCE='YES') '' END DO ELSE -!/TRKNC DO J = maxJ,1,-1 -!/TRKNC DO i = 1,maxI -!/TRKNC dum2nc(i,j,igrp,it)=dum(i,j) -!/TRKNC END DO -!/TRKNC END DO +#ifdef W3_TRKNC + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) + END DO + END DO +#endif ENDIF END DO END DO -!/TRKNC IF(outputType == 3 .OR. outputType == 4 ) THEN -!/TRKNC call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& -!/TRKNC maxGroup,date1,date2,dt,NTIME_NC,1,outputType) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType == 3 .OR. outputType == 4 ) THEN + call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& + maxGroup,date1,date2,dt,NTIME_NC,1,outputType) + ENDIF +#endif IF(outputType.EQ.1) CLOSE(22) @@ -494,20 +536,24 @@ PROGRAM WW3_SYSTRK END DO ELSE -!/TRKNC DO J = maxJ,1,-1 -!/TRKNC DO i = 1,maxI -!/TRKNC dum2nc(i,j,igrp,it)=dum(i,j) -!/TRKNC END DO -!/TRKNC END DO +#ifdef W3_TRKNC + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) + END DO + END DO +#endif ENDIF END DO END DO -!/TRKNC IF(outputType.EQ.3 .OR. outputType.EQ. 4 ) THEN -!/TRKNC call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& -!/TRKNC maxGroup,date1,date2,dt,NTIME_NC,2,outputType) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType.EQ.3 .OR. outputType.EQ. 4 ) THEN + call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& + maxGroup,date1,date2,dt,NTIME_NC,2,outputType) + ENDIF +#endif IF(outputType.EQ.1) CLOSE(23) @@ -557,20 +603,24 @@ PROGRAM WW3_SYSTRK WRITE(24,'(A)',ADVANCE='YES') '' END DO ELSE -!/TRKNC DO J = maxJ,1,-1 -!/TRKNC DO i = 1,maxI -!/TRKNC dum2nc(i,j,igrp,it)=dum(i,j) -!/TRKNC END DO -!/TRKNC END DO +#ifdef W3_TRKNC + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) + END DO + END DO +#endif END IF END DO END DO -!/TRKNC IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN -!/TRKNC call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& -!/TRKNC maxGroup,date1,date2,dt,NTIME_NC,3,outputType) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN + call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& + maxGroup,date1,date2,dt,NTIME_NC,3,outputType) + ENDIF +#endif IF(outputType.EQ.1) CLOSE(24) !-----Final SYSTEM output: dspr @@ -618,32 +668,40 @@ PROGRAM WW3_SYSTRK WRITE(25,'(A)',ADVANCE='YES') '' END DO ELSE -!/TRKNC DO J = maxJ,1,-1 -!/TRKNC DO i = 1,maxI -!/TRKNC dum2nc(i,j,igrp,it)=dum(i,j) -!/TRKNC END DO -!/TRKNC END DO +#ifdef W3_TRKNC + DO J = maxJ,1,-1 + DO i = 1,maxI + dum2nc(i,j,igrp,it)=dum(i,j) + END DO + END DO +#endif ENDIF END DO END DO -!/TRKNC IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN -!/TRKNC call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& -!/TRKNC maxGroup,date1,date2,dt,NTIME_NC,4,outputType) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType.EQ.3 .OR. outputType.EQ.4 ) THEN + call t2netcdf(longitude_nc,latitude_nc,dum2nc,maxI,maxJ,& + maxGroup,date1,date2,dt,NTIME_NC,4,outputType) + ENDIF +#endif IF(outputType.EQ.1) CLOSE(25) IF (ALLOCATED(DUM)) DEALLOCATE(dum) -!/TRKNC IF (ALLOCATED(dum2nc)) DEALLOCATE(dum2nc) - -!/TRKNC IF(outputType.EQ.3.OR.outputType.EQ.4) THEN -!/TRKNC ALLOCATE( hsprt_nc(10,noutp,NTIME_NC) ) -!/TRKNC ALLOCATE( tpprt_nc(10,noutp,NTIME_NC) ) -!/TRKNC ALLOCATE( dirprt_nc(10,noutp,NTIME_NC) ) -!/TRKNC ALLOCATE( lonprt_nc(noutp) ) -!/TRKNC ALLOCATE( latprt_nc(noutp) ) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF (ALLOCATED(dum2nc)) DEALLOCATE(dum2nc) +#endif + +#ifdef W3_TRKNC + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + ALLOCATE( hsprt_nc(10,noutp,NTIME_NC) ) + ALLOCATE( tpprt_nc(10,noutp,NTIME_NC) ) + ALLOCATE( dirprt_nc(10,noutp,NTIME_NC) ) + ALLOCATE( lonprt_nc(noutp) ) + ALLOCATE( latprt_nc(noutp) ) + ENDIF +#endif !-----Final SYSTEM output: point output IF(outputType == 1) THEN @@ -837,22 +895,26 @@ PROGRAM WW3_SYSTRK WRITE(26,'(32F14.4)') lonprt,latprt, & hsprt(1:10),tpprt(1:10),dirprt(1:10) ENDIF -!/TRKNC IF(outputType.EQ.3.OR.outputType.EQ.4) THEN -!/TRKNC lonprt_nc(ip)=lonprt -!/TRKNC latprt_nc(ip)=latprt -!/TRKNC do igrp=1,10 -!/TRKNC hsprt_nc(igrp,ip,it)=hsprt(igrp) -!/TRKNC tpprt_nc(igrp,ip,it)=tpprt(igrp) -!/TRKNC dirprt_nc(igrp,ip,it)=dirprt(igrp) -!/TRKNC enddo -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + lonprt_nc(ip)=lonprt + latprt_nc(ip)=latprt + do igrp=1,10 + hsprt_nc(igrp,ip,it)=hsprt(igrp) + tpprt_nc(igrp,ip,it)=tpprt(igrp) + dirprt_nc(igrp,ip,it)=dirprt(igrp) + enddo + ENDIF +#endif END DO END DO -!/TRKNC IF(outputType.EQ.3.OR.outputType.EQ.4) THEN -!/TRKNC call pt2netcdf(lonprt_nc,latprt_nc,hsprt_nc,tpprt_nc, & -!/TRKNC dirprt_nc,noutp,date1,date2,dt,NTIME_NC,outputType) -!/TRKNC ENDIF +#ifdef W3_TRKNC + IF(outputType.EQ.3.OR.outputType.EQ.4) THEN + call pt2netcdf(lonprt_nc,latprt_nc,hsprt_nc,tpprt_nc, & + dirprt_nc,noutp,date1,date2,dt,NTIME_NC,outputType) + ENDIF +#endif IF(outputType.EQ.1) CLOSE(26) @@ -987,10 +1049,14 @@ PROGRAM WW3_SYSTRK WRITE(6,999) -!/MPI END IF !/IF (rank.EQ.0) +#ifdef W3_MPI + END IF !/IF (rank.EQ.0) +#endif -!/MPI CALL MPI_FINALIZE(IERR) -!/MPI/! End of parallel region +#ifdef W3_MPI + CALL MPI_FINALIZE(IERR) +! End of parallel region +#endif 998 FORMAT ( ' ... finished. Elapsed time : ',F10.2,' s') 993 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK : '/ & @@ -1011,342 +1077,378 @@ PROGRAM WW3_SYSTRK END PROGRAM WW3_SYSTRK ! -!/TRKNC subroutine t2netcdf(lons,lats,data_in,nlons,nlats,nsys,date1,date2,& -!/TRKNC dt,ntime,ivar, outputType) -!/TRKNC USE W3TIMEMD -!/TRKNC use netcdf -!/TRKNC implicit none -!/TRKNC character (len = 15) :: file_name -!/TRKNC integer, parameter :: ndims = 4 -!/TRKNC integer, parameter :: deflate = 1 -!/TRKNC integer :: outputType, ncid, oldMode -!/TRKNC integer :: nlons,nlats,nsys,rec,ntime,ivar -!/TRKNC double precision :: date1,date2,timenc -!/TRKNC real :: data_in(nlons, nlats, nsys,ntime) -!/TRKNC real :: lats(nlats), lons(nlons),dt -!/TRKNC double precision :: times(ntime) -!/TRKNC integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0 -!/TRKNC integer :: iret +#ifdef W3_TRKNC + subroutine t2netcdf(lons,lats,data_in,nlons,nlats,nsys,date1,date2,& + dt,ntime,ivar, outputType) + USE W3TIMEMD + use netcdf + implicit none + character (len = 15) :: file_name + integer, parameter :: ndims = 4 + integer, parameter :: deflate = 1 + integer :: outputType, ncid, oldMode + integer :: nlons,nlats,nsys,rec,ntime,ivar + double precision :: date1,date2,timenc + real :: data_in(nlons, nlats, nsys,ntime) + real :: lats(nlats), lons(nlons),dt + double precision :: times(ntime) + integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0 + integer :: iret +#endif ! -!/TRKNC integer :: lon_varid, lat_varid, rec_varid -!/TRKNC character (len = *), parameter :: lsys_name = "system_index" -!/TRKNC character (len = *), parameter :: lat_name = "latitude" -!/TRKNC character (len = *), parameter :: lon_name = "longitude" -!/TRKNC character (len = *), parameter :: time_name = "time" -!/TRKNC integer :: sys_dimid, lon_dimid, lat_dimid, rec_dimid -!/TRKNC integer :: start(ndims), count(ndims) +#ifdef W3_TRKNC + integer :: lon_varid, lat_varid, rec_varid + character (len = *), parameter :: lsys_name = "system_index" + character (len = *), parameter :: lat_name = "latitude" + character (len = *), parameter :: lon_name = "longitude" + character (len = *), parameter :: time_name = "time" + integer :: sys_dimid, lon_dimid, lat_dimid, rec_dimid + integer :: start(ndims), count(ndims) +#endif ! -!/TRKNC character (len = *), parameter :: var1_name="hs" -!/TRKNC character (len = *), parameter :: var2_name="tp" -!/TRKNC character (len = *), parameter :: var3_name="dir" -!/TRKNC character (len = *), parameter :: var4_name="dspr" -!/TRKNC integer :: var1_varid, var2_varid, var3_varid,var4_varid -!/TRKNC integer :: dimids(ndims) +#ifdef W3_TRKNC + character (len = *), parameter :: var1_name="hs" + character (len = *), parameter :: var2_name="tp" + character (len = *), parameter :: var3_name="dir" + character (len = *), parameter :: var4_name="dspr" + integer :: var1_varid, var2_varid, var3_varid,var4_varid + integer :: dimids(ndims) +#endif ! -!/TRKNC character (len = *), parameter :: units = "units" -!/TRKNC character (len = *), parameter :: var1_units = "m" -!/TRKNC character (len = *), parameter :: var2_units = "s" -!/TRKNC character (len = *), parameter :: var3_units = "degrees" -!/TRKNC character (len = *), parameter :: var4_units = "degrees" -!/TRKNC character (len = *), parameter :: lat_units = "degrees_north" -!/TRKNC character (len = *), parameter :: lon_units = "degrees_east" -!/TRKNC iyc=date1/10000 -!/TRKNC imc=(date1-iyc*10000)/100 -!/TRKNC idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) -!/TRKNC ihc=date2/10000 -!/TRKNC iminc=(date2-ihc*10000)/100 -!/TRKNC isc=date2-ihc*10000-100*iminc -!/TRKNC timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & -!/TRKNC (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 -!/TRKNC Jday0=julday(1,1,1990) -!/TRKNC timenc=timenc-Jday0 -!/TRKNC do rec=1,ntime -!/TRKNC times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 -!/TRKNC enddo -!/TRKNC if( ivar == 1) then -!/TRKNC file_name = "sys_hs.ww3.nc" -!/TRKNC else if( ivar == 2) then -!/TRKNC file_name = "sys_tp.ww3.nc" -!/TRKNC else if( ivar == 3) then -!/TRKNC file_name = "sys_dir.ww3.nc" -!/TRKNC else -!/TRKNC file_name = "sys_dspr.ww3.nc" -!/TRKNC endif +#ifdef W3_TRKNC + character (len = *), parameter :: units = "units" + character (len = *), parameter :: var1_units = "m" + character (len = *), parameter :: var2_units = "s" + character (len = *), parameter :: var3_units = "degrees" + character (len = *), parameter :: var4_units = "degrees" + character (len = *), parameter :: lat_units = "degrees_north" + character (len = *), parameter :: lon_units = "degrees_east" + iyc=date1/10000 + imc=(date1-iyc*10000)/100 + idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) + ihc=date2/10000 + iminc=(date2-ihc*10000)/100 + isc=date2-ihc*10000-100*iminc + timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & + (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 + Jday0=julday(1,1,1990) + timenc=timenc-Jday0 + do rec=1,ntime + times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 + enddo + if( ivar == 1) then + file_name = "sys_hs.ww3.nc" + else if( ivar == 2) then + file_name = "sys_tp.ww3.nc" + else if( ivar == 3) then + file_name = "sys_dir.ww3.nc" + else + file_name = "sys_dspr.ww3.nc" + endif +#endif ! -!/TRKNC! create the netcdf file. -!/TRKNC if (outputType.EQ.3) then -!/TRKNC call check( nf90_create(file_name, NF90_CLOBBER, ncid) ) -!/TRKNC endif -!/TRKNC if(outputType.EQ.4) call check( nf90_create(file_name,NF90_NETCDF4,ncid)) -!/TRKNC call check ( nf90_set_fill(ncid,nf90_nofill,oldMode) ) -!/TRKNC call check( nf90_def_dim(ncid, lsys_name, nsys, sys_dimid) ) -!/TRKNC call check( nf90_def_dim(ncid, lat_name, nlats, lat_dimid) ) -!/TRKNC call check( nf90_def_dim(ncid, lon_name, nlons, lon_dimid) ) -!/TRKNC call check( nf90_def_dim(ncid, time_name, ntime, rec_dimid) ) -!/TRKNC call check( nf90_def_var(ncid, lat_name, NF90_REAL, lat_dimid,lat_varid)) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lat_varid,1,1,deflate) ) -!/TRKNC call check( nf90_def_var(ncid, lon_name, NF90_REAL, lon_dimid,lon_varid)) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lon_varid,1,1,deflate) ) -!/TRKNC call check( nf90_def_var(ncid,time_name,NF90_DOUBLE,rec_dimid,rec_varid)) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,rec_varid,1,1,deflate) ) +#ifdef W3_TRKNC +! create the netcdf file. + if (outputType.EQ.3) then + call check( nf90_create(file_name, NF90_CLOBBER, ncid) ) + endif + if(outputType.EQ.4) call check( nf90_create(file_name,NF90_NETCDF4,ncid)) + call check ( nf90_set_fill(ncid,nf90_nofill,oldMode) ) + call check( nf90_def_dim(ncid, lsys_name, nsys, sys_dimid) ) + call check( nf90_def_dim(ncid, lat_name, nlats, lat_dimid) ) + call check( nf90_def_dim(ncid, lon_name, nlons, lon_dimid) ) + call check( nf90_def_dim(ncid, time_name, ntime, rec_dimid) ) + call check( nf90_def_var(ncid, lat_name, NF90_REAL, lat_dimid,lat_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lat_varid,1,1,deflate) ) + call check( nf90_def_var(ncid, lon_name, NF90_REAL, lon_dimid,lon_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,lon_varid,1,1,deflate) ) + call check( nf90_def_var(ncid,time_name,NF90_DOUBLE,rec_dimid,rec_varid)) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,rec_varid,1,1,deflate) ) +#endif ! -!/TRKNC call check( nf90_put_att(ncid, lat_varid, units, lat_units) ) -!/TRKNC call check( nf90_put_att(ncid, lat_varid, 'long_name', 'latitude') ) -!/TRKNC call check( nf90_put_att(ncid, lat_varid, 'standard_name', 'latitude') ) -!/TRKNC call check( nf90_put_att(ncid, lat_varid, 'axis','Y')) -!/TRKNC call check( nf90_put_att(ncid, lon_varid, units, lon_units) ) -!/TRKNC call check( nf90_put_att(ncid, lon_varid, 'long_name', 'longitude') ) -!/TRKNC call check( nf90_put_att(ncid, lon_varid, 'standard_name', 'longitude') ) -!/TRKNC call check( nf90_put_att(ncid, lon_varid, 'axis','X')) -!/TRKNC call check(nf90_put_att(ncid,rec_varid,units,& -!/TRKNC 'days since 1990-01-01 00:00:00')) -!/TRKNC call check(nf90_put_att(ncid,rec_varid,'long_name','julian day (UT)')) -!/TRKNC call check( nf90_put_att(ncid, rec_varid,'standard_name', 'time') ) -!/TRKNC call check( nf90_put_att(ncid, rec_varid, 'conventions',& -!/TRKNC 'relative julian day with decimal part (as part of the day)' ) ) -!/TRKNC call check( nf90_put_att(ncid, rec_varid, 'axis','T')) +#ifdef W3_TRKNC + call check( nf90_put_att(ncid, lat_varid, units, lat_units) ) + call check( nf90_put_att(ncid, lat_varid, 'long_name', 'latitude') ) + call check( nf90_put_att(ncid, lat_varid, 'standard_name', 'latitude') ) + call check( nf90_put_att(ncid, lat_varid, 'axis','Y')) + call check( nf90_put_att(ncid, lon_varid, units, lon_units) ) + call check( nf90_put_att(ncid, lon_varid, 'long_name', 'longitude') ) + call check( nf90_put_att(ncid, lon_varid, 'standard_name', 'longitude') ) + call check( nf90_put_att(ncid, lon_varid, 'axis','X')) + call check(nf90_put_att(ncid,rec_varid,units,& + 'days since 1990-01-01 00:00:00')) + call check(nf90_put_att(ncid,rec_varid,'long_name','julian day (UT)')) + call check( nf90_put_att(ncid, rec_varid,'standard_name', 'time') ) + call check( nf90_put_att(ncid, rec_varid, 'conventions',& + 'relative julian day with decimal part (as part of the day)' ) ) + call check( nf90_put_att(ncid, rec_varid, 'axis','T')) +#endif ! -!/TRKNC dimids = (/ lon_dimid, lat_dimid, sys_dimid, rec_dimid /) -!/TRKNC if( ivar == 1) then -!/TRKNC call check( nf90_def_var(ncid, var1_name, NF90_REAL, dimids,var1_varid) ) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var1_varid,1,1,deflate) ) -!/TRKNC call check( nf90_put_att(ncid, var1_varid, units, var1_units) ) -!/TRKNC call check( nf90_put_att(ncid, var1_varid,'long_name','significant_wave_height') ) -!/TRKNC call check( nf90_put_att(ncid, var1_varid,'missing_value','9999.00')) -!/TRKNC else if( ivar == 2) then -!/TRKNC call check( nf90_def_var(ncid, var2_name, NF90_REAL, dimids, var2_varid) ) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var2_varid,1,1,deflate) ) -!/TRKNC call check( nf90_put_att(ncid, var2_varid, units, var2_units) ) -!/TRKNC call check( nf90_put_att(ncid, var2_varid,'long_name','peak_period') ) -!/TRKNC call check( nf90_put_att(ncid, var2_varid,'missing_value','9999.00') ) -!/TRKNC else if ( ivar ==3 ) then -!/TRKNC call check( nf90_def_var(ncid, var3_name, NF90_REAL, dimids, var3_varid) ) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var3_varid,1,1,deflate) ) -!/TRKNC call check( nf90_put_att(ncid, var3_varid, units, var3_units) ) -!/TRKNC call check( nf90_put_att(ncid, var3_varid,'long_name','peak_direction') ) -!/TRKNC call check( nf90_put_att(ncid, var3_varid,'missing_value','9999.00') ) -!/TRKNC else -!/TRKNC call check( nf90_def_var(ncid, var4_name, NF90_REAL, dimids, var4_varid) ) -!/TRKNC if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var4_varid,1,1,deflate) ) -!/TRKNC call check( nf90_put_att(ncid, var4_varid, units, var4_units) ) -!/TRKNC call check( nf90_put_att(ncid,var4_varid,'long_name','directional_spread') ) -!/TRKNC call check( nf90_put_att(ncid, var4_varid,'missing_value','9999.00') ) -!/TRKNC endif -!/TRKNC call check( nf90_enddef(ncid) ) +#ifdef W3_TRKNC + dimids = (/ lon_dimid, lat_dimid, sys_dimid, rec_dimid /) + if( ivar == 1) then + call check( nf90_def_var(ncid, var1_name, NF90_REAL, dimids,var1_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var1_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var1_varid, units, var1_units) ) + call check( nf90_put_att(ncid, var1_varid,'long_name','significant_wave_height') ) + call check( nf90_put_att(ncid, var1_varid,'missing_value','9999.00')) + else if( ivar == 2) then + call check( nf90_def_var(ncid, var2_name, NF90_REAL, dimids, var2_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var2_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var2_varid, units, var2_units) ) + call check( nf90_put_att(ncid, var2_varid,'long_name','peak_period') ) + call check( nf90_put_att(ncid, var2_varid,'missing_value','9999.00') ) + else if ( ivar ==3 ) then + call check( nf90_def_var(ncid, var3_name, NF90_REAL, dimids, var3_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var3_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var3_varid, units, var3_units) ) + call check( nf90_put_att(ncid, var3_varid,'long_name','peak_direction') ) + call check( nf90_put_att(ncid, var3_varid,'missing_value','9999.00') ) + else + call check( nf90_def_var(ncid, var4_name, NF90_REAL, dimids, var4_varid) ) + if(outputType.EQ.4) call check( nf90_def_var_deflate(ncid,var4_varid,1,1,deflate) ) + call check( nf90_put_att(ncid, var4_varid, units, var4_units) ) + call check( nf90_put_att(ncid,var4_varid,'long_name','directional_spread') ) + call check( nf90_put_att(ncid, var4_varid,'missing_value','9999.00') ) + endif + call check( nf90_enddef(ncid) ) +#endif ! -!/TRKNC call check( nf90_put_var(ncid, lat_varid, lats) ) -!/TRKNC call check( nf90_put_var(ncid, lon_varid, lons) ) -!/TRKNC call check( nf90_put_var(ncid, rec_varid, times) ) +#ifdef W3_TRKNC + call check( nf90_put_var(ncid, lat_varid, lats) ) + call check( nf90_put_var(ncid, lon_varid, lons) ) + call check( nf90_put_var(ncid, rec_varid, times) ) +#endif ! -!/TRKNC count = (/ nlons, nlats, nsys, ntime /) -!/TRKNC start = (/ 1, 1, 1, 1 /) -!/TRKNC if( ivar == 1) then -!/TRKNC call check( nf90_put_var(ncid, var1_varid, data_in, start = start, & -!/TRKNC count = count) ) -!/TRKNC else if( ivar == 2) then -!/TRKNC call check( nf90_put_var(ncid, var2_varid, data_in, start = start, & -!/TRKNC count = count) ) -!/TRKNC else if( ivar == 3) then -!/TRKNC call check( nf90_put_var(ncid, var3_varid, data_in, start = start, & -!/TRKNC count = count) ) -!/TRKNC else -!/TRKNC call check( nf90_put_var(ncid, var4_varid, data_in, start = start, & -!/TRKNC count = count) ) -!/TRKNC endif -!/TRKNC call check( nf90_close(ncid) ) -!/TRKNC end subroutine t2netcdf +#ifdef W3_TRKNC + count = (/ nlons, nlats, nsys, ntime /) + start = (/ 1, 1, 1, 1 /) + if( ivar == 1) then + call check( nf90_put_var(ncid, var1_varid, data_in, start = start, & + count = count) ) + else if( ivar == 2) then + call check( nf90_put_var(ncid, var2_varid, data_in, start = start, & + count = count) ) + else if( ivar == 3) then + call check( nf90_put_var(ncid, var3_varid, data_in, start = start, & + count = count) ) + else + call check( nf90_put_var(ncid, var4_varid, data_in, start = start, & + count = count) ) + endif + call check( nf90_close(ncid) ) + end subroutine t2netcdf +#endif ! -!/TRKNC subroutine check(status) -!/TRKNC use netcdf -!/TRKNC integer, intent ( in) :: status -!/TRKNC if(status /= nf90_noerr) then -!/TRKNC write(6,996) -!/TRKNC 996 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK:'/ & -!/TRKNC 'netCDF error:') -!/TRKNC print *, trim(nf90_strerror(status)) -!/TRKNC stop "Stopped in netcdf output part" -!/TRKNC endif -!/TRKNC end subroutine check +#ifdef W3_TRKNC + subroutine check(status) + use netcdf + integer, intent ( in) :: status + if(status /= nf90_noerr) then + write(6,996) + 996 FORMAT (/' *** WAVEWATCH III ERROR IN WW3_SYSTRK:'/ & + 'netCDF error:') + print *, trim(nf90_strerror(status)) + stop "Stopped in netcdf output part" + endif + end subroutine check +#endif ! -!/TRKNC subroutine pt2netcdf(longitude,latitude,hs,tp,& -!/TRKNC dir,npoints,date1,date2,dt,ntime,outputType) -!/TRKNC USE W3TIMEMD -!/TRKNC use netcdf -!/TRKNC implicit none -!/TRKNC integer :: ntime,npoints,outputType -!/TRKNC integer, parameter :: deflate = 1 -!/TRKNC integer :: iret, oldMode -!/TRKNC integer :: ncid -!/TRKNC integer :: system_index_dim -!/TRKNC integer :: point_dim,rec_dim -!/TRKNC integer :: nsys -!/TRKNC integer :: start(3), count(3) -!/TRKNC parameter (nsys = 10) -!/TRKNC integer :: latitude_id -!/TRKNC integer :: longitude_id -!/TRKNC integer :: time_id -!/TRKNC integer :: hs_id -!/TRKNC integer :: tp_id -!/TRKNC integer :: dir_id -!/TRKNC integer :: time_rank -!/TRKNC integer :: hs_rank -!/TRKNC integer :: tp_rank -!/TRKNC integer :: dir_rank -!/TRKNC parameter (time_rank = 1) -!/TRKNC parameter (hs_rank = 3) -!/TRKNC parameter (tp_rank = 3) -!/TRKNC parameter (dir_rank = 3) +#ifdef W3_TRKNC + subroutine pt2netcdf(longitude,latitude,hs,tp,& + dir,npoints,date1,date2,dt,ntime,outputType) + USE W3TIMEMD + use netcdf + implicit none + integer :: ntime,npoints,outputType + integer, parameter :: deflate = 1 + integer :: iret, oldMode + integer :: ncid + integer :: system_index_dim + integer :: point_dim,rec_dim + integer :: nsys + integer :: start(3), count(3) + parameter (nsys = 10) + integer :: latitude_id + integer :: longitude_id + integer :: time_id + integer :: hs_id + integer :: tp_id + integer :: dir_id + integer :: time_rank + integer :: hs_rank + integer :: tp_rank + integer :: dir_rank + parameter (time_rank = 1) + parameter (hs_rank = 3) + parameter (tp_rank = 3) + parameter (dir_rank = 3) +#endif ! -!/TRKNC integer :: hs_dims(hs_rank) -!/TRKNC integer :: tp_dims(tp_rank) -!/TRKNC integer :: dir_dims(dir_rank) -!/TRKNC real :: latitude(npoints),dt -!/TRKNC real :: longitude(npoints) -!/TRKNC real :: hs(nsys, npoints, ntime) -!/TRKNC real :: tp(nsys, npoints, ntime) -!/TRKNC real :: dir(nsys, npoints, ntime) -!/TRKNC integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0,rec -!/TRKNC double precision date1,date2,timenc -!/TRKNC double precision times(ntime) +#ifdef W3_TRKNC + integer :: hs_dims(hs_rank) + integer :: tp_dims(tp_rank) + integer :: dir_dims(dir_rank) + real :: latitude(npoints),dt + real :: longitude(npoints) + real :: hs(nsys, npoints, ntime) + real :: tp(nsys, npoints, ntime) + real :: dir(nsys, npoints, ntime) + integer :: iyc,imc,idc,ihc,iminc,isc,Jday,Jday0,rec + double precision date1,date2,timenc + double precision times(ntime) +#endif ! -!/TRKNC iyc=date1/10000 -!/TRKNC imc=(date1-iyc*10000)/100 -!/TRKNC idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) -!/TRKNC ihc=date2/10000 -!/TRKNC iminc=(date2-ihc*10000)/100 -!/TRKNC isc=date2-ihc*10000-100*iminc -!/TRKNC timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & -!/TRKNC (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 -!/TRKNC Jday0=julday(1,1,1990) -!/TRKNC timenc=timenc-Jday0 -!/TRKNC do rec=1,ntime -!/TRKNC times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 -!/TRKNC enddo +#ifdef W3_TRKNC + iyc=date1/10000 + imc=(date1-iyc*10000)/100 + idc=int(date1-DBLE(iyc*10000)-DBLE(imc*100)) + ihc=date2/10000 + iminc=(date2-ihc*10000)/100 + isc=date2-ihc*10000-100*iminc + timenc=DBLE(julday(idc,imc,iyc))+(DBLE(ihc)+(DBLE(iminc)+ & + (DBLE(isc)/60.0D0))/60.0D0)/24.0D0 + Jday0=julday(1,1,1990) + timenc=timenc-Jday0 + do rec=1,ntime + times(rec)=timenc+DBLE( (rec-1)*dt)/3600.0D0/24.0D0 + enddo +#endif ! -!/TRKNC if(outputType.EQ.3) then -!/TRKNC iret = nf90_create('sys_pnt.ww3.nc', NF90_CLOBBER, ncid) -!/TRKNC endif -!/TRKNC if (outputType.EQ.4) iret = nf90_create('sys_pnt.ww3.nc',NF90_NETCDF4, ncid) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_set_fill(ncid,nf90_nofill,oldMode) -!/TRKNC call check(iret) -!/TRKNC! define dimensions -!/TRKNC iret = nf90_def_dim(ncid, 'system_index', nsys, system_index_dim) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_def_dim(ncid, 'point', npoints, point_dim) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_def_dim(ncid, 'time', ntime, rec_dim) -!/TRKNC call check(iret) -!/TRKNC! define variables -!/TRKNC iret = nf90_def_var(ncid, 'latitude', NF90_REAL, point_dim, & -!/TRKNC latitude_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,latitude_id,1,1,deflate)) -!/TRKNC iret = nf90_def_var(ncid, 'longitude', NF90_REAL, point_dim, & -!/TRKNC longitude_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,longitude_id,1,1,deflate)) -!/TRKNC iret = nf90_def_var(ncid, 'time', NF90_DOUBLE, rec_dim, & -!/TRKNC time_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,time_id,1,1,deflate) ) -!/TRKNC hs_dims(3) = rec_dim -!/TRKNC hs_dims(2) = point_dim -!/TRKNC hs_dims(1) = system_index_dim -!/TRKNC iret = nf90_def_var(ncid, 'hs', NF90_REAL, & -!/TRKNC hs_dims, hs_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,hs_id,1,1,deflate)) -!/TRKNC tp_dims(3) = rec_dim -!/TRKNC tp_dims(2) = point_dim -!/TRKNC tp_dims(1) = system_index_dim -!/TRKNC iret = nf90_def_var(ncid, 'tp', NF90_REAL, & -!/TRKNC tp_dims, tp_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,tp_id,1,1,deflate)) -!/TRKNC dir_dims(3) = rec_dim -!/TRKNC dir_dims(2) = point_dim -!/TRKNC dir_dims(1) = system_index_dim -!/TRKNC iret = nf90_def_var(ncid, 'dir', NF90_REAL, & -!/TRKNC dir_dims, dir_id) -!/TRKNC call check(iret) -!/TRKNC if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,dir_id,1,1,deflate)) -!/TRKNC! assign attributes -!/TRKNC iret = nf90_put_att(ncid, latitude_id, 'units', 'degrees_north') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, latitude_id, 'long_name', 'latitude') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, latitude_id, 'standard_name', 'latitude') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, latitude_id, 'axis', 'Y') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, longitude_id, 'units', 'degrees_east') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, longitude_id,'long_name','longitude') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, longitude_id,'standard_name','longitude') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, longitude_id, 'axis', 'X') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, time_id, 'units', & -!/TRKNC 'days since 1990-01-01 00:00:00') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, time_id, 'long_name','julian day(UT)') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, time_id, 'standard_name','time') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, time_id, 'conventions', & -!/TRKNC 'relative julian day with decimal part (as part of the day)') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, time_id, 'axis', 'T') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, hs_id, 'units', 'm') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, hs_id,'long_name','significant_wave_height') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, hs_id, 'missing_value', & -!/TRKNC '999.9999') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, tp_id, 'units', 's') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, tp_id,'long_name','peak_period') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, tp_id, 'missing_value', & -!/TRKNC '999.9999') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, dir_id, 'units', 'degrees') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, dir_id,'long_name','peak_direction') -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_att(ncid, dir_id, 'missing_value',& -!/TRKNC '999.9999') -!/TRKNC call check(iret) -!/TRKNC! leave define mode -!/TRKNC iret = nf90_enddef(ncid) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_var(ncid, latitude_id, latitude) -!/TRKNC call check(iret) +#ifdef W3_TRKNC + if(outputType.EQ.3) then + iret = nf90_create('sys_pnt.ww3.nc', NF90_CLOBBER, ncid) + endif + if (outputType.EQ.4) iret = nf90_create('sys_pnt.ww3.nc',NF90_NETCDF4, ncid) + call check(iret) + iret = nf90_set_fill(ncid,nf90_nofill,oldMode) + call check(iret) +! define dimensions + iret = nf90_def_dim(ncid, 'system_index', nsys, system_index_dim) + call check(iret) + iret = nf90_def_dim(ncid, 'point', npoints, point_dim) + call check(iret) + iret = nf90_def_dim(ncid, 'time', ntime, rec_dim) + call check(iret) +! define variables + iret = nf90_def_var(ncid, 'latitude', NF90_REAL, point_dim, & + latitude_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,latitude_id,1,1,deflate)) + iret = nf90_def_var(ncid, 'longitude', NF90_REAL, point_dim, & + longitude_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,longitude_id,1,1,deflate)) + iret = nf90_def_var(ncid, 'time', NF90_DOUBLE, rec_dim, & + time_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,time_id,1,1,deflate) ) + hs_dims(3) = rec_dim + hs_dims(2) = point_dim + hs_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'hs', NF90_REAL, & + hs_dims, hs_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,hs_id,1,1,deflate)) + tp_dims(3) = rec_dim + tp_dims(2) = point_dim + tp_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'tp', NF90_REAL, & + tp_dims, tp_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,tp_id,1,1,deflate)) + dir_dims(3) = rec_dim + dir_dims(2) = point_dim + dir_dims(1) = system_index_dim + iret = nf90_def_var(ncid, 'dir', NF90_REAL, & + dir_dims, dir_id) + call check(iret) + if (outputType.EQ.4) call check( nf90_def_var_deflate(ncid,dir_id,1,1,deflate)) +! assign attributes + iret = nf90_put_att(ncid, latitude_id, 'units', 'degrees_north') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'long_name', 'latitude') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'standard_name', 'latitude') + call check(iret) + iret = nf90_put_att(ncid, latitude_id, 'axis', 'Y') + call check(iret) + iret = nf90_put_att(ncid, longitude_id, 'units', 'degrees_east') + call check(iret) + iret = nf90_put_att(ncid, longitude_id,'long_name','longitude') + call check(iret) + iret = nf90_put_att(ncid, longitude_id,'standard_name','longitude') + call check(iret) + iret = nf90_put_att(ncid, longitude_id, 'axis', 'X') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'units', & + 'days since 1990-01-01 00:00:00') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'long_name','julian day(UT)') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'standard_name','time') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'conventions', & + 'relative julian day with decimal part (as part of the day)') + call check(iret) + iret = nf90_put_att(ncid, time_id, 'axis', 'T') + call check(iret) + iret = nf90_put_att(ncid, hs_id, 'units', 'm') + call check(iret) + iret = nf90_put_att(ncid, hs_id,'long_name','significant_wave_height') + call check(iret) + iret = nf90_put_att(ncid, hs_id, 'missing_value', & + '999.9999') + call check(iret) + iret = nf90_put_att(ncid, tp_id, 'units', 's') + call check(iret) + iret = nf90_put_att(ncid, tp_id,'long_name','peak_period') + call check(iret) + iret = nf90_put_att(ncid, tp_id, 'missing_value', & + '999.9999') + call check(iret) + iret = nf90_put_att(ncid, dir_id, 'units', 'degrees') + call check(iret) + iret = nf90_put_att(ncid, dir_id,'long_name','peak_direction') + call check(iret) + iret = nf90_put_att(ncid, dir_id, 'missing_value',& + '999.9999') + call check(iret) +! leave define mode + iret = nf90_enddef(ncid) + call check(iret) + iret = nf90_put_var(ncid, latitude_id, latitude) + call check(iret) +#endif ! -!/TRKNC iret = nf90_put_var(ncid, longitude_id, longitude) -!/TRKNC call check(iret) +#ifdef W3_TRKNC + iret = nf90_put_var(ncid, longitude_id, longitude) + call check(iret) +#endif ! -!/TRKNC iret = nf90_put_var(ncid, time_id, times) -!/TRKNC call check(iret) +#ifdef W3_TRKNC + iret = nf90_put_var(ncid, time_id, times) + call check(iret) +#endif ! -!/TRKNC start = (/ 1, 1, 1 /) -!/TRKNC count = (/ nsys,npoints,ntime /) +#ifdef W3_TRKNC + start = (/ 1, 1, 1 /) + count = (/ nsys,npoints,ntime /) +#endif ! -!/TRKNC iret = nf90_put_var(ncid, hs_id, hs,& -!/TRKNC start = start, count = count ) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_var(ncid, tp_id, tp, & -!/TRKNC start = start, count = count ) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_put_var(ncid, dir_id, dir,& -!/TRKNC start = start, count = count ) -!/TRKNC call check(iret) -!/TRKNC iret = nf90_close(ncid) -!/TRKNC call check(iret) -!/TRKNC return -!/TRKNC end subroutine pt2netcdf +#ifdef W3_TRKNC + iret = nf90_put_var(ncid, hs_id, hs,& + start = start, count = count ) + call check(iret) + iret = nf90_put_var(ncid, tp_id, tp, & + start = start, count = count ) + call check(iret) + iret = nf90_put_var(ncid, dir_id, dir,& + start = start, count = count ) + call check(iret) + iret = nf90_close(ncid) + call check(iret) + return + end subroutine pt2netcdf +#endif diff --git a/model/ftn/ww3_trck.ftn b/model/src/ww3_trck.F90 similarity index 98% rename from model/ftn/ww3_trck.ftn rename to model/src/ww3_trck.F90 index d8ea2e6f1..5af6b4d09 100644 --- a/model/ftn/ww3_trck.ftn +++ b/model/src/ww3_trck.F90 @@ -65,7 +65,9 @@ PROGRAM W3TRCK USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD, ONLY : STME21 ! USE W3ODATMD, ONLY: NDSO, NDSE, NDST @@ -84,7 +86,9 @@ PROGRAM W3TRCK NREC, ILOC, ISPEC, TIME(2), TTST(2), & ILAST, NZERO, IK, ITH, IWZERO, ICH, & IWDTH, J -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif INTEGER :: LINELN = 81 REAL :: TH1, DTH, X, Y, DW, CX, CY, WX, WY, & UST, AS, VALUE @@ -118,7 +122,9 @@ PROGRAM W3TRCK NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE ( IENT, 'W3TRCK' ) +#ifdef W3_S + CALL STRACE ( IENT, 'W3TRCK' ) +#endif ! WRITE (NDSO,900) ! diff --git a/model/ftn/ww3_trnc.ftn b/model/src/ww3_trnc.F90 similarity index 99% rename from model/ftn/ww3_trnc.ftn rename to model/src/ww3_trnc.F90 index c640cac50..8f6f96fed 100644 --- a/model/ftn/ww3_trnc.ftn +++ b/model/src/ww3_trnc.F90 @@ -61,7 +61,9 @@ PROGRAM W3TRNC USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE -!/S USE W3SERVMD, ONLY : STRACE +#ifdef W3_S + USE W3SERVMD, ONLY : STRACE +#endif USE W3TIMEMD ! USE W3ODATMD, ONLY: NDSO, NDSE @@ -86,7 +88,9 @@ PROGRAM W3TRNC INTEGER :: TIME(2), TOUT(2), NOUT, TDUM(2), & DIMID(4), VARID(18), DIMLN(4), & STOPDATE(8) -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! REAL :: TH1, DTH, X, Y, DW, CX, CY, CAO, CDO,& WX, WY, WAO, WDO, UST, AS, DTEST, & @@ -126,7 +130,9 @@ PROGRAM W3TRNC NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! -!/S CALL STRACE ( IENT, 'W3TRNC' ) +#ifdef W3_S + CALL STRACE ( IENT, 'W3TRNC' ) +#endif ! WRITE (NDSO,900) ! @@ -483,7 +489,9 @@ SUBROUTINE W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) INTEGER :: S1, S2, S4, S5, NDSDAT, IRET INTEGER :: STARTDATE(8), CURDATE(8), REFDATE(8) INTEGER :: DEFLATE=1 -!/S INTEGER, SAVE :: IENT = 0 +#ifdef W3_S + INTEGER, SAVE :: IENT = 0 +#endif ! DOUBLE PRECISION :: OUTJULDAY ! @@ -496,7 +504,9 @@ SUBROUTINE W3EXNC ( FILEPREFIX, NCTYPE, NCID, S3, STRSTOPDATE, MK, MTH ) !/ ------------------------------------------------------------------- / !/ ! -!/S CALL STRACE (IENT, 'W3EXNC') +#ifdef W3_S + CALL STRACE (IENT, 'W3EXNC') +#endif ! CALL U2D('days since 1990-01-01 00:00:00',REFDATE,IERR) diff --git a/model/ftn/ww3_uprstr.ftn b/model/src/ww3_uprstr.F90 similarity index 79% rename from model/ftn/ww3_uprstr.ftn rename to model/src/ww3_uprstr.F90 index edecc169e..b0204253c 100644 --- a/model/ftn/ww3_uprstr.ftn +++ b/model/src/ww3_uprstr.F90 @@ -322,12 +322,16 @@ PROGRAM W3UPRSTR USE W3GDATMD, ONLY: GNAME, NX, NY, MAPSTA, SIG, NK, NTH, NSEA, & NSEAL, MAPSF, DMIN, ZB, DSIP, DTH, RSTYPE, & GTYPE, SMCTYPE -!/SMC USE W3GDATMD, ONLY: FSWND +#ifdef W3_SMC + USE W3GDATMD, ONLY: FSWND +#endif USE W3WDATMD, ONLY: VA, TIME USE W3ADATMD, ONLY: NSEALM USE W3ODATMD, ONLY: IAPROC, NAPERR, NAPLOG, NDS, NAPOUT USE W3ODATMD, ONLY: NDSE, NDSO, NDST, IDOUT, FNMPRE -!/WRST USE W3IDATMD +#ifdef W3_WRST + USE W3IDATMD +#endif ! USE W3NMLUPRSTRMD ! @@ -378,8 +382,10 @@ PROGRAM W3UPRSTR CALL W3SETA ( 1, 6, 6 ) CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) -!/WRST CALL W3NINP ( 6, 6 ) -!/WRST CALL W3SETI ( 1, 6, 6 ) +#ifdef W3_WRST + CALL W3NINP ( 6, 6 ) + CALL W3SETI ( 1, 6, 6 ) +#endif ! NDSE = 6 NDSI = 10 @@ -403,9 +409,11 @@ PROGRAM W3UPRSTR ! WRITE (NDSO,900) ! -!/WRST !Compiling with WRST will allow access to options UPD5/6 -!/WRST WRSTON = .TRUE. -!/WRST WRITE (NDSO,*) '*** UPRSTR will read wind from restart files' +#ifdef W3_WRST + !Compiling with WRST will allow access to options UPD5/6 + WRSTON = .TRUE. + WRITE (NDSO,*) '*** UPRSTR will read wind from restart files' +#endif !/ !/ ------------------------------------------------------------------- / ! 2. Read the ww3_uprstr input data @@ -445,8 +453,10 @@ PROGRAM W3UPRSTR IF ((UPDPROC .EQ. 'UPD2') .OR. (UPDPROC .EQ. 'UPD3')) THEN ! CALL NEXTLN ( COMSTR , NDSI , NDSEN ) READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP -!/F CALL NEXTLN ( COMSTR , NDSI , NDSEN ) -!/F READ (NDSI,*,END=2001,ERR=2002) FLNMCOR +#ifdef W3_F + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*,END=2001,ERR=2002) FLNMCOR +#endif ELSE READ (NDSI,*,END=2001,ERR=2002) PRCNTG_CAP, THRWSEA END IF @@ -454,7 +464,9 @@ PROGRAM W3UPRSTR READ (NDSI,*,END=2001,ERR=2002) FLNMANL END IF ENDIF -!/T WRITE (NDSO,*)' TIME: ',TIME +#ifdef W3_T + WRITE (NDSO,*)' TIME: ',TIME +#endif !/ !/ ------------------------------------------------------------------- / ! 3. Read model definition file. @@ -463,21 +475,29 @@ PROGRAM W3UPRSTR NSEAL = NSEA WRITE (NDSO,920) GNAME !/ -!/SMC !! SMC grid option is activated if GTYPE .EQ. SMCTYPE. JGLi06May2021 -!/SMC IF( GTYPE .EQ. SMCTYPE ) SMCGRD = .TRUE. -!/SMC !! SMC sea-point wind option is activated if FSWND=.TRUE. JGLi06May2021 -!/SMC IF( FSWND ) SMCWND = .TRUE. -!/WRST ! Override SMCWND - at present restarts only store wind on -!/WRST ! a regular grid -!/WRST SMCWND = .FALSE. -!/SMC WRITE (NDSO,*) '*** UPRSTR set to work with SMC grid model' +#ifdef W3_SMC + !! SMC grid option is activated if GTYPE .EQ. SMCTYPE. JGLi06May2021 + IF( GTYPE .EQ. SMCTYPE ) SMCGRD = .TRUE. + !! SMC sea-point wind option is activated if FSWND=.TRUE. JGLi06May2021 + IF( FSWND ) SMCWND = .TRUE. +#endif +#ifdef W3_WRST + ! Override SMCWND - at present restarts only store wind on + ! a regular grid + SMCWND = .FALSE. +#endif +#ifdef W3_SMC + WRITE (NDSO,*) '*** UPRSTR set to work with SMC grid model' +#endif !/ !/ ------------------------------------------------------------------- / ! 4. Read restart file !/ -!/WRST ! Set the wind flag to true when reading restart wind -!/WRST INFLAGS1(3) = .TRUE. -!/WRST CALL W3DIMI ( 1, 6, 6 ) !Needs to be called after w3iogr to have correct dimensions? +#ifdef W3_WRST + ! Set the wind flag to true when reading restart wind + INFLAGS1(3) = .TRUE. + CALL W3DIMI ( 1, 6, 6 ) !Needs to be called after w3iogr to have correct dimensions? +#endif CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD )! IF ( IAPROC .EQ. NAPLOG ) THEN IF (RSTYPE.EQ.0.OR.RSTYPE.EQ.1.OR.RSTYPE.EQ.4) THEN @@ -489,8 +509,10 @@ PROGRAM W3UPRSTR WRITE (NDSO,*) ' TIME: ',TIME END IF END IF -!/T WRITE (NDST,*), MYNAME,' : Exporting VA as imported to VA01.txt' -!/T CALL writeMatrix('VA01.txt', REAL(VA)) +#ifdef W3_T + WRITE (NDST,*), MYNAME,' : Exporting VA as imported to VA01.txt' + CALL writeMatrix('VA01.txt', REAL(VA)) +#endif !/ !/ ------------------------------------------------------------------- / ! 5. Update restart spectra array according to the selected option @@ -503,29 +525,37 @@ PROGRAM W3UPRSTR CASE ('UPD0F') WRITE (NDSO,902) 'UPD0F' WRITE (NDSO,1005) ' PRCNTG = ',PRCNTG -!/T ALLOCATE( VATMP (SIZE(VA ,1) )) -!/T ALLOCATE( SWHANL (SIZE(MAPSTA,1), SIZE(MAPSTA,2))) -!/T ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2))) +#ifdef W3_T + ALLOCATE( VATMP (SIZE(VA ,1) )) + ALLOCATE( SWHANL (SIZE(MAPSTA,1), SIZE(MAPSTA,2))) + ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2))) +#endif DO ISEA=1, NSEA, 1 -!/T IX = MAPSF(ISEA,1) -!/T IY = MAPSF(ISEA,2) -!/T VATMP = VA(:,ISEA) -!/T CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) -!/T SWHBCKG(IY,IX)=SWHBCKG_1 +#ifdef W3_T + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) + SWHBCKG(IY,IX)=SWHBCKG_1 +#endif CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) -!/T VATMP = VA(:,ISEA) -!/T CALL SWH_RSRT_1p (VATMP, ISEA, SWHANL_1) -!/T SWHANL(IY,IX)=SWHANL_1 -!/T WRITE (NDSO,*) ' =========== UPD0F Output ===========' -!/T WRITE (NDSO,*)'ISEA = ', ISEA,' PRCNTG = ',PRCNTG, & -!/T ' SWHBCKG = ',SWHBCKG(IY,IX), & -!/T ' SWHANL= ', SWHANL(IY,IX) +#ifdef W3_T + VATMP = VA(:,ISEA) + CALL SWH_RSRT_1p (VATMP, ISEA, SWHANL_1) + SWHANL(IY,IX)=SWHANL_1 + WRITE (NDSO,*) ' =========== UPD0F Output ===========' + WRITE (NDSO,*)'ISEA = ', ISEA,' PRCNTG = ',PRCNTG, & + ' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL= ', SWHANL(IY,IX) +#endif END DO -!/T CALL writeMatrix('SWHBCKG_UPD0F.txt', REAL(SWHBCKG)) -!/T CALL writeMatrix('SWHANL_UPD0F.txt' , REAL(SWHANL )) -!/T CALL writeMatrix('SWHRSTR_UPD0F.txt', REAL(SWHANL )) -!/T -!/T DEALLOCATE ( VATMP, SWHBCKG, SWHANL ) +#ifdef W3_T + CALL writeMatrix('SWHBCKG_UPD0F.txt', REAL(SWHBCKG)) + CALL writeMatrix('SWHANL_UPD0F.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD0F.txt', REAL(SWHANL )) + + DEALLOCATE ( VATMP, SWHBCKG, SWHANL ) +#endif !/ !/ ------------------------------------------------------------------- / ! UPD2 @@ -542,26 +572,36 @@ PROGRAM W3UPRSTR IF (.NOT. SMCGRD) THEN ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/SMC ELSE -!/SMC ALLOCATE( SWHBCKG(NSEA,1) ) -!/SMC ALLOCATE( SWHANL(NSEA,1) ) +#ifdef W3_SMC + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) +#endif ENDIF -!/T IF (.NOT. SMCGRD) THEN -!/T ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/T ELSE -!/T ALLOCATE( SWHUPRSTR(NSEA,1) ) -!/T ENDIF +#ifdef W3_T + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif ! ! Read additional Input: Analysis Field INQUIRE(FILE=FLNMANL, EXIST=anl_exists) IF (anl_exists) THEN -!/T WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#ifdef W3_T + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#endif CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) -!/T CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#ifdef W3_T + CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#endif ELSE WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' DEALLOCATE( SWHANL,VATMP,SWHBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif STOP END IF ! @@ -570,9 +610,11 @@ PROGRAM W3UPRSTR IF (.NOT. SMCGRD) THEN IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ELSE -!/SMC IX = 1 -!/SMC IY = ISEA +#ifdef W3_SMC + ELSE + IX = 1 + IY = ISEA +#endif ENDIF VATMP = VA(:,ISEA) CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) @@ -580,26 +622,34 @@ PROGRAM W3UPRSTR ! IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) -!/T WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & -!/T ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & -!/T ' SWHANL = ', SWHANL(IY,IX) +#ifdef W3_T + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) +#endif CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) CALL UPDATE_VA(PRCNTG, VA(:,ISEA)) -!/T CALL SWH_RSRT_1p (VA(:,ISEA), ISEA, SWHUPRSTR(IY,IX)) -!/T WRITE (NDSO,*) ' =========== UPD2 Output ===========' -!/T WRITE (NDSO,*)'ISEA = ',ISEA, & -!/T 'SWH_BCKG = ', SWHBCKG(IY,IX), & -!/T 'SWH_ANL = ', SWHANL(IY,IX), & -!/T 'PRCNTG = ', PRCNTG, & -!/T 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#ifdef W3_T + CALL SWH_RSRT_1p (VA(:,ISEA), ISEA, SWHUPRSTR(IY,IX)) + WRITE (NDSO,*) ' =========== UPD2 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA, & + 'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'PRCNTG = ', PRCNTG, & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif END IF END DO -!/T CALL writeMatrix('SWHBCKG_UPD2.txt', REAL(SWHBCKG )) -!/T CALL writeMatrix('SWHANL_UPD2.txt' , REAL(SWHANL )) -!/T CALL writeMatrix('SWHRSTR_UPD2.txt', REAL(SWHUPRSTR)) +#ifdef W3_T + CALL writeMatrix('SWHBCKG_UPD2.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD2.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD2.txt', REAL(SWHUPRSTR)) +#endif ! DEALLOCATE( SWHANL,VATMP,SWHBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif !/ !/ ------------------------------------------------------------------- / ! UPD3 @@ -618,26 +668,36 @@ PROGRAM W3UPRSTR IF (.NOT. SMCGRD) THEN ALLOCATE( SWHBCKG(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) ALLOCATE( SWHANL(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/SMC ELSE -!/SMC ALLOCATE( SWHBCKG(NSEA,1) ) -!/SMC ALLOCATE( SWHANL(NSEA,1) ) +#ifdef W3_SMC + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) +#endif + ENDIF +#ifdef W3_T + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) ENDIF -!/T IF (.NOT. SMCGRD) THEN -!/T ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/T ELSE -!/T ALLOCATE( SWHUPRSTR(NSEA,1) ) -!/T ENDIF +#endif ! ! Read additional Input: Analysis Field INQUIRE(FILE=FLNMANL, EXIST=anl_exists) IF (anl_exists) THEN -!/T WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#ifdef W3_T + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#endif CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) -!/T CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#ifdef W3_T + CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#endif ELSE WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif STOP END IF ! @@ -646,9 +706,11 @@ PROGRAM W3UPRSTR IF (.NOT. SMCGRD) THEN IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ELSE -!/SMC IX = 1 -!/SMC IY = ISEA +#ifdef W3_SMC + ELSE + IX = 1 + IY = ISEA +#endif ENDIF VATMP = VA(:,ISEA) CALL SWH_RSRT_1p (VATMP, ISEA, SWHBCKG_1) @@ -657,15 +719,19 @@ PROGRAM W3UPRSTR IF ( SWHBCKG(IY,IX) > 0.01 .AND. SWHANL(IY,IX) > 0.01 ) THEN !Step 1. PRCNTG=(SWHANL(IY,IX)/SWHBCKG_1) -!/T WRITE (NDSO,*) ' =========== Step 1. ===========' -!/T WRITE (NDSO,*) ' ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & -!/T ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & -!/T ' SWHANL = ', SWHANL(IY,IX) +#ifdef W3_T + WRITE (NDSO,*) ' =========== Step 1. ===========' + WRITE (NDSO,*) ' ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) +#endif CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) VATMP_NORM=VATMP/SUM(VATMP) -!/T WRITE (NDSO,*)' ISEA =', ISEA,' IX = ',IX,' IY = ', IY, & -!/T ' PRCNTG = ',PRCNTG, & -!/T ' SWHBCKG = ',SWHBCKG(IY,IX), ' SWHANL = ', SWHANL(IY,IX) +#ifdef W3_T + WRITE (NDSO,*)' ISEA =', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG, & + ' SWHBCKG = ',SWHBCKG(IY,IX), ' SWHANL = ', SWHANL(IY,IX) +#endif IF (PRCNTG > 1.) THEN A=PRCNTG**2*(1 + VATMP_NORM) ELSE @@ -674,28 +740,36 @@ PROGRAM W3UPRSTR VATMP=A*VATMP CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) PRCNTG=(SWHANL(IY,IX)/SWHTMP) -!/T SWHUPRSTR(IY,IX)=SWHTMP -!/T WRITE (NDSO,*) ' =========== Step 2. ===========' -!/T WRITE (NDSO,*)'ISEA = ', ISEA, ' PRCNTG = ',PRCNTG, & -!/T ' SWHANL= ', SWHANL(IY,IX), & -!/T ' SWHUPRSTR(IY,IX) = ', SWHUPRSTR(IY,IX) +#ifdef W3_T + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== Step 2. ===========' + WRITE (NDSO,*)'ISEA = ', ISEA, ' PRCNTG = ',PRCNTG, & + ' SWHANL= ', SWHANL(IY,IX), & + ' SWHUPRSTR(IY,IX) = ', SWHUPRSTR(IY,IX) +#endif CALL CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) CALL UPDATE_VA(PRCNTG, VATMP) VA(:,ISEA)=VATMP -!/T CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) -!/T SWHUPRSTR(IY,IX)=SWHTMP -!/T WRITE (NDSO,*) ' =========== UPD3 Output ===========' -!/T WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & -!/T 'SWH_ANL = ', SWHANL(IY,IX), & -!/T 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#ifdef W3_T + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD3 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif END IF END DO -!/T CALL writeMatrix('SWHBCKG_UPD3.txt', REAL(SWHBCKG)) -!/T CALL writeMatrix('SWHANL_UPD3.txt' , REAL(SWHANL )) -!/T CALL writeMatrix('SWHRSTR_UPD3.txt', REAL(SWHUPRSTR)) +#ifdef W3_T + CALL writeMatrix('SWHBCKG_UPD3.txt', REAL(SWHBCKG)) + CALL writeMatrix('SWHANL_UPD3.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD3.txt', REAL(SWHUPRSTR)) +#endif ! DEALLOCATE( SWHANL,VATMP,SWHBCKG,VATMP_NORM,A ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif !/ !/ ------------------------------------------------------------------- / ! UPD5 @@ -722,47 +796,63 @@ PROGRAM W3UPRSTR ! Wind arrays allocated using X,Y convention as in w3idatmd ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) -!/SMC ELSE -!/SMC ALLOCATE( SWHBCKG(NSEA,1) ) -!/SMC ALLOCATE( SWHANL(NSEA,1) ) -!/SMC ! Use SMCWND to determine if reading a seapoint aray for wind -!/SMC IF( SMCWND ) THEN -!/SMC ALLOCATE( WSBCKG(NSEA,1) ) -!/SMC ALLOCATE( WDRBCKG(NSEA,1) ) -!/SMC ELSE -!/SMC ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) -!/SMC ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) -!/SMC ENDIF +#ifdef W3_SMC + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) + ! Use SMCWND to determine if reading a seapoint aray for wind + IF( SMCWND ) THEN + ALLOCATE( WSBCKG(NSEA,1) ) + ALLOCATE( WDRBCKG(NSEA,1) ) + ELSE + ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ENDIF +#endif ENDIF -!/T IF (.NOT. SMCGRD) THEN -!/T ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/T ELSE -!/T ALLOCATE( SWHUPRSTR(NSEA,1) ) -!/T ENDIF +#ifdef W3_T + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif ! ! Read additional Input: Analysis Field INQUIRE(FILE=FLNMANL, EXIST=anl_exists) IF (anl_exists) THEN -!/T WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) -!/WRST ! For WRST switch read only corrected SWH -!/WRST ! Wind will have been read from the restart -!/WRST IF (WRSTON) THEN -!/WRST CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) -!/WRST ELSE +#ifdef W3_T + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#endif +#ifdef W3_WRST + ! For WRST switch read only corrected SWH + ! Wind will have been read from the restart + IF (WRSTON) THEN + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + ELSE +#endif CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) -!/WRST ENDIF -!/T CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#ifdef W3_WRST + ENDIF +#endif +#ifdef W3_T + CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#endif ELSE WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif STOP END IF ! -!/WRST !Calculate wind speed and direction values from u,v.. -!/WRST !..using cartesian direction convention -!/WRST !At present assume only needed for data read from restart -!/WRST CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#ifdef W3_WRST + !Calculate wind speed and direction values from u,v.. + !..using cartesian direction convention + !At present assume only needed for data read from restart + CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#endif ! ! Calculation DO ISEA=1, NSEA, 1 @@ -771,19 +861,21 @@ PROGRAM W3UPRSTR IY = MAPSF(ISEA,2) IXW = IX IYW = IY -!/SMC ELSE -!/SMC IX = 1 -!/SMC IY = ISEA -!/SMC IF( SMCWND ) THEN -!/SMC ! Wind arrays allocated using (X,Y) convention for regular grids -!/SMC ! but overriding here for the SMC grid which are always defined -!/SMC ! as (NSEA,1) by switching the IY and IX dimension values around -!/SMC IXW = IY -!/SMC IYW = IX -!/SMC ELSE -!/SMC IXW = MAPSF(ISEA,1) -!/SMC IYW= MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ELSE + IX = 1 + IY = ISEA + IF( SMCWND ) THEN + ! Wind arrays allocated using (X,Y) convention for regular grids + ! but overriding here for the SMC grid which are always defined + ! as (NSEA,1) by switching the IY and IX dimension values around + IXW = IY + IYW = IX + ELSE + IXW = MAPSF(ISEA,1) + IYW= MAPSF(ISEA,2) + ENDIF +#endif ENDIF VATMP = VA(:,ISEA) CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & @@ -804,24 +896,32 @@ PROGRAM W3UPRSTR CALL CHECK_PRCNTG(PRCNTG,PRCNTG_CAP) CALL UPDATE_VA(PRCNTG,VATMP) END IF -!/T WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & -!/T ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & -!/T ' SWHANL = ', SWHANL(IY,IX) +#ifdef W3_T + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) +#endif VA(:,ISEA)=VATMP -!/T CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) -!/T SWHUPRSTR(IY,IX)=SWHTMP -!/T WRITE (NDSO,*) ' =========== UPD5 Output ===========' -!/T WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & -!/T 'SWH_ANL = ', SWHANL(IY,IX), & -!/T 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#ifdef W3_T + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD5 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif END IF END DO -!/T CALL writeMatrix('SWHBCKG_UPD5.txt', REAL(SWHBCKG )) -!/T CALL writeMatrix('SWHANL_UPD5.txt' , REAL(SWHANL )) -!/T CALL writeMatrix('SWHRSTR_UPD5.txt', REAL(SWHUPRSTR)) +#ifdef W3_T + CALL writeMatrix('SWHBCKG_UPD5.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD5.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD5.txt', REAL(SWHUPRSTR)) +#endif ! DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif !/ !/ ------------------------------------------------------------------- / ! UPD6 @@ -850,47 +950,63 @@ PROGRAM W3UPRSTR ! Wind arrays allocated using X,Y convention as in w3idatmd ALLOCATE( WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) ALLOCATE( WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1)) ) -!/SMC ELSE -!/SMC ALLOCATE( SWHBCKG(NSEA,1) ) -!/SMC ALLOCATE( SWHANL(NSEA,1) ) -!/SMC ! Use SMCWND to determine if reading a seapoint aray for wind -!/SMC IF( SMCWND ) THEN -!/SMC ALLOCATE( WSBCKG(NSEA,1) ) -!/SMC ALLOCATE( WDRBCKG(NSEA,1) ) -!/SMC ELSE -!/SMC ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) -!/SMC ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) -!/SMC ENDIF +#ifdef W3_SMC + ELSE + ALLOCATE( SWHBCKG(NSEA,1) ) + ALLOCATE( SWHANL(NSEA,1) ) + ! Use SMCWND to determine if reading a seapoint aray for wind + IF( SMCWND ) THEN + ALLOCATE( WSBCKG(NSEA,1) ) + ALLOCATE( WDRBCKG(NSEA,1) ) + ELSE + ALLOCATE(WSBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ALLOCATE(WDRBCKG(SIZE(MAPSTA,2), SIZE(MAPSTA,1))) + ENDIF +#endif ENDIF -!/T IF (.NOT. SMCGRD) THEN -!/T ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) -!/T ELSE -!/T ALLOCATE( SWHUPRSTR(NSEA,1) ) -!/T ENDIF +#ifdef W3_T + IF (.NOT. SMCGRD) THEN + ALLOCATE( SWHUPRSTR(SIZE(MAPSTA,1), SIZE(MAPSTA,2)) ) + ELSE + ALLOCATE( SWHUPRSTR(NSEA,1) ) + ENDIF +#endif ! ! Read additional Input: Analysis Field INQUIRE(FILE=FLNMANL, EXIST=anl_exists) IF (anl_exists) THEN -!/T WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) -!/WRST ! For WRST switch read only corrected SWH -!/WRST ! Wind will have been read from the restart -!/WRST IF (WRSTON) THEN -!/WRST CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) -!/WRST ELSE +#ifdef W3_T + WRITE (NDSO,*) 'shape(SWHANL)', shape(SWHANL) +#endif +#ifdef W3_WRST + ! For WRST switch read only corrected SWH + ! Wind will have been read from the restart + IF (WRSTON) THEN + CALL READ_GRBTXT(SWHANL, FLNMANL, SMCGRD) + ELSE +#endif CALL READ_GRBTXTWS(SWHANL,WSBCKG,WDRBCKG,FLNMANL,SMCGRD) -!/WRST ENDIF -!/T CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#ifdef W3_WRST + ENDIF +#endif +#ifdef W3_T + CALL writeMatrix('SWHANL_IN.txt',SWHANL) +#endif ELSE WRITE (NDSO,*) trim(FLNMANL), ' does not exist, stopping...' DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif STOP END IF ! -!/WRST !Calculate wind speed and direction values from u,v.. -!/WRST !..using cartesian direction convention -!/WRST !At present assume only needed for data read from restart -!/WRST CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#ifdef W3_WRST + !Calculate wind speed and direction values from u,v.. + !..using cartesian direction convention + !At present assume only needed for data read from restart + CALL UVTOCART(WXNwrst,WYNwrst,WSBCKG,WDRBCKG,SMCWND) +#endif ! ! Calculation DO ISEA=1, NSEA, 1 @@ -899,19 +1015,21 @@ PROGRAM W3UPRSTR IY = MAPSF(ISEA,2) IXW = IX IYW = IY -!/SMC ELSE -!/SMC IX = 1 -!/SMC IY = ISEA -!/SMC IF( SMCWND ) THEN -!/SMC ! Wind arrays allocated using (X,Y) convention for regular grids -!/SMC ! but overriding here for the SMC grid which are always defined -!/SMC ! as (NSEA,1) by switching the IY and IX dimension values around -!/SMC IXW = IY -!/SMC IYW = IX -!/SMC ELSE -!/SMC IXW = MAPSF(ISEA,1) -!/SMC IYW = MAPSF(ISEA,2) -!/SMC ENDIF +#ifdef W3_SMC + ELSE + IX = 1 + IY = ISEA + IF( SMCWND ) THEN + ! Wind arrays allocated using (X,Y) convention for regular grids + ! but overriding here for the SMC grid which are always defined + ! as (NSEA,1) by switching the IY and IX dimension values around + IXW = IY + IYW = IX + ELSE + IXW = MAPSF(ISEA,1) + IYW = MAPSF(ISEA,2) + ENDIF +#endif ENDIF VATMP = VA(:,ISEA) CALL SWH_RSRT_1pw (VATMP, WSBCKG(IXW,IYW), WDRBCKG(IXW,IYW), ISEA, & @@ -938,24 +1056,32 @@ PROGRAM W3UPRSTR CALL UPDATE_VA(PRCNTG,VATMP) END IF END IF -!/T WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & -!/T ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & -!/T ' SWHANL = ', SWHANL(IY,IX) +#ifdef W3_T + WRITE (NDSO,*) 'ISEA = ', ISEA,' IX = ',IX,' IY = ', IY, & + ' PRCNTG = ',PRCNTG,' SWHBCKG = ',SWHBCKG(IY,IX), & + ' SWHANL = ', SWHANL(IY,IX) +#endif VA(:,ISEA)=VATMP -!/T CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) -!/T SWHUPRSTR(IY,IX)=SWHTMP -!/T WRITE (NDSO,*) ' =========== UPD6 Output ===========' -!/T WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & -!/T 'SWH_ANL = ', SWHANL(IY,IX), & -!/T 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#ifdef W3_T + CALL SWH_RSRT_1p (VATMP, ISEA, SWHTMP) + SWHUPRSTR(IY,IX)=SWHTMP + WRITE (NDSO,*) ' =========== UPD6 Output ===========' + WRITE (NDSO,*)'ISEA = ',ISEA,'SWH_BCKG = ', SWHBCKG(IY,IX), & + 'SWH_ANL = ', SWHANL(IY,IX), & + 'SWH_RSTR = ',SWHUPRSTR(IY,IX) +#endif END IF END DO -!/T CALL writeMatrix('SWHBCKG_UPD6.txt', REAL(SWHBCKG )) -!/T CALL writeMatrix('SWHANL_UPD6.txt' , REAL(SWHANL )) -!/T CALL writeMatrix('SWHRSTR_UPD6.txt', REAL(SWHUPRSTR)) +#ifdef W3_T + CALL writeMatrix('SWHBCKG_UPD6.txt', REAL(SWHBCKG )) + CALL writeMatrix('SWHANL_UPD6.txt' , REAL(SWHANL )) + CALL writeMatrix('SWHRSTR_UPD6.txt', REAL(SWHUPRSTR)) +#endif ! DEALLOCATE( SWHANL,VATMP,SWHBCKG,VAMAPWS,WSBCKG,WDRBCKG ) -!/T DEALLOCATE( SWHUPRSTR ) +#ifdef W3_T + DEALLOCATE( SWHUPRSTR ) +#endif !/ !/ ------------------------------------------------------------------- / ! End of update options @@ -965,14 +1091,18 @@ PROGRAM W3UPRSTR !/ ------------------------------------------------------------------- / ! 6. Write updated restart file !/ -!/WRST ! Copy read wind values from restart for write out -!/WRST WXN = WXNwrst -!/WRST WYN = WYNwrst +#ifdef W3_WRST + ! Copy read wind values from restart for write out + WXN = WXNwrst + WYN = WYNwrst +#endif WRITE (NDSO,903) RSTYPE = 3 CALL W3IORS ( 'HOT', NDS(6), SIG(NK), 1 ) -!/T WRITE (NDST,*), MYNAME,' : Exporting VA at the end of the re-analysis' -!/T CALL writeMatrix('VA02.txt', REAL(VA)) +#ifdef W3_T + WRITE (NDST,*), MYNAME,' : Exporting VA at the end of the re-analysis' + CALL writeMatrix('VA02.txt', REAL(VA)) +#endif ! !/ !/ ------------------------------------------------------------------- / @@ -1158,23 +1288,35 @@ SUBROUTINE CHECK_PRCNTG (PRCNTG,PRCNTG_CAP) REAL, INTENT(IN ) :: PRCNTG_CAP ! local CHARACTER(12), PARAMETER :: MYNAME='CHECK_PRCNTG' -!/T -!/T WRITE (NDSO,*) trim(MYNAME)," The original correction is ",PRCNTG -!/T WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP +#ifdef W3_T + + WRITE (NDSO,*) trim(MYNAME)," The original correction is ",PRCNTG + WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP +#endif IF ( PRCNTG_CAP < 1. ) THEN WRITE (NDSO,*) trim(MYNAME)," WARNING: PRCNTG_CAP set < 1." WRITE (NDSO,*) trim(MYNAME)," This may introduce spurious corrections" END IF -!/T WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP +#ifdef W3_T + WRITE (NDSO,*) trim(MYNAME)," The cap is ",PRCNTG_CAP +#endif IF ( PRCNTG > 1. ) THEN -!/T WRITE (NDSO,*) trim(MYNAME)," PRCNTG > 1." +#ifdef W3_T + WRITE (NDSO,*) trim(MYNAME)," PRCNTG > 1." +#endif PRCNTG = MIN(PRCNTG, 1. * PRCNTG_CAP) ELSE IF ( PRCNTG < 1. ) THEN -!/T WRITE (NDSO,*) trim(MYNAME)," PRCNTG < 1." +#ifdef W3_T + WRITE (NDSO,*) trim(MYNAME)," PRCNTG < 1." +#endif PRCNTG = MAX(PRCNTG, 1. / PRCNTG_CAP) -!/T +#ifdef W3_T + +#endif END IF -!/T WRITE (NDSO,*) trim(MYNAME)," The updated correction is ",PRCNTG +#ifdef W3_T + WRITE (NDSO,*) trim(MYNAME)," The updated correction is ",PRCNTG +#endif ! END SUBROUTINE CHECK_PRCNTG !/ @@ -1237,7 +1379,9 @@ SUBROUTINE READ_GRBTXT(UPDPRCNT,FLNMCOR,SMCGRD) INTEGER, PARAMETER :: IP_FID = 123 CHARACTER(25), PARAMETER::myname='read_grbtxt' ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif J = LEN_TRIM(FNMPRE) OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & ,ACTION='read',IOSTAT=IERR) @@ -1250,13 +1394,15 @@ SUBROUTINE READ_GRBTXT(UPDPRCNT,FLNMCOR,SMCGRD) 'dimensions: M=',M,' N=',N STOP END IF -!/SMC ELSE -!/SMC READ( IP_FID, *) N -!/SMC IF ( SIZE(UPDPRCNT,1) /= N ) THEN -!/SMC WRITE (NDSO,*) trim(myname),': These are not the grid ' // & -!/SMC 'dimensions: N=',N -!/SMC STOP -!/SMC END IF +#ifdef W3_SMC + ELSE + READ( IP_FID, *) N + IF ( SIZE(UPDPRCNT,1) /= N ) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: N=',N + STOP + END IF +#endif END IF UPDPRCNT=0 ! @@ -1269,17 +1415,21 @@ SUBROUTINE READ_GRBTXT(UPDPRCNT,FLNMCOR,SMCGRD) UPDPRCNT(N+1-L,K)=A END DO END DO -!/SMC ELSE -!/SMC DO L=1,N -!/SMC A=0. -!/SMC READ(IP_FID,*)A -!/SMC UPDPRCNT(L,1)=A -!/SMC END DO +#ifdef W3_SMC + ELSE + DO L=1,N + A=0. + READ(IP_FID,*)A + UPDPRCNT(L,1)=A + END DO +#endif END IF ! CLOSE(IP_FID) ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE READ_GRBTXT !/ !/ ------------------------------------------------------------------- / @@ -1340,7 +1490,9 @@ SUBROUTINE READ_GRBTXTWS(UPDPRCNT,WSPD,WDIR,FLNMCOR,SMCGRD) INTEGER, PARAMETER :: IP_FID = 123 CHARACTER(25), PARAMETER::myname='read_grbtxt' ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif J = LEN_TRIM(FNMPRE) OPEN (IP_FID,FILE=FNMPRE(:J)//TRIM(FLNMCOR),STATUS='OLD' & ,ACTION='read',IOSTAT=IERR) @@ -1353,13 +1505,15 @@ SUBROUTINE READ_GRBTXTWS(UPDPRCNT,WSPD,WDIR,FLNMCOR,SMCGRD) 'dimensions: M=',M,' N=',N STOP END IF -!/SMC ELSE -!/SMC READ( IP_FID, *) N -!/SMC IF ( SIZE(UPDPRCNT,1) /= N ) THEN -!/SMC WRITE (NDSO,*) trim(myname),': These are not the grid ' // & -!/SMC 'dimensions: N=',N -!/SMC STOP -!/SMC END IF +#ifdef W3_SMC + ELSE + READ( IP_FID, *) N + IF ( SIZE(UPDPRCNT,1) /= N ) THEN + WRITE (NDSO,*) trim(myname),': These are not the grid ' // & + 'dimensions: N=',N + STOP + END IF +#endif END IF UPDPRCNT=0 WSPD=0. @@ -1380,20 +1534,24 @@ SUBROUTINE READ_GRBTXTWS(UPDPRCNT,WSPD,WDIR,FLNMCOR,SMCGRD) WDIR(K,N+1-L)=WD END DO END DO -!/SMC ELSE -!/SMC DO L=1,N -!/SMC A=0. -!/SMC READ(IP_FID,*)A, WS, WD -!/SMC UPDPRCNT(L,1)=A -!/SMC WSPD(L,1)=WS -!/SMC WDIR(L,1)=WD -!/SMC END DO +#ifdef W3_SMC + ELSE + DO L=1,N + A=0. + READ(IP_FID,*)A, WS, WD + UPDPRCNT(L,1)=A + WSPD(L,1)=WS + WDIR(L,1)=WD + END DO +#endif ENDIF ! CLOSE(IP_FID) ! ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE READ_GRBTXTWS !/ !/ ------------------------------------------------------------------- / @@ -1448,8 +1606,10 @@ SUBROUTINE SWH_RSRT_1p (VA1p, ISEA1p, HSIG1p ) REAL, DIMENSION(:), INTENT(IN) :: VA1p CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1p' ! -!/FT WRITE (NDSO,*)' ' -!/FT WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_FT + WRITE (NDSO,*)' ' + WRITE (NDSO,*) trim(myname), ' starts' +#endif HSIG1p = 0. DEPTH = MAX ( DMIN , -ZB(ISEA1p) ) ETOT = 0. @@ -1465,8 +1625,10 @@ SUBROUTINE SWH_RSRT_1p (VA1p, ISEA1p, HSIG1p ) ! HSIG1p = 4. * SQRT ( ETOT * DTH ) ! -!/FT WRITE (NDSO,*) ' ', trim(myname), ' ends' -!/FT WRITE (NDSO,*)' ' +#ifdef W3_FT + WRITE (NDSO,*) ' ', trim(myname), ' ends' + WRITE (NDSO,*)' ' +#endif END SUBROUTINE SWH_RSRT_1p !/ !/ ------------------------------------------------------------------- / @@ -1529,7 +1691,9 @@ SUBROUTINE SWH_RSRT_1pw (VA1p, WS, WD, ISEA1p, HSIG1p, HSIGwp, HSIGsp, VAMAPWS ) REAL :: RELWS, ETOTw, ETOTs, EwI, EsI CHARACTER(25),PARAMETER :: myname='SWH_RSRT_1pw' ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif HSIG1p = 0. HSIGwp = 0. HSIGsp = 0. @@ -1565,7 +1729,9 @@ SUBROUTINE SWH_RSRT_1pw (VA1p, WS, WD, ISEA1p, HSIG1p, HSIGwp, HSIGsp, VAMAPWS ) HSIGwp = 4. * SQRT ( ETOTw * DTH ) HSIGsp = 4. * SQRT ( ETOTs * DTH ) ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE SWH_RSRT_1pw !/ !/ ------------------------------------------------------------------- / @@ -1622,15 +1788,19 @@ SUBROUTINE UVTOCART (UVEC, VVEC, SPD, DCART, SMCGRD) REAL, DIMENSION(:,:), INTENT(IN) :: UVEC, VVEC LOGICAL, INTENT(IN) :: SMCGRD ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif ! DO ISEA=1, NSEA, 1 IF (.NOT. SMCGRD) THEN IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) -!/SMC ELSE -!/SMC IX = 1 -!/SMC IY = ISEA +#ifdef W3_SMC + ELSE + IX = 1 + IY = ISEA +#endif ENDIF ! SPD(IY,IX) = SQRT( UVEC(IY,IX)**2 + VVEC(IY,IX)**2 ) @@ -1642,7 +1812,9 @@ SUBROUTINE UVTOCART (UVEC, VVEC, SPD, DCART, SMCGRD) SPD(IY,IX) = MAX( SPD(IY,IX) , 0.001 ) END DO ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE UVTOCART !/ !/ ------------------------------------------------------------------- / @@ -1698,7 +1870,9 @@ SUBROUTINE UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) REAL, INTENT(IN) :: PRCNTG CHARACTER(25),PARAMETER :: myname='UPDTWSPEC' ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif DO IK=1, NK DO ITH=1, NTH IF ( VAMAPWS(ITH+(IK-1)*NTH) .EQ. 1 ) THEN @@ -1707,7 +1881,9 @@ SUBROUTINE UPDTWSPEC(VATMP, PRCNTG, VAMAPWS) END DO END DO ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE UPDTWSPEC !/ !/ ------------------------------------------------------------------- / @@ -1769,7 +1945,9 @@ SUBROUTINE UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA1p, ADJALL) INTEGER :: LPF, M1, M2 REAL, ALLOCATABLE :: VASHFT(:) ! -!/T WRITE (NDSO,*) trim(myname), ' starts' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' starts' +#endif DEPTH = MAX( DMIN , -ZB(ISEA1p)) ALLOCATE(VASHFT(SIZE(VATMP))) VASHFT(:) = 0.0 @@ -1853,7 +2031,9 @@ SUBROUTINE UPDTWSPECF(VATMP, PRCNTG, VAMAPWS, ISEA1p, ADJALL) ! DEALLOCATE(VASHFT) ! -!/T WRITE (NDSO,*) trim(myname), ' ends' +#ifdef W3_T + WRITE (NDSO,*) trim(myname), ' ends' +#endif END SUBROUTINE UPDTWSPECF !/ !/ ------------------------------------------------------------------- / diff --git a/model/tools/w3adc.f b/model/tools/w3adc.f deleted file mode 100644 index c1fcddf6d..000000000 --- a/model/tools/w3adc.f +++ /dev/null @@ -1,625 +0,0 @@ - PROGRAM W3ADC -C/ -C/ +-----------------------------------+ -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 03-Feb-2020 | -C/ +-----------------------------------+ -C/ -C/ 05-Jan-2001 : Origination -C/ 03-Feb-2020 : Added ability to process multiple ( version 7.00 ) -C/ switches on a single line. Chris Bunney, UKMO -C/ -C/ Version to preprocess FORTRAN 90 free format code. -C/ -C 1. Purpose : -C -C Pre-processing of FORTRAN files by switching on and off of -C selected lines and by including COMMONs. -C -C - Based on ADCOM by N. Booij, -C Delft University of Technology. -C - Refinement of WWADC -C - FORTRAN 90 compatible -C -C 2. Method : -C -C From standard input the following data are read: -C - Test indicator and compress indicator ( 1 line ). -C - File name of the input and output code ( 1 line ). -C - Switches to be turned on ( 1 line ). -C - Include string and file name ( n lines ). -C -C where : -C -C test indicator : 0 : no test output -C >0 : (more) test output -C compress ind. : 0 : no file compression -C 1 : Remove comments except for empty switches. -C 2 : Remove all comment. -C -C Output is read using free format, so quotes are needed around -C strings. Echo and test output is send to the standard output -C device. Switches can be up to NLSWTC characters long, and are -C separated by spaces. -C -C 3. Parameters : -C -C Data in PARAMETER statements : -C ---------------------------------------------------------------- -C MMLOUT Int. Line length of output. -C MMSWTC Int. Maximum number of switches. -C MMSWLN Int. Maximum number of switches on a single line. -C MMFILE Int. Maximum number of include files. -C MMLINE Int. Maximum length of include files. -C ---------------------------------------------------------------- -C -C Internal data : -C ---------------------------------------------------------------- -C ITEST Int. Test indicator (see section 2). -C ICOMP Int. Compression indicator (see section 2). -C NSWTCH Int. Number of switches (total). -C NLSWTC Int. Maximum length of switches. -C NFILES Int. Number of include files. -C NLINES I.A. Length of include files. -C IDLEN I.A. Length of ID string for include file. -C MMLNGT Int. Maximum length of include files. -C ---------------------------------------------------------------- -C -C 4. Subroutines used : -C -C None. -C -C 5. Called by : -C -C None (stand alone program). -C -C 6. Error messages : -C -C - Checks on array sizes. -C - Open errors on files. -C -C 7. Remarks : -C -C - Switches are case-sensitive -C - Switch in code has to be followed by space, forward slash (/) or -C exclamation mark (!) -C - Multiple switches can appear on a single line, seperated by -C a forward slash or exclamation mark. In this case all switches -C need to be present in switch file for the line to be included. -C - Switches can be used in include files, since include files are -C are pre-processed before the actual file is processed. Includes -C in include files, however, are not accepted. -C - By dealing with swtiches before looking for include files, -C the inclusion of files can be governed by switches. -C - Variable record lengths used by looking for last non-blank. -C - ID string for inclusion of file can be anything, and may -C include blanks. -C -C 8. Structure : -C -C ===================================================== -C Initializations -C Read from standard input and proparations -C ---------------------------------------------------- -C ITEST and ICOMP -C Read names of input and output files and open -C Read and process switches. -C Process include files -C ------------------------------------------------ -C Get and store ID string -C Preprocess include file -C ---------------------------------------------- -C Process switches -C Check for keeping of line (compress) -C Determine line lengths -C ===================================================== -C Actual processing -C For every line do -C ---------------------------------------------------- -C Process switches -C Check for include files -C If no include -C -------------------------------------------------- -C Check for keeping of line (compress) -C Determine actual line length -C Write line -C ===================================================== -C -C 9. Source code : -C -* ---------------------------------------------------------------------- -* - PARAMETER ( MMLOUT = 132 ) - PARAMETER ( MMFILE = 30 ) - PARAMETER ( MMSWTC = 52 ) - PARAMETER ( MMSWLN = 4 ) - PARAMETER ( MMLINE = 200 ) -* - INTEGER NSWTCH, IDLEN(MMFILE), NLINES(MMFILE), LL, NSWLN, - & LENGTH(MMFILE,MMLINE), NINCF(MMFILE), LS(MMSWTC) - LOGICAL FLOLD, FLKEEP, FLINCL, FLSWTC, LSTEXC, NOWEXC, - & QUOTES -* - CHARACTER*20 TEST0, TSTSTR - CHARACTER*500 FNAMEI, FNAMEO, FNAMER - CHARACTER*72 INSTR - CHARACTER*176 NEWLNE, OLDLNE - CHARACTER*200 SWTCHS - CHARACTER*33 NOLINE - CHARACTER SWITCH*8, SW0*8 - DIMENSION SWITCH(MMSWTC), TSTSTR(MMFILE), INSTR(MMFILE,MMLINE) -* -* initialisations -* - NOLINE = '. . . . . . . . . . . ' -* -* set test parameters -------------------------------------------------- -* - NLSWTC = LEN(SWITCH(1)) -* - READ (*,*) ITEST, ICOMP - ITEST = MAX ( ITEST , 0 ) - ICOMP = MIN ( MAX(ICOMP,0) , 2 ) - WRITE (*,900) ITEST, ICOMP -* -* Read file names ------------------------------------------------------ -* - READ (*,*) FNAMEI, FNAMEO - NDSIN = 10 - NDSOUT = 11 - WRITE (*,910) FNAMEI, FNAMEO -* - OPEN (NDSIN ,FILE=FNAMEI,ERR=801,STATUS='OLD') - OPEN (NDSOUT,FILE=FNAMEO,ERR=802) -* -* Read switches -------------------------------------------------------- -* - READ (*,*) SWTCHS - NSWTCH = 0 - FLOLD = .FALSE. -* - DO 100, I=1, 200 - IF (SWTCHS(I:I).NE.' ') THEN - IF ( FLOLD ) THEN - J = J + 1 - IF (J.GT.NLSWTC) THEN - WRITE (*,*) '*** ERROR: SWITCH TOO LONG' - STOP - ENDIF - SW0(J:J) = SWTCHS(I:I) - ELSE - IF (NSWTCH+1.GT.MMSWTC) THEN - WRITE (*,*) '*** ERROR: TOO MANY SWITCHES' - STOP - ENDIF - NSWTCH = NSWTCH + 1 - J = 1 - SW0(1:1) = SWTCHS(I:I) - FLOLD = .TRUE. - ENDIF - ELSE - IF ( FLOLD ) THEN - SWITCH(NSWTCH) = SW0(1:J) - LS (NSWTCH) = J - ENDIF - FLOLD = .FALSE. - ENDIF - 100 CONTINUE -* - IF ( FLOLD ) THEN - SWITCH(NSWTCH) = SW0(1:J) - LS (NSWTCH) = J - ENDIF -* - WRITE (*,920) NSWTCH - IF (ITEST.EQ.0) THEN - WRITE (*,921) (SWITCH(I),I=1,NSWTCH) - ELSE - DO 90, J=1, NSWTCH - SW0 = SWITCH(J) - WRITE (*,922) J, SW0(1:LS(J)) - 90 CONTINUE - ENDIF -* -* get include files ---------------------------------------------------- -* - NDSINC = 50 - NFILES = 0 - WRITE (*,930) - 110 CONTINUE - READ (*,*,END=200,ERR=200) TEST0, FNAMER - NFILES = NFILES + 1 - NINCF(NFILES) = 0 - IF (NFILES.GT.MMFILE) THEN - WRITE (*,*) '*** ERROR: TOO MANY INCLUDE FILES' - STOP - ENDIF - IF (ITEST.GE.3) WRITE (*,9930) TEST0, FNAMER -* -* store ID string and determine its length - - - - - - - - - - - - - - - -* - TSTSTR(NFILES) = TEST0 - DO 120 J=LEN(TEST0),1,-1 - IDLEN(NFILES) = J - IF (TEST0(J:J).NE.' ') GOTO 121 - 120 CONTINUE - 121 CONTINUE - IF (ITEST.GE.2) WRITE (*,9931) IDLEN(NFILES) -* -* (pre-) process include file - - - - - - - - - - - - - - - - - - - - - -* - ILINE1 = 0 - ILINE2 = 0 - NDSINC = NDSINC+1 - OPEN (NDSINC,FILE=FNAMER,ERR=803,STATUS='OLD') - LSTEXC = .FALSE. - 130 CONTINUE - READ (NDSINC,'(A)',END=190,ERR=190) NEWLNE - OLDLNE = NEWLNE - ILINE1 = ILINE1 + 1 -* -* switches -* - FLKEEP = .TRUE. - FLSWTC = .FALSE. -* - ! Rewrite for multiple switches on single line - ! Chris Bunney, Feb 2020. - NSWLN = 0 - DO 140 - IF(NSWLN .GT. MMSWLN) THEN - WRITE(*,9950) ILINE1, TRIM(FNAMER), TRIM(OLDLNE) - STOP - ENDIF - IF(NEWLNE(1:2) .EQ. '!/') THEN - ! Potential switch - FLSWTC = .FALSE. - FLKEEP = .FALSE. -* - ! Check if just a comment - IF ( NEWLNE(3:3) .EQ. ' ' ) THEN - FLSWTC = .TRUE. - GOTO 142 ! Assumes no more switches - ENDIF -* - ! Check if is an activated switch: - DO 141, I=1, NSWTCH - SW0 = SWITCH(I) - J = LS(I) - IF(NEWLNE(3:2+J) .EQ. SW0(1:J)) THEN -* - IF(NEWLNE(3+J:3+J) .EQ. ' ' .OR. - & NEWLNE(3+J:3+J) .EQ. '!') THEN - NEWLNE(1:MMLOUT) = NEWLNE(3+J:MMLOUT+3+J-1) - FLSWTC = .TRUE. - NSWLN = NSWLN + 1 - GOTO 140 - ENDIF -* - IF(NEWLNE(3+J:3+J) .EQ. '/' ) THEN - NEWLNE(1:MMLOUT) = NEWLNE(4+J:MMLOUT+4+J-1) - FLSWTC = .TRUE. - NSWLN = NSWLN + 1 - GOTO 140 - ENDIF -* - ENDIF - 141 CONTINUE ! ENDDO -* - ! No match found for switch - don't include line - FLSWTC = .FALSE. - GOTO 142 - ELSE - ! No more switches, break out of do loop - GOTO 142 - ENDIF -* - 140 CONTINUE ! ENDDO - 142 CONTINUE ! ESCAPE -* -* keep line ... -* - FLKEEP = FLKEEP .OR. FLSWTC -* - IF (ICOMP.GE.1) FLKEEP = FLSWTC .OR. .NOT. (NEWLNE(1:1).EQ.'!') - IF (ICOMP.GT.1) FLKEEP = FLKEEP .AND. (NEWLNE(1:2).NE.'!/') -* - IF ( FLKEEP ) THEN - DO 150 J=MMLOUT,1,-1 - LL = J - IF (NEWLNE(J:J).NE.' ') GOTO 151 - 150 CONTINUE - 151 CONTINUE -* - IF ( ICOMP.NE.0 .AND. .NOT.FLSWTC ) THEN - QUOTES = .FALSE. - DO 155 J=1,LL - IF (.NOT.QUOTES .AND. NEWLNE(J-1:J-1).EQ.'!') GOTO 156 - IF (NEWLNE(J-1:J-1).EQ.'''') QUOTES = .NOT. QUOTES - 155 CONTINUE - 156 CONTINUE - LL = MIN ( J , LL ) - ENDIF -* - ENDIF -* - NOWEXC = NEWLNE(1:1).EQ.'!' .AND. LL.EQ.1 - FLKEEP = FLKEEP .AND. .NOT. (LSTEXC.AND.NOWEXC) -* - IF (FLKEEP) THEN - LSTEXC = NOWEXC - ILINE2 = ILINE2 + 1 - IF (ILINE2.GT.MMLINE) THEN - WRITE (*,*) '*** ERROR: TOO MANY INCLUDE LINES' - STOP - ENDIF - INSTR(NFILES,ILINE2) = NEWLNE(1:MMLOUT) -* -* line length -* - LENGTH(NFILES,ILINE2) = LL - ENDIF -* -* next line -* - GOTO 130 - 190 CONTINUE - NLINES(NFILES) = ILINE2 - WRITE (*,931) TEST0, FNAMER, ILINE1, ILINE2 -* - IF (ITEST.GE.2) THEN - WRITE (*,9932) FNAMER - DO 191, I=1,NLINES(NFILES) - IF (ITEST.GE.3) THEN - WRITE (*,9933) INSTR(NFILES,I)(1:LENGTH(NFILES,I)), - & ('.',J=LENGTH(NFILES,I)+1,72), '|' - ELSE - WRITE (*,9933) INSTR(NFILES,I)(1:72), '|' - ENDIF - 191 CONTINUE - WRITE (*,9934) - ENDIF -* -* next include file -* - GOTO 110 - 200 CONTINUE - IF (ITEST.GE.2) THEN - WRITE (*,9999) - STOP - ENDIF -* -* Preprocessing finished, start processing file ------------------------ -* - NINP = 0 - NOUT = 0 - NINCL = 0 - LSTEXC = .FALSE. - IF (ITEST.GE.1) WRITE (*,9940) - 300 CONTINUE - READ (NDSIN ,'(A)',END=400,ERR=400) NEWLNE - NINP = NINP + 1 -* - OLDLNE = NEWLNE -* -* switches -* - FLKEEP = .TRUE. - FLSWTC = .FALSE. -* - ! Rewrite for multiple switches on single line - ! Chris Bunney, Feb 2020. - NSWLN = 0 - DO 310 - IF(NSWLN .GT. MMSWLN) THEN - WRITE(*,9950) ILINE1, TRIM(FNAMEI), TRIM(OLDLNE) - STOP - ENDIF - IF(NEWLNE(1:2) .EQ. '!/') THEN - ! Potential switch - FLSWTC = .FALSE. - FLKEEP = .FALSE. -* - ! Check if just a comment - IF ( NEWLNE(3:3) .EQ. ' ' ) THEN - FLSWTC = .TRUE. - GOTO 312 ! Assumes no more switches - ENDIF -* - ! Check if is an activated switch: - DO 311, I=1, NSWTCH - SW0 = SWITCH(I) - J = LS(I) - IF(NEWLNE(3:2+J) .EQ. SW0(1:J)) THEN -* - IF(NEWLNE(3+J:3+J) .EQ. ' ' .OR. - & NEWLNE(3+J:3+J) .EQ. '!') THEN - NEWLNE(1:MMLOUT) = NEWLNE(3+J:MMLOUT+3+J-1) - FLSWTC = .TRUE. - NSWLN = NSWLN + 1 - GOTO 310 - ENDIF -* - IF(NEWLNE(3+J:3+J) .EQ. '/' ) THEN - NEWLNE(1:MMLOUT) = NEWLNE(4+J:MMLOUT+4+J-1) - FLSWTC = .TRUE. - NSWLN = NSWLN + 1 - GOTO 310 - ENDIF -* - ENDIF - 311 CONTINUE ! ENDDO -* - ! No match found for switch - don't include line - FLSWTC = .FALSE. - GOTO 312 - ELSE - ! No more switches, break out of do loop - GOTO 312 - ENDIF -* - 310 CONTINUE ! ENDDO - 312 CONTINUE ! ESCAPE -* -* include ??? -* - FLINCL = .FALSE. - DO 330, J=1, NFILES - IF (NEWLNE(1:IDLEN(J)).EQ.TSTSTR(J)(1:IDLEN(J))) THEN - IF (ITEST.GE.1) THEN - WRITE (*,9941) OLDLNE, NOLINE - NOLINE(1 :32) = NOLINE( 2:33) - NOLINE(33:33) = NOLINE( 3: 3) - ENDIF - DO 320, I=1,NLINES(J) - WRITE (NDSOUT,'(A)') INSTR(J,I)(1:LENGTH(J,I)) - 320 CONTINUE - IF (ITEST.GE.1) THEN - DO 321, I=1,NLINES(J) - WRITE (*,9941) NOLINE, INSTR(J,I) - NOLINE(1 :32) = NOLINE( 2:33) - NOLINE(33:33) = NOLINE( 3: 3) - 321 CONTINUE - ENDIF - FLINCL = .TRUE. - NINCL = NINCL + 1 - NINCF(J) = NINCF(J) + 1 - NOUT = NOUT + NLINES(J) - GOTO 331 - ENDIF - 330 CONTINUE - 331 CONTINUE -* -* keep line ... -* - IF (.NOT.FLINCL) THEN - FLKEEP = FLKEEP .OR. FLSWTC -* - IF (ICOMP.GE.1) FLKEEP = FLSWTC .OR. .NOT.(NEWLNE(1:1).EQ.'!') - IF (ICOMP.GT.1) FLKEEP = FLKEEP .AND. (NEWLNE(1:2).NE.'!/') -* - IF ( FLKEEP ) THEN - DO 350 J=MMLOUT,1,-1 - LL = J - IF (NEWLNE(J:J).NE.' ') GOTO 351 - 350 CONTINUE - 351 CONTINUE -* - IF ( ICOMP.NE.0 .AND. .NOT.FLSWTC ) THEN - QUOTES = .FALSE. - DO 355 J=1,LL - IF (.NOT.QUOTES .AND. NEWLNE(J-1:J-1).EQ.'!') - & GOTO 356 - IF (NEWLNE(J-1:J-1).EQ.'''') QUOTES = .NOT. QUOTES - 355 CONTINUE - 356 CONTINUE - LL = MIN ( J , LL ) - ENDIF -* - ENDIF -* - NOWEXC = NEWLNE(1:1).EQ.'!' .AND. LL.EQ.1 - FLKEEP = FLKEEP .AND. .NOT. (LSTEXC.AND.NOWEXC) -* - IF (FLKEEP) THEN - LSTEXC = NOWEXC -* -* write line -* - WRITE (NDSOUT,'(A)') NEWLNE(1:LL) - NOUT = NOUT + 1 - IF (ITEST.GE.1) WRITE (*,9941) OLDLNE, NEWLNE -* - ELSE IF (ITEST.GE.1) THEN - WRITE (*,9941) OLDLNE, NOLINE - NOLINE(1 :32) = NOLINE( 2:33) - NOLINE(33:33) = NOLINE( 3: 3) - ENDIF - ENDIF -* -* next line -* - GOTO 300 - 400 CONTINUE -* -* End of processing ---------------------------------------------------- -* - IF (ITEST.GE.1) WRITE (*,9942) - WRITE (*,950) NINP, NOUT, NINCL - IF (NINCL.NE.0) THEN - WRITE (*,951) - DO 410, J=1, NFILES - IF (NINCF(J).NE.0) WRITE (*,952) NINCF(J), TSTSTR(J) - 410 CONTINUE - ENDIF -* - STOP ' ' -* -* Error escape locations -* - 801 CONTINUE - WRITE (*,*) '*** ERROR: OPENING INPUT FILE' - STOP -* - 802 CONTINUE - WRITE (*,*) '*** ERROR: OPENING OUTPUT FILE' - STOP -* - 803 CONTINUE - WRITE (*,*) '*** ERROR: OPENING INCLUDE FILE ', FNAMER - STOP -* -* Formats -* - 900 FORMAT (/' W3ADC, WAVEWATCH FORTRAN PREPROCESSING : '/ - & ' =========================================='// - & ' ITEST =',I4/ - & ' ICOMP =',I4) - 910 FORMAT ( ' INPUT FILE : ',A/ - & ' OUTPUT FILE : ',A) - 920 FORMAT ( ' NUMBER OF SWITCHES:',I4,' SWITCHES :') - 921 FORMAT ( ' ',8(A,1X)) - 922 FORMAT ( ' ',I4,' >',A,'<') - 930 FORMAT (/' INCLUDE FILES :'// - & ' ID_STRING FILENAME ', - & ' LINES '/ - & ' ----------------------------------', - & '---------------------------------------') - 931 FORMAT ( ' ',A20,2X,A40,2X,2I4) - 950 FORMAT (/' FINAL STATISTICS : '/ - & ' INPUT LINES :',I6/ - & ' OUTPUT LINES :',I6/ - & ' FILES INCLUDED :',I6,' TOTAL') - 951 FORMAT ( ' ------------------------', - & '--------------------') - 952 FORMAT ( ' ',I6,2X,A) -* - 9930 FORMAT ( ' TEST W3ADC/3 : ',A,2X,A) - 9931 FORMAT ( ' TEST W3ADC/3 : ',I10) - 9932 FORMAT ( ' TEST W3ADC/2 : INCULDE FILE ',A/ - & ' +------------------------------------', - & '------------------------------------+') - 9933 FORMAT ( ' |',73A) - 9934 FORMAT ( ' +------------------------------------', - & '------------------------------------+'/) - 9940 FORMAT (/' TEST W3ADC/1 '/ - & ' INPUT ', - & ' OUTPUT'/ - & ' +---------------------------------+ ', - & ' +---------------------------------+') - 9941 FORMAT ( ' |',A33,'| |',A33,'|') - 9942 FORMAT ( ' +---------------------------------+ ', - & ' +---------------------------------+') -* - 9950 FORMAT (/'*** ERROR: MAXIMUM NUMBER OF SWITCHES ON', - & ' INPUT LINE EXCEEDED ',/ - & ' LINE NUMBER: ', I5, / - & ' FILENAME: ', A, / - & ' LINE: ', A//) -* - 9999 FORMAT ( ' TEST W3ADC/2 : PROGRAM ENDED DUE TO VALUE OF ITEST'/) -* -* End of W3ADC -------------------------------------------------------- -* - END diff --git a/model/tools/w3list.f b/model/tools/w3list.f deleted file mode 100644 index e41f9b298..000000000 --- a/model/tools/w3list.f +++ /dev/null @@ -1,171 +0,0 @@ - PROGRAM W3LIST -C/ -C/ +-----------------------------------+ -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 17-Feb-1995 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Generate a line numbered source code listing, putting numbers -C on source code lines only. -C -C This is a modified version of w3prnt. See this program for -C documentation. -C -C Invert option disabled. -C ALLNUM read from standard input after file name. -C -C 9. Source code : -C -* ---------------------------------------------------------------------- -* - INTEGER MMLINE, NLPAGE, NOPAGE -* - PARAMETER ( MMLINE = 50000 ) - PARAMETER ( NLPAGE = 60 ) - PARAMETER ( NOPAGE = 55 ) -* - INTEGER NADD_1, NADD_2, N_HEAD, IERR, I, NL, NPAGE, - & IP, IL, IL1, ILN, ICHAR - LOGICAL ALLNUM - CHARACTER FILE*80, LINE*80, NOLINE*80, HEADER*79, - & FNAME*40, NULLST*1, PP*4 - DIMENSION FILE(MMLINE) -* -* initialisations ------------------------------------------------------ -* - NOLINE(01:40) = ' ' - NOLINE(41:80) = ' ' - NULLST = ' ' - NADD_1 = ( NLPAGE - NOPAGE -1 ) / 2 - NADD_2 = NLPAGE - NOPAGE - 1 - NADD_1 -* -* get file name -------------------------------------------------------- -* - READ (*,'(A)',ERR=800,IOSTAT=IERR) FNAME - READ (*,*,ERR=800,IOSTAT=IERR) ALLNUM - N_HEAD = LEN(FNAME) - DO 100, I=N_HEAD, 1, -1 - IF ( FNAME(I:I) .NE. ' ' ) THEN - N_HEAD = I - GOTO 101 - ENDIF - 100 CONTINUE - 101 CONTINUE - HEADER = NOLINE(1:79) - HEADER(70-N_HEAD:69) = FNAME(1:N_HEAD) - HEADER(72:75) = 'page' -* -* Open input file ------------------------------------------------------ -* - OPEN (10,FILE=FNAME,STATUS='OLD',ERR=802,IOSTAT=IERR) - REWIND (10) -* -* Read input file ------------------------------------------------------ -* - NL = 0 - 200 CONTINUE - READ (10,'(A)',END=201,ERR=803,IOSTAT=IERR) LINE - NL = NL + 1 - IF ( NL .GT. MMLINE ) THEN - WRITE (*,*) '*** ERROR : TOO MANY LINES' - STOP ' ' - ENDIF - FILE(NL) = LINE - GOTO 200 -* - 201 CONTINUE -* -* Numer of pages-------------------------------------------------------- -* - NPAGE = 1 + (NL-1)/NOPAGE - ILCODE = 0 -* -* Open output file ----------------------------------------------------- -* - OPEN (11,FILE='w3list.out',ERR=804,IOSTAT=IERR) -* -* Loop over pages ------------------------------------------------------ -* - DO 400, IP=1, NPAGE, 1 -* - WRITE (PP,'(I4)') IP - HEADER(76:79) = PP - ILN = IP * NOPAGE - IL1 = ILN + 1 - NOPAGE -* - WRITE (11,'(A)') HEADER - DO 300, IL=1, NADD_1 - WRITE (11,'(A)') NULLST - 300 CONTINUE -* - DO 350, IL=IL1, ILN - IF ( IL .LE. NL ) THEN - LINE = FILE(IL) - DO 310, I=80, 1, -1 - IF ( LINE(I:I) .NE. ' ' ) THEN - ICHAR = I - GOTO 311 - ENDIF - 310 CONTINUE - 311 CONTINUE - IF ( ICHAR .GT. 74 ) THEN - LINE(74:74) = '>' - ICHAR = 74 - ENDIF - IF ( LINE(1:1) .EQ. ' ' .OR. ALLNUM ) THEN - ILCODE = ILCODE + 1 - WRITE (11,'(1X,I4,1X,A)') ILCODE, LINE(1:ICHAR) - ELSE - WRITE (11,'(6X,A)') LINE(1:ICHAR) - ENDIF - ENDIF - 350 CONTINUE -* - IF ( IP .NE. NPAGE ) THEN - DO 360, IL=1, NADD_2 - WRITE (11,'(A)') NULLST - 360 CONTINUE - ENDIF -* - 400 CONTINUE -* -* End of processing ---------------------------------------------------- -* - STOP -* -* Error escape locations -* - 800 CONTINUE - WRITE (*,*) '*** w3list ERROR : READING FILE NAME' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 801 CONTINUE - WRITE (*,*) '*** w3list ERROR : READING LINE NUMBER FLAG' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 802 CONTINUE - WRITE (*,*) '*** w3list ERROR : OPENING INPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 803 CONTINUE - WRITE (*,*) '*** w3list ERROR : READING FROM OUTPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 804 CONTINUE - WRITE (*,*) '*** w3list ERROR : OPENING INPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* -* Formats -* -* -* End of W3PRNT -------------------------------------------------------- -* - END diff --git a/model/tools/w3prnt.f b/model/tools/w3prnt.f deleted file mode 100644 index 4e06c7208..000000000 --- a/model/tools/w3prnt.f +++ /dev/null @@ -1,219 +0,0 @@ - PROGRAM W3PRNT -C/ -C/ +-----------------------------------+ -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 08-Jul-1993 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Printing source codes and COMMON's including page numbers and -C headers. -C -C 2. Method : -C -C File name read from standard input. -C Output send to w3prnt.out. -C -C 3. Parameters : -C -C Data in PARAMETER statements : -C ---------------------------------------------------------------- -C MMLINE Int. Maximum length of file. -C NLPAGE Int. Length of page in terms of lines. -C NOPAGE Int. Number of lines printed on page. -C NUMB Log. Flag for line numbering. -C INVERT Log. Flag for inverting print order of pages. -C ---------------------------------------------------------------- -C -C 4. Subroutines used : -C -C None. -C -C 5. Called by : -C -C None (stand alone program). -C -C 6. Error messages : -C -C - File existence. -C - File size. -C -C 7. Remarks : -C -C - Only first 74 characters printed. -C - If line is longer, last charected beomes break-off mark >. -C -C 8. Structure : -C -C ===================================================== -C Prepagations -C Get file name from standard input. -C Open input file. -C Read entire file. -C Get number of pages. -C Open output file. -C Process pages. -C ------------------------------------------------ -C ------------------------------------------------ -C ===================================================== -C -C 9. Source code : -C -* ---------------------------------------------------------------------- -* - INTEGER MMLINE, NLPAGE, NOPAGE - LOGICAL NUMB, INVERT -* - PARAMETER ( MMLINE = 5000 ) - PARAMETER ( NLPAGE = 60 ) - PARAMETER ( NOPAGE = 55 ) -* - PARAMETER ( NUMB = .TRUE. ) - PARAMETER ( INVERT = .FALSE. ) -* - INTEGER NADD_1, NADD_2, N_HEAD, IERR, I, NL, NPAGE, - & IP, IP1, IPN, IPS, IL, IL1, ILN, ICHAR - CHARACTER FILE*80, LINE*80, NOLINE*80, HEADER*80, - & FNAME*40, NULLST*1, PP*4 - DIMENSION FILE(MMLINE) -* -* initialisations ------------------------------------------------------ -* - NOLINE(01:40) = ' ' - NOLINE(41:80) = ' ' - NULLST = ' ' - NADD_1 = ( NLPAGE - NOPAGE -1 ) / 2 - NADD_2 = NLPAGE - NOPAGE - 1 - NADD_1 -* -* get file name -------------------------------------------------------- -* - READ (*,'(A)',ERR=800,IOSTAT=IERR) FNAME - N_HEAD = LEN(FNAME) - DO 100, I=N_HEAD, 1, -1 - IF ( FNAME(I:I) .NE. ' ' ) THEN - N_HEAD = I - GOTO 101 - ENDIF - 100 CONTINUE - 101 CONTINUE - HEADER = NOLINE - HEADER(71-N_HEAD:70) = FNAME(1:N_HEAD) - HEADER(73:76) = 'page' -* -* Open input file ------------------------------------------------------ -* - OPEN (10,FILE=FNAME,STATUS='OLD',ERR=801,IOSTAT=IERR) - REWIND (10) -* -* Read input file ------------------------------------------------------ -* - NL = 0 - 200 CONTINUE - READ (10,'(A)',END=201,ERR=802,IOSTAT=IERR) LINE - NL = NL + 1 - IF ( NL .GT. MMLINE ) THEN - WRITE (*,*) '*** ERROR : TOO MANY LINES' - STOP ' ' - ENDIF - FILE(NL) = LINE - GOTO 200 -* - 201 CONTINUE -* -* Numer of pages ---------------------------------------------------------------------- -* - NPAGE = 1 + (NL-1)/NOPAGE - IF ( INVERT ) THEN - IP1 = NPAGE - IPN = 1 - IPS = -1 - ELSE - IP1 = 1 - IPN = NPAGE - IPS = 1 - ENDIF -* -* Open output file ----------------------------------------------------- -* - OPEN (11,FILE='w3prnt.out',ERR=803,IOSTAT=IERR) -* -* Loop over pages ------------------------------------------------------ -* - DO 400, IP=IP1, IPN, IPS -* - WRITE (PP,'(I4)') IP - HEADER(77:80) = PP - ILN = IP * NOPAGE - IL1 = ILN + 1 - NOPAGE -* - WRITE (11,'(A)') HEADER - DO 300, IL=1, NADD_1 - WRITE (11,'(A)') NULLST - 300 CONTINUE -* - DO 350, IL=IL1, ILN - IF ( IL .LE. NL ) THEN - LINE = FILE(IL) - DO 310, I=80, 1, -1 - IF ( LINE(I:I) .NE. ' ' ) THEN - ICHAR = I - GOTO 311 - ENDIF - 310 CONTINUE - 311 CONTINUE - IF ( ICHAR .GT. 74 ) THEN - LINE(74:74) = '>' - ICHAR = 74 - ENDIF - IF ( NUMB ) THEN - WRITE (11,'(1X,I4,1X,A)') IL, LINE(1:ICHAR) - ELSE - WRITE (11,'(6X,A)') LINE(1:ICHAR) - ENDIF - ELSE - WRITE (11,'(A)') NULLST - ENDIF - 350 CONTINUE -* - IF ( IP .NE. IPN ) THEN - DO 360, IL=1, NADD_2 - WRITE (11,'(A)') NULLST - 360 CONTINUE - ENDIF -* - 400 CONTINUE -* -* End of processing ---------------------------------------------------- -* - STOP -* -* Error escape locations -* - 800 CONTINUE - WRITE (*,*) '*** ERROR : READING FILE NAME' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 801 CONTINUE - WRITE (*,*) '*** ERROR : OPENING INPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 802 CONTINUE - WRITE (*,*) '*** ERROR : READING FROM OUTPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* - 803 CONTINUE - WRITE (*,*) '*** ERROR : OPENING INPUT FILE' - WRITE (*,*) ' IOSTAT : ', IERR - STOP -* -* Formats -* -* -* End of W3PRNT -------------------------------------------------------- -* - END diff --git a/model/tools/w3split.f b/model/tools/w3split.f deleted file mode 100644 index 78f2c5f28..000000000 --- a/model/tools/w3split.f +++ /dev/null @@ -1,960 +0,0 @@ -C/ ------------------------------------------------------------------- / - PROGRAM W3SPLT -C/ -C/ +-----------------------------------+ -C/ | WAVEWATCH III NOAA/NCEP | -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 19-May-1999 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Read a WAVEWATCH III version 1.17 point output data file and -C produces a table of mean parameters for all individual wave -C systems. -C -C 2. Method : -C -C Partitioning as devised by Gerling and similar to used in -C WAM model. From standard input the following data is read : -C -C name of output point to be considered. -C name of run of model. -C name of input file. -C logical to indentify FORMATTED input file. -C name of output file. -C -C All strings are read as characters, therefore no quotes are -C needed. -C -C 3. Parameters : -C -C Parameter statements -C ---------------------------------------------------------------- -C NFR Int. Number of frequencies in spectrum. -C NTH Int. Number of directions in spectrum. -C NPMAX Int. Maximum number of peaks to be looked for. -C NPTAB Int. Number of columns in table. -C HSMIN Real Minimum wave height for includion in table. -C HSDROP Real Minimum wave high for system to be considered -C as separate wave system. -C DHSMAX Real Max. change in Hs for system to be considered -C related to previous time. -C DTPAX Real Id. Tp. -C DDMMAX Real Id. Dm. -C DDWMAX Real Maximum differences in wind and wave direction -C for marking of system as under the influence -C of the local wind, -C AGEMIN Real Id. wave age. -C ---------------------------------------------------------------- -C -C 4. Subroutines used : -C -C MPARS Calculate mean parameters -C FNDPRT Get mask for partition. -C WAVNU2 Solve dispersion relation. -C -C 5. Called by : -C -C None, main program, -C -C 6. Error messages : -C -C See "Error escape locations" at end of code. -C -C 7. Remarks : -C -C 8. Structure : -C -C See source code. -C -C 10. Source code : -C -C/ ------------------------------------------------------------------- / -C/ Parameter statements -C/ - INTEGER NFR, NTH, NPMAX, NPTAB - REAL XFR, HSMIN, HSDROP, - & DHSMAX, DTPAX, DDMMAX, DDWMAX, AGEMIN -* - PARAMETER ( NFR = 25 ) - PARAMETER ( NTH = 24 ) - PARAMETER ( NPMAX = 20 ) - PARAMETER ( NPTAB = 6 ) - PARAMETER ( XFR = 1.1 ) - PARAMETER ( HSMIN = 0.15 ) - PARAMETER ( HSDROP = 0.05 ) - PARAMETER ( DHSMAX = 1.5 ) - PARAMETER ( DTPMAX = 1.5 ) - PARAMETER ( DDMMAX = 15. ) - PARAMETER ( DDWMAX = 30. ) - PARAMETER ( AGEMIN = 0.8 ) -* - INTEGER NDSI, NDSO, IERR, NFRF, NTHF, IFR, ITH - INTEGER NPNTS, IP, TIME(2), IREAD - INTEGER IFL, IFH, ITHL, ITHH - INTEGER NPEAK, NFRP(NPMAX), NTHP(NPMAX), IPNOW, IOUT, ITAB - INTEGER NZERO - REAL PI, RADE, FR(NFR), TH(NTH), DTH, DFR(NFR), - & TAILF, SPEC(NFR,NTH), W1(NFR,NTH), W2(NFR,NTH), - & SP1D(NFR), HS, TP, DM, XFRV, STMAX, HMAX - REAL HSTOT, HSP(NPMAX), TPP(NPMAX), DMP(NPMAX) - REAL HST(NPMAX,2), TPT(NPMAX,2), DMT(NPMAX,2) - REAL D, UA, UD, UABS, UDIR, DELDW, DELHS, DELTP, DELDM - REAL AFR, WN, CG, AGE, Y, X - LOGICAL FORMI, DATA, FLAG(NPMAX), HEADER - CHARACTER POINT*10, PID*10, FNAMEI*40, FNAMEO*40, IDSTR*21 - CHARACTER MODEL*40, RUN*20, GNAME*30, IDLAT*1, IDLON*1 - CHARACTER*129 BLANK, TAIL, STRING - CHARACTER*15 PART -C/ -C/ ------------------------------------------------------------------- / -C/ -* -* 1. Initializations ------------------------------------------------ * -* 1.a Constants etc. -* - NDSI = 10 - NDSO = 50 -* - PI = 4. * ATAN(1.) - RADE = 180. / PI - XFRV = XFR -* - IREAD = 0 -* - TAIL ( 1: 40) = '+-------+-----------+-----------------+-' - TAIL ( 41: 80) = '----------------+-----------------+-----' - TAIL ( 81:120) = '------------+-----------------+---------' - TAIL (120:129) = '---------+' - BLANK( 1: 40) = '| nn nn | nn | | ' - BLANK( 41: 80) = ' | | ' - BLANK( 81:120) = ' | | ' - BLANK(120:129) = ' |' - STRING = BLANK -* - DO 100, IP=1, NPTAB - HST(IP,1) = -1. - TPT(IP,1) = -1. - DMT(IP,1) = -1. - 100 CONTINUE -* -* 1.b Initial I/O -* - WRITE (*,900) - READ (*,'(A)') POINT - READ (*,'(A)') RUN - WRITE (*,901) POINT, RUN - READ (*,'(A)') FNAMEI - READ (*,*) FORMI - WRITE (*,902) FNAMEI, FORMI - READ (*,'(A)') FNAMEO - WRITE (*,903) FNAMEO -* -* 1.c Open input file and process header -* - IF ( FORMI ) THEN - OPEN (NDSI,FILE=FNAMEI,STATUS='OLD',ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSI,FILE=FNAMEI,STATUS='OLD', - & FORM='UNFORMATTED',ERR=800,IOSTAT=IERR) - ENDIF - WRITE (*,904) -* - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) - & IDSTR, NFRF, NTHF, NPNTS, GNAME - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) - & IDSTR, NFRF, NTHF, NPNTS, GNAME - ENDIF -* - IF ( IDSTR .NE. 'WAVEWATCH III SPECTRA' ) GOTO 803 - IF ( NFR.NE.NFRF .OR. NTH.NE.NTHF ) GOTO 804 - WRITE (*,905) -* - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) FR - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) FR - ENDIF - WRITE (*,906) -* - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) TH - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) TH - ENDIF - WRITE (*,907) -* - DTH = 2. * PI / REAL(NTH) - TAILF = 0.25 * FR(NFR) -* - DO 110, IFR=1, NFR - DFR(IFR) = 0.5 * (XFR-1./XFR) * FR(IFR) - 110 CONTINUE - DFR(NFR) = 0.5 * DFR(NFR) - WRITE (*,908) -* -* 1.d Open output file and process header -* - OPEN (NDSO,FILE=FNAMEO,ERR=810,IOSTAT=IERR) - WRITE (*,909) - HEADER = .TRUE. -* -* === LOOP OVER DATA ================================================= * -* - 200 CONTINUE -* -* 2. Read next data ------------------------------------------------- * -* - IF ( FORMI ) THEN - READ (NDSI,*,END=888,ERR=802,IOSTAT=IERR) TIME - ELSE - READ (NDSI , END=888,ERR=802,IOSTAT=IERR) TIME - ENDIF -* - DATA = .FALSE. - DO 210, IP=1, NPNTS - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) - & PID, Y, X, D, UA, UD - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) - & PID, Y, X, D, UA, UD - ENDIF - IF ( PID .EQ. POINT ) THEN - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) SPEC - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) SPEC - ENDIF - DATA = .TRUE. - UABS = UA - UDIR = MOD( UD+180., 360. ) - ELSE - IF ( FORMI ) THEN - READ (NDSI,*,END=801,ERR=802,IOSTAT=IERR) W1 - ELSE - READ (NDSI , END=801,ERR=802,IOSTAT=IERR) W1 - ENDIF - ENDIF - 210 CONTINUE -* - IF ( .NOT. DATA ) GOTO 805 - IREAD = IREAD + 1 -* - IF ( HEADER ) THEN - X = MOD ( X+720. , 360. ) - IF ( X .LE. 180. ) THEN - IDLON = 'E' - ELSE - X = 360. - X - IDLON = 'W' - ENDIF - IF ( ABS(Y) .LE. 0.0049 ) THEN - IDLAT = ' ' - ELSE IF ( Y .GT. 0. ) THEN - IDLAT = 'N' - ELSE - IDLAT = 'S' - X = -X - ENDIF - WRITE (NDSO,950) POINT, Y, IDLAT, X, IDLON, GNAME, RUN - WRITE (NDSO,951) TAIL - WRITE (NDSO,952) - WRITE (NDSO,951) TAIL - HEADER = .FALSE. - ENDIF -* -* 3. Get overall wave height ---------------------------------------- * -* - DO 310, ITH=1, NTH - DO 300, IFR=1, NFR - W1(IFR,ITH) = 1. - 300 CONTINUE - 310 CONTINUE -* - CALL MPARS ( NFR, NTH, SPEC, W1, FR, TH, DFR, DTH, TAILF, XFRV, - & SP1D, HS, TP, DM ) -* - HSTOT = HS -* -* 4. Determine maxima ----------------------------------------------- * -* - NPEAK = 0 -* - DO 410, IFR=NFR, 1, -1 - IFL = MAX ( 1 , IFR-1 ) - IFH = MIN ( NFR , IFR+1 ) - DO 400, ITH=1, NTH - ITHL = 1 + MOD(NTH+ITH-2,NTH) - ITHH = 1 + MOD(ITH,NTH) - IF ( SPEC(IFR,ITH) .GE. SPEC(IFL,ITH ) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFH,ITH ) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFL,ITHL) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFR,ITHL) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFH,ITHL) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFL,ITHH) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFR,ITHH) .AND. - & SPEC(IFR,ITH) .GE. SPEC(IFH,ITHH) .AND. - & SPEC(IFR,ITH) .GT. 0. ) THEN - NPEAK = NPEAK + 1 - NFRP(NPEAK) = IFR - NTHP(NPEAK) = ITH - ENDIF - W1(IFR,ITH) = 0. - 400 CONTINUE - 410 CONTINUE -* - IF ( NPEAK .LE. NPMAX ) THEN - WRITE (*,910) TIME, NPEAK - ELSE - NPEAK = NPMAX - WRITE (*,911) TIME, NPEAK - ENDIF -* -* 5. Process all partial fields ------------------------------------- * -* - NZERO = 0 -* - DO 500, IP=1, NPEAK -* - CALL FNDPRT ( NFR, NTH, NFRP(IP), NTHP(IP), SPEC, W1, W2 ) -* - CALL MPARS ( NFR, NTH, SPEC, W2, FR, TH, DFR, DTH, TAILF, XFRV, - & SP1D, HSP(IP), TPP(IP), DMP(IP) ) - IF ( HSP(IP) .LE. HSDROP ) NZERO = NZERO + 1 -* - 500 CONTINUE -* - DO 510, IP=NPEAK+1, NPMAX - HSP(IP) = 0.00 - TPP(IP) = -999.99 - DMP(IP) = -999.99 - 510 CONTINUE -* - DO 520, IP=1, NPTAB - HST(IP,2) = HST(IP,1) - TPT(IP,2) = TPT(IP,1) - DMT(IP,2) = DMT(IP,1) - HST(IP,1) = -1. - TPT(IP,1) = -1. - DMT(IP,1) = -1. - 520 CONTINUE -* -* 6. Generate output table ------------------------------------------ * -* 6.a Time and overall wave height to string -* - STRING = BLANK -* - WRITE (STRING(3:4),'(I2)') MOD(TIME(1),100) - WRITE (STRING(6:7),'(I2)') TIME(2)/10000 - IF ( HSTOT .GT. 0. ) WRITE (STRING(11:14),'(F4.1)') HSTOT - WRITE (STRING(16:17),'(I2)') NPEAK - NZERO - IF ( NPEAK.EQ.0 .OR. HSTOT.LT.0.1 ) GOTO 699 -* -* 6.b Switch off peak with too low wave height -* - DO 600, IP=1, NPEAK - FLAG(IP) = HSP(IP) .GT. HSMIN - 600 CONTINUE -* -* 6.c Find next highest wave height -* - IOUT = 0 - 601 CONTINUE -* - HMAX = 0. - IPNOW = 0 - DO 610, IP=1, NPEAK - IF ( HSP(IP).GT.HMAX .AND. FLAG(IP) ) THEN - IPNOW = IP - HMAX = HSP(IP) - ENDIF - 610 CONTINUE -* -* 6.d No more peaks, skip to output -* - IF ( IPNOW .EQ. 0 ) GOTO 699 -* -* 6.e Find matching field -* - ITAB = 0 -* - DO 620, IP=1, NPTAB - IF ( TPT(IP,2) .GT. 0. ) THEN - DELHS = ABS ( HST(IP,2) - HSP(IPNOW) ) - DELTP = ABS ( TPT(IP,2) - TPP(IPNOW) ) - DELDM = ABS ( DMT(IP,2) - DMP(IPNOW) ) - IF ( DELDM .GT. 180. ) DELDM = 360. - DELDM - IF ( DELHS.LT.DHSMAX .AND. - & DELTP.LT.DTPMAX .AND. - & DELDM.LT.DDMMAX ) ITAB = IP - ENDIF - 620 CONTINUE -* -* 6.f No matching field, find empty fields -* - IF ( ITAB .EQ. 0 ) THEN - DO 630, IP=NPTAB, 1, -1 - IF ( TPT(IP,1).LT.0. .AND. TPT(IP,2).LT.0. ) ITAB = IP - 630 CONTINUE - ENDIF -* -* 6.g Slot in table found, write -* - IF ( ITAB .NE. 0 ) THEN -* - WRITE (PART,'(2X,F4.1,F5.1,I4)') - & HSP(IPNOW), TPP(IPNOW), NINT(DMP(IPNOW)) - DELDW = MOD ( ABS ( UDIR - DMP(IPNOW) ) , 360. ) - IF ( DELDW .GT. 180. ) DELDW = 360. - DELDW - AFR = 2.*PI/TPP(IPNOW) - CALL WAVNU2 ( AFR, D, WN, CG, 1.E-5, 15, ICON ) - AGE = UABS * WN / AFR - IF ( DELDW.LT.DDWMAX .AND. AGE.GT.AGEMIN ) PART(1:1) = '*' -* - STRING(5+ITAB*18:19+ITAB*18) = PART -* - HST(ITAB,1) = HSP(IPNOW) - TPT(ITAB,1) = TPP(IPNOW) - DMT(ITAB,1) = DMP(IPNOW) -* -* 6.g No slot in table found, write -* - ELSE -* - IOUT = IOUT + 1 - WRITE (STRING(19:19),'(I1)') IOUT -* - ENDIF -* - FLAG(IPNOW) = .FALSE. - GOTO 601 -* -* 6.h End of processing, write line in table -* - 699 CONTINUE -* - WRITE (NDSO,951) STRING -* -* === BRANCH BACK IN DATA LOOP ======================================= * -* - GOTO 200 -* -* Error escape locations ----------------------------------------- * -* -c GOTO 888 -* - 800 CONTINUE - WRITE (*,1000) FNAMEI, IERR - STOP -* - 801 CONTINUE - WRITE (*,1001) FNAMEI - STOP -* - 802 CONTINUE - WRITE (*,1002) FNAMEI, IERR - STOP -* - 803 CONTINUE - WRITE (*,1003) IDSTR, 'WAVEWATCH III SPECTRA' - STOP -* - 804 CONTINUE - WRITE (*,1004) NFR, NTH, NFRF, NTHF - STOP -* - 805 CONTINUE - WRITE (*,1005) POINT - STOP -* - 810 CONTINUE - WRITE (*,1010) FNAMEO, IERR - STOP -* - 888 CONTINUE - WRITE (NDSO,951) TAIL - WRITE (NDSO,953) HSDROP, HSMIN - WRITE (*,999) -* -* Format statements ---------------------------------------------- * -* - 900 FORMAT (/' Splitting WAVEWATCH III spectra : '/ - & ' ----------------------------------') - 901 FORMAT ( ' Location : ',A/ - & ' Run ID : ',A) - 902 FORMAT ( ' Input file : ',A,' FORMATTED : ',L1) - 903 FORMAT ( ' Output file : ',A) -* - 904 FORMAT (/' Input file opened ...') - 905 FORMAT ( ' Header read and processed.') - 906 FORMAT ( ' Frequency info read.') - 907 FORMAT ( ' Direction info read.') - 908 FORMAT ( ' Bin sizes preprocessed.') -* - 909 FORMAT (/' Output file opened ...') - 910 FORMAT ( ' Processing ',I8.8,' ',I6.6, - & ' Number of peaks :',I3) - 911 FORMAT ( ' Processing ',I8.8,' ',I6.6, - & ' Number of peaks :',I3,' (TRUNCATED)') -* - 950 FORMAT ( ' Location : ',A,' (',F5.2,A,1X,F6.2,A,')'/ - & ' Model : ',A/ - & ' Cycle : ',A) - 951 FORMAT (1X,A) - 952 FORMAT (' | day & | Hst n x | Hs Tp dir |', - & ' Hs Tp dir |', - & ' Hs Tp dir |', - & ' Hs Tp dir |', - & ' Hs Tp dir |', - & ' Hs Tp dir |'/ - & ' | hour | (m) - - | (m) (s) (d) |', - & ' (m) (s) (d) |', - & ' (m) (s) (d) |', - & ' (m) (s) (d) |', - & ' (m) (s) (d) |', - & ' (m) (s) (d) |') - 953 FORMAT ( - & 75X,'Hst : Total sigificant wave height.'/ - & 75X,'n : Number of fields with Hs > ',f6.2, - & ' in 2-D spectrum.'/ - & 75X,'x : Number of fields with Hs > ',f6.2, - & ' not in table.'/ - & 75X,'Hs : Significant wave height of separate wave field.'/ - & 75X,'Tp : Peak period of separate wave field.'/ - & 75X,'dir : Mean direction of separate wave field.'/ - & 75X,'* : Wave generation due to local wind probable.') -* - 999 FORMAT (/' End of program '/) -* - 1000 FORMAT (/' *** ERROR IN OPENING INPUT FILE ',A/ - & ' IOSTAT = ',I8/) - 1001 FORMAT (/' *** PREMATURE END OF INPUT FILE ',A/) - 1002 FORMAT (/' *** ERROR IN READING FROM INPUT FILE ',A/ - & ' IOSTAT = ',I8/) - 1003 FORMAT (/' *** UNEXPECTED HEADER IN FILE : '/ - & ' READ : ',A/ - & ' EXPECTED : ',A) - 1004 FORMAT (/' *** UNEXPECTED SPECTRAL DIMENSIONS : '/ - & ' IN PROGRAM :',2I6/ - & ' IN FILE :',2I6/) - 1005 FORMAT (/' *** NO DATA FOUND FOR POINT ',A/) -* - 1010 FORMAT (/' *** ERROR IN OPENING OUTPUT FILE ',A/ - & ' IOSTAT = ',I8/) -C/ -C/ End of W3SPLT ----------------------------------------------------- / -C/ - END -C/ ------------------------------------------------------------------- / - SUBROUTINE MPARS ( NFR, NTH, SPEC, MASK, FREQ, DIR, DFR, DTH, - & TAILF, XFR, SP1D, HS, TP, DM ) -C/ -C/ +-----------------------------------+ -C/ | WAVEWATCH III NOAA/NCEP | -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 15-Oct-1998 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Calculate mean parameters of a spectrum using a mask. -C -C 2. Method : -C -C Wave height HS : Integral over spectrum using par. tail. -C Peak period TP : Parabolic fit to 1-D spectrum. -C Mean direction DM : From first Fourier components. -C -C 3. Parameters : -C -C Parameter list -C ---------------------------------------------------------------- -C NFR Int. I Number of frequencies. -C NTH Int. I Number of directions. -C SPEC R.A. I Spectrum. -C MASK R.A. I Mask for spectrumi (real weight function). -C FREQ R.A. I Frequencies. -C DIR R.A. I Directions (radians). -C DFR R.A. I Bind width info for all frequencies. -C DTH R.A. I Directionsl increment. -C TAILF Real I Tail factor. -C XFR Real I Frequency increment factor. -C SP1D R.A. O 1-D spectrum. -C HS Real O Wave height -999.99 if undef. -C TP Real O Peak wave period -999.99 if undef. -C DM Real O Mean wave direction -999.99 if undef. -C ---------------------------------------------------------------- -C -C 4. Subroutines used : -C -C None. -C -C 5. Called by : -C -C Any. -C -C 10. Source code : -C -C/ ------------------------------------------------------------------- / -C/ Parameter list -C/ - INTEGER NFR, NTH - REAL SPEC(NFR,NTH), MASK(NFR,NTH), FREQ(NFR), DIR(NTH), - & DFR(NFR), DTH, TAILF, XFR, SP1D(NFR), HS, TP, DM -C/ -C/ ------------------------------------------------------------------- / -C/ Local parameters -C/ - INTEGER IFR, ITH, IMAX, ILOW, IHGH - REAL COSMOM, SINMOM, TOTMOM, COS0, SIN0, PI, RADE, EMAX - REAL XL, XH, XL2, XH2, EL, EH, DENOM, FP -C/ -C/ ------------------------------------------------------------------- / -* - PI = 4. * ATAN(1.) - RADE = 180./PI -* - XL = 1./XFR - 1. - XH = XFR - 1. - XL2 = XL**2 - XH2 = XH**2 -* - COSMOM = 0. - SINMOM = 0. - TOTMOM = 0. -* - DO 110, IFR=1, NFR -* - SP1D(IFR) = 0. - COS0 = 0. - SIN0 = 0. -* - DO 100, ITH=1, NTH - SP1D(IFR) = SP1D(IFR) + MASK(IFR,ITH)*SPEC(IFR,ITH) - COS0 = COS0 + MASK(IFR,ITH)*SPEC(IFR,ITH) * COS(DIR(ITH)) - SIN0 = SIN0 + MASK(IFR,ITH)*SPEC(IFR,ITH) * SIN(DIR(ITH)) - 100 CONTINUE -* - SP1D(IFR) = SP1D(IFR) * DTH - COSMOM = COSMOM + COS0 * DTH * DFR(IFR) - SINMOM = SINMOM + SIN0 * DTH * DFR(IFR) - TOTMOM = TOTMOM + SP1D(IFR)*DFR(IFR) -* - 110 CONTINUE -* - TOTMOM = TOTMOM + SP1D(NFR)*TAILF - TOTMOM = MAX ( 0. , TOTMOM ) -* -* 2. Mean parameters ------------------------------------------------ * -* 2.a Set to undefined -* - HS = 0.00 - TP = -999.99 - DM = -999.99 -* - IF ( TOTMOM .GT. 0. ) THEN -* -* 2.b Wave height -* - HS = 4. * SQRT(TOTMOM) -* -* 2.c Mean direction -* - DM = RADE * ATAN2(SINMOM,COSMOM) - IF ( DM .LT. 0. ) DM = DM + 360. -* -* 2.d Peak period -* - EMAX = 0. -* - DO 200, IFR=1, NFR - IF ( SP1D(IFR) .GT. EMAX ) THEN - EMAX = SP1D(IFR) - IMAX = IFR - ENDIF - 200 CONTINUE -* - ILOW = MAX ( 1 , IMAX-1 ) - IHGH = MIN ( NFR , IMAX+1 ) - EL = SP1D(ILOW) - SP1D(IMAX) - EH = SP1D(IHGH) - SP1D(IMAX) - DENOM = XL*EH - XH*EL - FP = FREQ(IMAX) * ( 1. + 0.5 * ( XL2*EH - XH2*EL ) - & / SIGN ( MAX(ABS(DENOM),1.E-15) , DENOM ) ) -* - TP = 1. / FP -* - ENDIF -* - RETURN -C/ -C/ End of MPARS ------------------------------------------------------ / -C/ - END -C/ ------------------------------------------------------------------- / - SUBROUTINE FNDPRT ( NFR, NTH, IFRC, ITHC, SPEC, W1, W2 ) -C/ -C/ +-----------------------------------+ -C/ | WAVEWATCH III NOAA/NCEP | -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 09-Sep-1998 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Find partition starting at given peak and given mask. -C -C 2. Method : -C -C 3. Parameters : -C -C Parameter list -C ---------------------------------------------------------------- -C NFR Int. I Number of frequencies. -C NTH Int. I Number of directions. -C IFRC Int. I Peak discrete frequency. -C ITHC Int. I Peak discrete direction. -C SPEC R.A. I Spectrum. -C W1 R.A. I/O Map of bins used so far. -C W2 R.A. O Map of bins used now. -C ---------------------------------------------------------------- -C -C 4. Subroutines used : -C -C None. -C -C 5. Called by : -C -C Any. -C -C 10. Source code : -C -C/ ------------------------------------------------------------------- / -C/ Parameter list -C/ - INTEGER NFR, NTH, IFRC, ITHC - REAL SPEC(NFR,NTH), W1(NFR,NTH), W2(NFR,NTH) -C/ -C/ ------------------------------------------------------------------- / -C/ Local parameters -C/ - INTEGER IFR, ITH, IFRL, ITHL - LOGICAL CHANGE, ADD -C/ -C/ ------------------------------------------------------------------- / -* -* 1. Set up the W2 map ---------------------------------------------- * -* - DO 110, IFR=1, NFR - DO 100, ITH=1, NTH - W2(IFR,ITH) = 0. - 100 CONTINUE - 110 CONTINUE -* - IFRL = MAX ( 1 , IFRC-1 ) - IFRH = MIN ( NFR , IFRC+1 ) - ITHL = 1 + MOD(NTH+ITHC-2,NTH) - ITHH = 1 + MOD(ITHC,NTH) -* - DO 130, ITH=ITHC-1, ITHC+1 - ITHL = 1 + MOD(NTH+ITH-1,NTH) - DO 120, IFR=IFRC-1, IFRC+1 - IFRL = MAX(1,MIN(NFR,IFR)) - IF ( W1(IFRL,ITHL) .LE. 0.5 ) W2(IFRL,ITHL) = 0.5 - 120 CONTINUE - 130 CONTINUE -* - IF ( W1(IFRC,ITHC) .LT. 0.25 ) W2(IFRC,ITHC) = 1.0 -* -* 2. Itterate search ------------------------------------------------ * -* - NITT = 0 -* -* 2.a Branch point -* - 200 CONTINUE - NITT = NITT + 1 - CHANGE = .FALSE. -* -* 2.b Determine central points -* - DO 240, IFR=1, NFR - DO 230, ITH=1, NTH -* - IF ( W2(IFR,ITH).EQ.0.5 .AND. W1(IFR,ITH).LT.0.5 ) THEN - ADD = .TRUE. - DO 220, ITHR=ITH-1, ITH+1 - ITHL = 1 + MOD(NTH+ITHR-1,NTH) - DO 210, IFRL=MAX(1,IFR-1), MIN(NFR,IFR+1) - IF ( W2 (IFRL,ITHL).EQ.0. .AND. - & SPEC(IFRL,ITHL).GT.SPEC(IFR,ITH) ) ADD = .FALSE. - 210 CONTINUE - 220 CONTINUE - IF ( ADD ) W2(IFR,ITH) = 1. - CHANGE = CHANGE .OR. ADD - ENDIF -* - 230 CONTINUE - 240 CONTINUE -* -* 2.c Determine central points -* - DO 280, IFR=1, NFR - DO 270, ITH=1, NTH -* - IF ( W2(IFR,ITH).EQ.0. ) THEN - ADD = .FALSE. - DO 260, ITHR=ITH-1, ITH+1 - ITHL = 1 + MOD(NTH+ITHR-1,NTH) - DO 250, IFRL=MAX(1,IFR-1), MIN(NFR,IFR+1) - IF ( W2 (IFRL,ITHL).EQ.1. ) ADD = .TRUE. - 250 CONTINUE - 260 CONTINUE - IF ( ADD ) W2(IFR,ITH) = 0.5 - CHANGE = CHANGE .OR. ADD - ENDIF -* - 270 CONTINUE - 280 CONTINUE -* -* 2.d Branch back ? -* - IF ( CHANGE .AND. NITT.LT.25 ) GOTO 200 -* -* 3 Update the overall map ----------------------------------------- * -* - DO 310, IFR=1, NFR - DO 300, ITH=1, NTH - W1(IFR,ITH) = W1(IFR,ITH) + W2(IFR,ITH) - 300 CONTINUE - 310 CONTINUE -* - RETURN -C/ -C/ End of FNDPRT ----------------------------------------------------- / -C/ - END -C/ ------------------------------------------------------------------- / - SUBROUTINE WAVNU2 (W,H,K,CG,EPS,NMAX,ICON) -C/ -C/ +-----------------------------------+ -C/ | WAVEWATCH III NOAA/NCEP | -C/ | H. L. Tolman | -C/ | FORTRAN 77 | -C/ | Last update : 17-Jul-1990 | -C/ +-----------------------------------+ -C/ -C 1. Purpose : -C -C Calculation of wavenumber K from a given angular -C frequency W and waterdepth H. -C -C 2. Method : -C -C Used equation : -C 2 -C W = G*K*TANH(K*H) -C -C Because of the nature of the equation, K is calculated -C with an itterative procedure. -C -C 3. Parameters : -C -C Parameter list -C ---------------------------------------------------------------- -C W Real I Angular frequncy -C H Real I Waterdepth -C K Real O Wavenumber ( same sign as W ) -C CG Real O Group velocity (same sign as W) -C EPS Real I Wanted max. difference between K and Kold -C NMAX Int. I Max number of repetitions in calculation -C ICON Int. O Contol counter ( See error messages ) -C ---------------------------------------------------------------- -C -C 9. Switches : -C -C C/S Enable subroutine tracing. -C -C 10. Source code : -C/ -C/ ------------------------------------------------------------------- / -C/ Parameter list -C/ - INTEGER ICON, NMAX - REAL EPS, CG, K, H, W -C/ -C/ ------------------------------------------------------------------- / -C/ Local parameters -C/ - INTEGER I -C/S INTEGER IENT - REAL G, F, W0, FD, DIF, RDIF, KOLD -C/ -C/ ------------------------------------------------------------------- / -C/ - DATA G / 9.81 / -* -* Initialisations : -* - CG = 0 - KOLD = 0 - ICON = 0 - W0 = ABS(W) -* -* 1st approach : -* - IF (W0.LT.SQRT(G/H)) THEN - K = W0/SQRT(G*H) - ELSE - K = W0*W0/G - END IF -* -* Refinement : -* - DO 7, I=1, NMAX - DIF = ABS(K-KOLD) - IF (K.NE.0) THEN - RDIF = DIF/K - ELSE - RDIF = 0 - END IF - IF (DIF .LT. EPS .AND. RDIF .LT. EPS) THEN - ICON = 1 - GOTO 8 - ELSE - KOLD = K - F = G*KOLD*TANH(KOLD*H)-W0**2 - IF (KOLD*H.GT.25) THEN - FD = G*TANH(KOLD*H) - ELSE - FD = G*TANH(KOLD*H) + G*KOLD*H/((COSH(KOLD*H))**2) - END IF - K = KOLD - F/FD - END IF -7 CONTINUE - DIF = ABS(K-KOLD) - RDIF = DIF/K - IF (DIF .LT. EPS .AND. RDIF .LT. EPS) ICON = 1 -8 CONTINUE - IF (2*K*H.GT.25) THEN - CG = W0/K * 0.5 - ELSE - CG = W0/K * 0.5*(1+(2*K*H/SINH(2*K*H))) - END IF - IF (W.LT.0.0) THEN - K = (-1)*K - CG = CG*(-1) - END IF -* - RETURN -C/ -C/ End of WAVNU2 ----------------------------------------------------- / -C/ - END