| 1 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
|---|
| 2 | ! Math and Computer Science Division, Argonne National Laboratory ! |
|---|
| 3 | !----------------------------------------------------------------------- |
|---|
| 4 | ! CVS $Id: pop.F90,v 1.15 2004-03-04 20:04:17 eong Exp $ |
|---|
| 5 | ! CVS $Name: $ |
|---|
| 6 | !BOP ------------------------------------------------------------------- |
|---|
| 7 | ! |
|---|
| 8 | ! !ROUTINE: pop2_2 -- dummy ocean model for unit tester |
|---|
| 9 | ! |
|---|
| 10 | ! !DESCRIPTION: |
|---|
| 11 | ! An ocean model subroutine to test functionality of MPH and MCT. |
|---|
| 12 | ! |
|---|
| 13 | ! !INTERFACE: |
|---|
| 14 | subroutine pop2_2 (POP_World) |
|---|
| 15 | ! |
|---|
| 16 | ! !USES: |
|---|
| 17 | ! |
|---|
| 18 | use MPH_all |
|---|
| 19 | !---Component Model Registry |
|---|
| 20 | use m_MCTWorld,only: ThisMCTWorld |
|---|
| 21 | use m_MCTWorld,only: MCTComponentRootRank => ComponentRootRank |
|---|
| 22 | use m_MCTWorld,only: MCTWorld_init => init |
|---|
| 23 | use m_MCTWorld,only: MCTWorld_clean => clean |
|---|
| 24 | !---Intercomponent communications scheduler |
|---|
| 25 | use m_Router,only: Router |
|---|
| 26 | use m_Router,only: MCT_Router_init => init |
|---|
| 27 | use m_Router,only: MCT_Router_clean => clean |
|---|
| 28 | use m_Transfer,only: MCT_Send => send |
|---|
| 29 | use m_Transfer,only: MCT_Recv => recv |
|---|
| 30 | !---Field Storage DataType and associated methods |
|---|
| 31 | use m_AttrVect,only : AttrVect |
|---|
| 32 | use m_AttrVect,only : MCT_AtrVt_init => init |
|---|
| 33 | use m_AttrVect,only : MCT_AtrVt_clean => clean |
|---|
| 34 | use m_AttrVect,only : MCT_AtrVt_lsize => lsize |
|---|
| 35 | use m_AttrVect,only : MCT_AtrVt_nReal => nRAttr |
|---|
| 36 | use m_AttrVect,only : MCT_AtrVt_nInteger => nIAttr |
|---|
| 37 | use m_AttrVect,only : AttrVect_zero => zero |
|---|
| 38 | use m_AttrVect,only : AttrVect_Copy => Copy |
|---|
| 39 | use m_AttrVectComms,only : AttrVect_gather => gather |
|---|
| 40 | !---Domain Decomposition Descriptor DataType and associated methods |
|---|
| 41 | use m_GlobalSegMap,only: GlobalSegMap |
|---|
| 42 | use m_GlobalSegMap,only: MCT_GSMap_init => init |
|---|
| 43 | use m_GlobalSegMap,only: MCT_GSMap_clean => clean |
|---|
| 44 | use m_GlobalSegMap,only: MCT_GSMap_gsize => gsize |
|---|
| 45 | use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize |
|---|
| 46 | use m_GlobalSegMap,only: MCT_GSMap_ngseg => ngseg |
|---|
| 47 | use m_GlobalSegMap,only: MCT_GSMap_nlseg => nlseg |
|---|
| 48 | use m_GlobalMap,only : GlobalMap |
|---|
| 49 | use m_GlobalMap,only : GlobalMap_init => init |
|---|
| 50 | use m_GlobalMap,only : GlobalMap_clean => clean |
|---|
| 51 | !---GlobalSegMap Communication Methods |
|---|
| 52 | use m_GlobalSegMapComms,only: GlobalSegMap_bcast => bcast |
|---|
| 53 | use m_GlobalSegMapComms,only: GlobalSegMap_send => send |
|---|
| 54 | use m_GlobalSegMapComms,only: GlobalSegMap_recv => recv |
|---|
| 55 | use m_GlobalSegMapComms,only: GlobalSegMap_isend => isend |
|---|
| 56 | !---Methods for Exchange of GlobalMapping Objects |
|---|
| 57 | use m_ExchangeMaps,only: ExchangeMap |
|---|
| 58 | !---Coordinate Grid DataType and associated methods |
|---|
| 59 | use m_GeneralGrid,only : GeneralGrid |
|---|
| 60 | use m_GeneralGrid,only : MCT_GGrid_init => init |
|---|
| 61 | use m_GeneralGrid,only : MCT_GGrid_clean => clean |
|---|
| 62 | use m_GeneralGrid,only : MCT_GGrid_dims => dims |
|---|
| 63 | use m_GeneralGrid,only : MCT_GGrid_lsize => lsize |
|---|
| 64 | use m_GeneralGrid,only : MCT_GGrid_indexIA => indexIA |
|---|
| 65 | use m_GeneralGrid,only : MCT_GGrid_indexRA => indexRA |
|---|
| 66 | use m_GeneralGrid,only : MCT_GGrid_exportIAttr => exportIAttr |
|---|
| 67 | use m_GeneralGrid,only : MCT_GGrid_importIAttr => importIAttr |
|---|
| 68 | use m_GeneralGrid,only : MCT_GGrid_exportRAttr => exportRAttr |
|---|
| 69 | use m_GeneralGrid,only : MCT_GGrid_importRAttr => importRAttr |
|---|
| 70 | use m_GeneralGrid,only : MCT_GGrid_SortPermute => sortpermute |
|---|
| 71 | use m_GeneralGridComms,only: MCT_GGrid_send => send |
|---|
| 72 | use m_GeneralGridComms,only: MCT_GGrid_scatter => scatter |
|---|
| 73 | use m_GeneralGridComms,only: MCT_GGrid_gather => gather |
|---|
| 74 | !---Spatial Integral DataType and associated methods |
|---|
| 75 | use m_SpatialIntegral,only : MCT_SpatialIntegral => SpatialIntegral |
|---|
| 76 | use m_SpatialIntegral,only : MCT_SpatialAverage => SpatialAverage |
|---|
| 77 | use m_SpatialIntegral,only : MCT_MaskedSpatialIntegral => & |
|---|
| 78 | MaskedSpatialIntegral |
|---|
| 79 | use m_SpatialIntegral,only : MCT_MaskedSpatialAverage => & |
|---|
| 80 | MaskedSpatialAverage |
|---|
| 81 | |
|---|
| 82 | !---mpeu List datatype |
|---|
| 83 | use m_List, only : List |
|---|
| 84 | use m_List, only : List_clean => clean |
|---|
| 85 | use m_List, only : List_exportToChar => exportToChar |
|---|
| 86 | !---mpeu routines for MPI communications |
|---|
| 87 | use m_mpif90 |
|---|
| 88 | !---mpeu timers |
|---|
| 89 | use m_zeit |
|---|
| 90 | |
|---|
| 91 | use m_stdio |
|---|
| 92 | use m_ioutil, only: luavail |
|---|
| 93 | use m_die |
|---|
| 94 | |
|---|
| 95 | !---Tester Modules |
|---|
| 96 | use m_ACTEST, only : Accumulator_test => testall |
|---|
| 97 | use m_AVTEST, only : AttrVect_test => testall |
|---|
| 98 | use m_AVTEST, only : AttrVect_identical => Identical |
|---|
| 99 | use m_GGRIDTEST, only : GGrid_test => testall |
|---|
| 100 | use m_GGRIDTEST, only : GGrid_identical => Identical |
|---|
| 101 | use m_GMAPTEST, only : GMap_test => testall |
|---|
| 102 | use m_GSMAPTEST, only : GSMap_test => testall |
|---|
| 103 | use m_GSMAPTEST, only : GSMap_identical => Identical |
|---|
| 104 | use m_MCTWORLDTEST, only : MCTWorld_test => testall |
|---|
| 105 | use m_ROUTERTEST, only : Router_test => testall |
|---|
| 106 | use m_SMATTEST, only : sMat_test => testall |
|---|
| 107 | use m_SMATTEST, only : sMat_identical => Identical |
|---|
| 108 | |
|---|
| 109 | ! |
|---|
| 110 | ! !REVISION HISTORY: |
|---|
| 111 | ! Oct00 - Yun (Helen) He and Chris Ding, NERSC/LBNL - initial version |
|---|
| 112 | ! 19Nov00 - R. Jacob <jacob@mcs.anl.gov> - interface with mct |
|---|
| 113 | ! 09Feb01 - R. Jacob <jacob@mcs.anl.gov> - add MPI_Barrier |
|---|
| 114 | ! 25Feb01 - R. Jacob <jacob@mcs.anl.gov> - mpeu timing and MPE |
|---|
| 115 | ! 15Feb02 - R. Jacob <jacob@mcs.anl.gov> - new MCTWorld_init interface |
|---|
| 116 | ! 13Jul02 - E. Ong <eong@mcs.anl.gov> - introduce a POP grid |
|---|
| 117 | !EOP ___________________________________________________________________ |
|---|
| 118 | |
|---|
| 119 | implicit none |
|---|
| 120 | |
|---|
| 121 | character(len=*), parameter :: popname='pop2_2' |
|---|
| 122 | |
|---|
| 123 | !----------------------- MPH vars |
|---|
| 124 | |
|---|
| 125 | integer myProc, myProc_global, mySize, root |
|---|
| 126 | integer Global_World, POP_World |
|---|
| 127 | integer ncomps, mycompid, coupler_id |
|---|
| 128 | |
|---|
| 129 | ! SparseMatrix dimensions and Processor Layout |
|---|
| 130 | integer :: Nax, Nay ! Atmosphere lons, lats |
|---|
| 131 | integer :: Nox, Noy ! Ocean lons, lats |
|---|
| 132 | integer :: NPROCS_LATA, NPROCS_LONA ! Processor layout |
|---|
| 133 | |
|---|
| 134 | !----------------------- MCT vars |
|---|
| 135 | |
|---|
| 136 | ! Variables used for GlobalSegMap |
|---|
| 137 | integer,dimension(1) :: starts,lengths |
|---|
| 138 | integer :: osize,osize2 |
|---|
| 139 | integer :: i,j,k,n |
|---|
| 140 | |
|---|
| 141 | ! Arrays used to test MCT import/export routines |
|---|
| 142 | integer,dimension(:),pointer :: MaskVector |
|---|
| 143 | integer, dimension(:), pointer :: dummyI |
|---|
| 144 | real, dimension(:), pointer :: dummyR |
|---|
| 145 | integer :: latindx,lonindx,gridindx,status |
|---|
| 146 | integer :: length |
|---|
| 147 | integer :: dAindx |
|---|
| 148 | real :: pi |
|---|
| 149 | |
|---|
| 150 | ! Ocean GeneralGrid |
|---|
| 151 | type(GeneralGrid) :: POPGrid, dPOPGrid |
|---|
| 152 | |
|---|
| 153 | ! Test grid for scatter,gather |
|---|
| 154 | type(GeneralGrid) :: scatterGGrid, gatherGGrid |
|---|
| 155 | |
|---|
| 156 | ! Ocean GlobalSegMap |
|---|
| 157 | type(GlobalSegMap) :: OGSMap |
|---|
| 158 | |
|---|
| 159 | ! Ocean GlobalSegMap from coupler |
|---|
| 160 | type(GlobalSegMap) :: CPL_OGSMap |
|---|
| 161 | |
|---|
| 162 | ! GSMap for testing GlobalSegMapComms |
|---|
| 163 | type(GlobalSegMap) :: inGSMap |
|---|
| 164 | |
|---|
| 165 | ! Ocean GlobalMap |
|---|
| 166 | type(GlobalMap) :: OGMap |
|---|
| 167 | |
|---|
| 168 | ! Router from Cpl to Ocn |
|---|
| 169 | type(Router) :: Cpl2Ocn |
|---|
| 170 | |
|---|
| 171 | ! Ocean Inputs from the Coupler and Integral |
|---|
| 172 | type(AttrVect) :: OinputAV, IntegratedOinputAV |
|---|
| 173 | |
|---|
| 174 | ! Ocean Outputs to the Coupler |
|---|
| 175 | type(AttrVect) :: OoutputAV |
|---|
| 176 | |
|---|
| 177 | ! Temporary Vars for hmv tests |
|---|
| 178 | type(AttrVect) :: gatherAV_ocn |
|---|
| 179 | integer :: unit |
|---|
| 180 | |
|---|
| 181 | #ifdef MPE |
|---|
| 182 | #include "mpe.h" |
|---|
| 183 | #endif |
|---|
| 184 | |
|---|
| 185 | ! Set the value of pi: |
|---|
| 186 | pi = acos(-1.0) |
|---|
| 187 | |
|---|
| 188 | !-------------------------begin code |
|---|
| 189 | |
|---|
| 190 | call MPI_COMM_DUP (MPI_COMM_WORLD, Global_World, ierr) |
|---|
| 191 | call MPI_COMM_RANK (Global_World, myProc_global, ierr) |
|---|
| 192 | call MPI_COMM_RANK (POP_World, myProc, ierr) |
|---|
| 193 | call MPI_COMM_SIZE(POP_World,mySize,ierr) |
|---|
| 194 | |
|---|
| 195 | if (myProc==0) call MPH_redirect_output ('pop') |
|---|
| 196 | ! write(*,*) myProc, ' in pop === ', myProc_global, ' in global' |
|---|
| 197 | ! write(*,*) 'MPH_local_proc_id_ME_SE()=', MPH_local_proc_id_ME_SE() |
|---|
| 198 | ! write(*,*) 'MPH_global_proc_id()=', MPH_global_proc_id() |
|---|
| 199 | |
|---|
| 200 | |
|---|
| 201 | !------------------------------------------------------- |
|---|
| 202 | ! Begin attempts to use MCT |
|---|
| 203 | #ifdef MPE |
|---|
| 204 | call mpe_logging_init(myProc_global,init_s,init_e,gsmi_s,gsmi_e, & |
|---|
| 205 | atri_s,atri_e,routi_s,routi_e,send_s,send_e,recv_s,recv_e, & |
|---|
| 206 | clean_s,clean_e) |
|---|
| 207 | #endif |
|---|
| 208 | |
|---|
| 209 | ! Get the coupler's component id |
|---|
| 210 | coupler_id = MPH_get_component_id("coupler") |
|---|
| 211 | |
|---|
| 212 | ! Initialize MCTWorld |
|---|
| 213 | ncomps=MPH_total_components() |
|---|
| 214 | mycompid=MPH_component_id_ME_SE() |
|---|
| 215 | call zeit_ci('Oworldinit') |
|---|
| 216 | call MCTWorld_init(ncomps,MPI_COMM_WORLD,POP_World,mycompid) |
|---|
| 217 | call zeit_co('Oworldinit') |
|---|
| 218 | |
|---|
| 219 | call MCTWorld_test("POP::MCTWorld",6200+myProc) |
|---|
| 220 | |
|---|
| 221 | ! Get the Sparse Matrix dimensions and processor layout |
|---|
| 222 | root = MCTComponentRootRank(coupler_id,ThisMCTWorld) |
|---|
| 223 | call MPI_BCAST(Nax,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 224 | call MPI_BCAST(Nay,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 225 | call MPI_BCAST(Nox,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 226 | call MPI_BCAST(Noy,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 227 | call MPI_BCAST(NPROCS_LATA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 228 | call MPI_BCAST(NPROCS_LONA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) |
|---|
| 229 | |
|---|
| 230 | |
|---|
| 231 | ! Load a POP grid on the ROOT PROCESS |
|---|
| 232 | |
|---|
| 233 | if(myProc==0) then |
|---|
| 234 | |
|---|
| 235 | write(*,*) popname, ":: Initializing Ocean General Grid" |
|---|
| 236 | |
|---|
| 237 | ! NOTE: Since POP grids already have a predefined order, |
|---|
| 238 | ! do not impose a sorting order upon initialization |
|---|
| 239 | |
|---|
| 240 | call convertPOPT(POPGrid, & |
|---|
| 241 | "../../data/grid.320x384.da", & |
|---|
| 242 | "../../data/kmt_full_40.da", Nox, Noy) |
|---|
| 243 | |
|---|
| 244 | call GGrid_test(POPGrid,"POP::POPGrid",3400+myProc) |
|---|
| 245 | |
|---|
| 246 | ! Write out the basic things we initialized |
|---|
| 247 | |
|---|
| 248 | write(stdout,'(3a,i1)') popname, ":: Initialized POP GeneralGrid variable POPGrid.", & |
|---|
| 249 | "Number of dimensions = ",MCT_GGrid_dims(POPGrid) |
|---|
| 250 | write(stdout,'(2a,i8)') popname, ":: Number of grid points in POPGrid=", & |
|---|
| 251 | MCT_GGrid_lsize(POPGrid) |
|---|
| 252 | write(stdout,'(2a,i8)') popname, ":: Number of latitudes Noy=", Noy |
|---|
| 253 | write(stdout,'(2a,i8)') popname, ":: Number of longitudes Nox=", Nox |
|---|
| 254 | write(stdout,'(2a,i8)') popname, ":: Number of grid points Nox*Nox=", Noy*Nox |
|---|
| 255 | write(stdout,'(3a)') popname, ":: POPGrid%coordinate_list = ", & |
|---|
| 256 | List_exportToChar(POPGrid%coordinate_list) |
|---|
| 257 | ! write(stdout,'(3a)') popname, ":: POPGrid%coordinate_sort_order = ", & |
|---|
| 258 | ! List_exportToChar(POPGrid%coordinate_sort_order) |
|---|
| 259 | write(stdout,'(3a)') popname, ":: POPGrid%weight_list = ", & |
|---|
| 260 | List_exportToChar(POPGrid%weight_list) |
|---|
| 261 | write(stdout,*) popname, ":: POPGrid%other_list = ", & |
|---|
| 262 | ! * is used for SUPER_UX compatibility |
|---|
| 263 | List_exportToChar(POPGrid%other_list) |
|---|
| 264 | write(stdout,'(3a)') popname, ":: POPGrid%index_list = ", & |
|---|
| 265 | List_exportToChar(POPGrid%index_list) |
|---|
| 266 | write(stdout,'(2a,i3)') popname, ":: Number of integer attributes stored in POPGrid=", & |
|---|
| 267 | MCT_AtrVt_nInteger(POPGrid%data) |
|---|
| 268 | write(stdout,'(2a,i3)') popname, ":: Total Number of real attributes stored in POPGrid=", & |
|---|
| 269 | MCT_AtrVt_nReal(POPGrid%data) |
|---|
| 270 | |
|---|
| 271 | ! Get POPGrid attribute indicies |
|---|
| 272 | latindx=MCT_GGrid_indexRA(POPGrid,'grid_center_lat') |
|---|
| 273 | lonindx=MCT_GGrid_indexRA(POPGrid,'grid_center_lon') |
|---|
| 274 | |
|---|
| 275 | ! NOTE: The integer attribute GlobGridNum is automatically |
|---|
| 276 | ! appended to any General Grid. Store the grid numbering |
|---|
| 277 | ! scheme (used in the GlobalSegMap) here. |
|---|
| 278 | gridindx=MCT_GGrid_indexIA(POPGrid,'GlobGridNum') |
|---|
| 279 | |
|---|
| 280 | do i=1,MCT_GGrid_lsize(POPGrid) |
|---|
| 281 | POPGrid%data%iAttr(gridindx,i)=i |
|---|
| 282 | enddo |
|---|
| 283 | |
|---|
| 284 | ! Check the weight values of the grid_area attribute |
|---|
| 285 | |
|---|
| 286 | dAindx = MCT_GGrid_indexRA(POPGrid, 'grid_area') |
|---|
| 287 | |
|---|
| 288 | write(stdout,'(2a)') popname, & |
|---|
| 289 | ':: Various checks of GeneralGrid POPGrid Weight data...' |
|---|
| 290 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 291 | ':: direct ref--POPGrid 1st dA entry=.', & |
|---|
| 292 | POPGrid%data%rAttr(dAindx,1) |
|---|
| 293 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 294 | ':: direct ref--POPGrid last dA entry=.', & |
|---|
| 295 | POPGrid%data%rAttr(dAindx,MCT_GGrid_lsize(POPGrid)) |
|---|
| 296 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 297 | ':: Sum of dA(1,...,Nox*Noy)=.', sum(POPGrid%data%rAttr(dAindx,:)) |
|---|
| 298 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 299 | ':: Unit Sphere area 4 * pi=.', 4.*pi |
|---|
| 300 | |
|---|
| 301 | ! Check on coordinate values (and check some export functions, too...) |
|---|
| 302 | |
|---|
| 303 | allocate(dummyR(MCT_GGrid_lsize(POPGrid)), stat=ierr) |
|---|
| 304 | if(ierr/=0) call die(popname, "allocate(dummyR)", ierr) |
|---|
| 305 | |
|---|
| 306 | call MCT_GGrid_exportRAttr(POPGrid, 'grid_center_lat', dummyR, length) |
|---|
| 307 | |
|---|
| 308 | write(stdout,'(2a)') popname, & |
|---|
| 309 | ':: Various checks of GeneralGrid POPGrid coordinate data...' |
|---|
| 310 | write(stdout,'(2a,i8)') popname, & |
|---|
| 311 | ':: No. exported POPGrid latitude values =.',length |
|---|
| 312 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 313 | ':: export--POPGrid 1st latitude=.',dummyR(1) |
|---|
| 314 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 315 | ':: export--POPGrid last latitude=.',dummyR(length) |
|---|
| 316 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 317 | ':: direct ref--POPGrid 1st latitude=.', & |
|---|
| 318 | POPGrid%data%rAttr(latindx,1) |
|---|
| 319 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 320 | ':: direct ref--POPGrid last latitude=.', & |
|---|
| 321 | POPGrid%data%rAttr(latindx,length) |
|---|
| 322 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 323 | ':: direct ref--POPGrid 1st longitude=.', & |
|---|
| 324 | POPGrid%data%rAttr(lonindx,1) |
|---|
| 325 | write(stdout,'(2a,f12.6)') popname, & |
|---|
| 326 | ':: direct ref--POPGrid last longitude=.', & |
|---|
| 327 | POPGrid%data%rAttr(lonindx,MCT_GGrid_lsize(POPGrid)) |
|---|
| 328 | write(stdout,'(2a)') popname, & |
|---|
| 329 | ':: End checks of GeneralGrid POPGrid coordinate data.' |
|---|
| 330 | |
|---|
| 331 | ! Check the GlobalGridNum values: |
|---|
| 332 | |
|---|
| 333 | allocate(dummyI(MCT_GGrid_lsize(POPGrid)), stat=ierr) |
|---|
| 334 | if(ierr/=0) call die(popname, "allocate(dummyI)", ierr) |
|---|
| 335 | |
|---|
| 336 | call MCT_GGrid_exportIAttr(POPGrid, 'GlobGridNum', dummyI, length) |
|---|
| 337 | |
|---|
| 338 | write(stdout,'(2a,i8)') popname, & |
|---|
| 339 | ':: No. exported POPGrid GlobalGridNum values =.',length |
|---|
| 340 | write(stdout,'(2a,i8)') popname, & |
|---|
| 341 | ':: export--POPGrid 1st GlobalGridNum =.', dummyI(1) |
|---|
| 342 | write(stdout,'(2a,i8)') popname, & |
|---|
| 343 | ':: export--POPGrid last GlobalGridNum =.', dummyI(length) |
|---|
| 344 | write(stdout,'(2a,i8)') popname, & |
|---|
| 345 | ':: direct ref--POPGrid 1st GlobalGridNum =.', & |
|---|
| 346 | POPGrid%data%iAttr(gridindx,1) |
|---|
| 347 | write(stdout,'(2a,i8)') popname, & |
|---|
| 348 | ':: direct ref--POPGrid last GlobalGridNum =.', & |
|---|
| 349 | POPGrid%data%iAttr(gridindx,length) |
|---|
| 350 | |
|---|
| 351 | ! Clean temporary structures |
|---|
| 352 | |
|---|
| 353 | deallocate(dummyI, dummyR, stat=ierr) |
|---|
| 354 | if(ierr/=0) call die(popname, "deallocate(dummyI...)", ierr) |
|---|
| 355 | |
|---|
| 356 | endif ! if(myProc==0) |
|---|
| 357 | |
|---|
| 358 | ! send the ocean's grid from the ocean's root to the |
|---|
| 359 | ! coupler's root. 2800 is the randomly chosen tag base. |
|---|
| 360 | if(myProc==0) call MCT_GGrid_send(POPGrid,coupler_id,2800,ierr) |
|---|
| 361 | |
|---|
| 362 | !:::::::::::::::::::::::::::::::::::::::::::::::::::: |
|---|
| 363 | |
|---|
| 364 | ! Describe OGSMap, the ocean grid decomposition |
|---|
| 365 | |
|---|
| 366 | ! number of local oceanpoints |
|---|
| 367 | osize = (Noy * Nox)/mySize |
|---|
| 368 | osize2 = osize |
|---|
| 369 | |
|---|
| 370 | ! (Noy *Nox)/mySize isnt an integer, give extra points to last proc. |
|---|
| 371 | if(myProc == mySize - 1) then |
|---|
| 372 | osize = osize + mod(Noy*Nox,mySize) |
|---|
| 373 | endif |
|---|
| 374 | |
|---|
| 375 | ! find starting point in the numbering scheme |
|---|
| 376 | ! numbering scheme is same as that used in ocean model. |
|---|
| 377 | starts(1) = (myProc * osize2) +1 |
|---|
| 378 | lengths(1) = osize |
|---|
| 379 | |
|---|
| 380 | ! describe this information in a Global Map for the ocean. |
|---|
| 381 | call zeit_ci('OGSMapinit') |
|---|
| 382 | call MCT_GSMap_init(OGSMap,starts,lengths,0,POP_World,mycompid) |
|---|
| 383 | call zeit_co('OGSMmapinit') |
|---|
| 384 | |
|---|
| 385 | !!! test some GlobalSegMap functions |
|---|
| 386 | ! write(*,*)myProc,'number of global segs is',MCT_GSMap_ngseg(OGSMap) |
|---|
| 387 | ! write(*,*)myProc,'local size is',MCT_GSMap_lsize(OGSMap,CPL_World) |
|---|
| 388 | ! write(*,*)myProc,'global size is',MCT_GSMap_gsize(OGSMap) |
|---|
| 389 | |
|---|
| 390 | ! make a sample GlobalMap based on the local sizes of the GlobalSegMap |
|---|
| 391 | call GlobalMap_init(OGMap,mycompid,MCT_GSMap_lsize(OGSMap,POP_World), & |
|---|
| 392 | POP_World) |
|---|
| 393 | call GMap_test(GMap=OGMap,Identifier="POP::OGMap", & |
|---|
| 394 | mycomm=POP_World,device=4200+myProc) |
|---|
| 395 | |
|---|
| 396 | ! lets exchange maps with the coupler |
|---|
| 397 | call ExchangeMap(OGMap,POP_World,CPL_OGSMap,coupler_id,ierr) |
|---|
| 398 | if(ierr/=0) call die(popname,"call ExchangeMap") |
|---|
| 399 | |
|---|
| 400 | call GMap_test(GMap=OGMap,Identifier="POP::OGMap", & |
|---|
| 401 | mycomm=POP_World,device=4300+myProc) |
|---|
| 402 | call GSMap_test(CPL_OGSMap,"POP::CPL_OGSMap",POP_World,5200+myProc) |
|---|
| 403 | |
|---|
| 404 | ! Compare this to sending and recieving maps |
|---|
| 405 | if(myProc==0) then |
|---|
| 406 | |
|---|
| 407 | call GlobalSegMap_recv(inGSMap,coupler_id,777) |
|---|
| 408 | if (.NOT.(GSMap_identical(inGSMap,CPL_OGSMap))) then |
|---|
| 409 | call die(popname,"GSMap_identical(inGSMap,CPL_OGSMap)") |
|---|
| 410 | endif |
|---|
| 411 | call MCT_GSMap_clean(inGSMap) |
|---|
| 412 | |
|---|
| 413 | call GlobalSegMap_recv(inGSMap,coupler_id,888) |
|---|
| 414 | if (.NOT.(GSMap_identical(inGSMap,CPL_OGSMap))) then |
|---|
| 415 | call die(popname,"GSMap_identical(inGSMap,CPL_OGSMap)") |
|---|
| 416 | endif |
|---|
| 417 | call MCT_GSMap_clean(inGSMap) |
|---|
| 418 | |
|---|
| 419 | endif |
|---|
| 420 | |
|---|
| 421 | !:::::::GGRID COMMUNICATIONS TESTING:::::::! |
|---|
| 422 | |
|---|
| 423 | call MCT_GGrid_scatter(POPGrid,scatterGGrid,OGMap,0,POP_World) |
|---|
| 424 | call MCT_GGrid_gather(scatterGGrid,gatherGGrid,OGMap,0,POP_World) |
|---|
| 425 | |
|---|
| 426 | if(myProc==0) then |
|---|
| 427 | if(.NOT. GGrid_identical(POPGrid,gatherGGrid,0.1) ) then |
|---|
| 428 | call die(popname,"GGrid Comms test failed") |
|---|
| 429 | endif |
|---|
| 430 | endif |
|---|
| 431 | |
|---|
| 432 | ! declare an attrvect to hold all ocean model inputs |
|---|
| 433 | ! NOTE: the size of the AttrVect is set to be the local |
|---|
| 434 | ! size of the GSMap. |
|---|
| 435 | |
|---|
| 436 | call zeit_ci('OInputAVinit') |
|---|
| 437 | |
|---|
| 438 | call MCT_AtrVt_init(OinputAV, & |
|---|
| 439 | rList=& |
|---|
| 440 | ! net solar radiation |
|---|
| 441 | "solrad:& |
|---|
| 442 | ! downward direct visible radiation |
|---|
| 443 | &dirvis:& |
|---|
| 444 | ! downward diffuse visible radiation |
|---|
| 445 | &difvis:& |
|---|
| 446 | ! downward direct near-infrared radiation |
|---|
| 447 | &dirnif:& |
|---|
| 448 | ! downward diffuse near-infrared radiation |
|---|
| 449 | &difnif:& |
|---|
| 450 | ! convective precip |
|---|
| 451 | &precc:& |
|---|
| 452 | ! large-scale precip |
|---|
| 453 | &precl",& |
|---|
| 454 | lsize=MCT_GSMap_lsize(OGSMap, POP_World)) |
|---|
| 455 | |
|---|
| 456 | call zeit_co('OinputAVinit') |
|---|
| 457 | |
|---|
| 458 | ! declare an attrvect to hold all ocean model outputs |
|---|
| 459 | ! NOTE: the size of the AttrVect is set to be the local |
|---|
| 460 | ! size of the GSMap. |
|---|
| 461 | |
|---|
| 462 | call zeit_ci('OoutputAVinit') |
|---|
| 463 | |
|---|
| 464 | call MCT_AtrVt_init(OoutputAV, & |
|---|
| 465 | rList=& |
|---|
| 466 | ! East-West Gradient of Ocean Surface Height |
|---|
| 467 | "dhdx:& |
|---|
| 468 | ! North-South Gradient of Ocean Surface Height |
|---|
| 469 | &dhdy:& |
|---|
| 470 | ! Heat of Fusion of Ocean Water |
|---|
| 471 | &Qfusion:& |
|---|
| 472 | ! Sea Surface Temperature |
|---|
| 473 | &SST:& |
|---|
| 474 | ! Salinity |
|---|
| 475 | &salinity:& |
|---|
| 476 | ! East Component of the Surface Current |
|---|
| 477 | &Uocean:& |
|---|
| 478 | ! East Component of the Surface Current |
|---|
| 479 | &Vocean",& |
|---|
| 480 | lsize=MCT_GSMap_lsize(OGSMap, POP_World)) |
|---|
| 481 | |
|---|
| 482 | call zeit_co('OoutputAVinit') |
|---|
| 483 | |
|---|
| 484 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!--Build Router |
|---|
| 485 | ! |
|---|
| 486 | ! Intialize router between atmosphere and coupler using AGSMap. |
|---|
| 487 | ! This call must be paired with a similar call in cp |
|---|
| 488 | call zeit_ci('OCplRouterInit') |
|---|
| 489 | call MCT_Router_init(coupler_id,OGSMap,POP_World,Cpl2Ocn) |
|---|
| 490 | call zeit_co('OCplRouterInit') |
|---|
| 491 | |
|---|
| 492 | call Router_test(Cpl2Ocn,"POP::Cpl2Ocn",7200+myProc) |
|---|
| 493 | |
|---|
| 494 | !::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: |
|---|
| 495 | |
|---|
| 496 | ! Lets prepare to do some neat integrals using MCT. |
|---|
| 497 | ! First, we must scatter the Ocean Grid: |
|---|
| 498 | |
|---|
| 499 | call MCT_GGrid_scatter(POPGrid, dPOPGrid, OGSMap, 0, POP_World) |
|---|
| 500 | |
|---|
| 501 | ! Then, receive the accumulated and interpolated attrvect from the coupler |
|---|
| 502 | if(myProc == 0) write(stdout,*) popname,':: Before MCT_RECV from CPL.' |
|---|
| 503 | call zeit_ci('OinputAVrecv') |
|---|
| 504 | call MCT_Recv(OinputAV,Cpl2Ocn) |
|---|
| 505 | call zeit_co('OinputAVrecv') |
|---|
| 506 | call AttrVect_test(OinputAV,"POP::OinputAV",2600) |
|---|
| 507 | if(myProc == 0) write(stdout,*) popname,':: After MCT_RECV from CPL.' |
|---|
| 508 | |
|---|
| 509 | ! Lets check the values to make sure our asci matrix file |
|---|
| 510 | ! corresponds to the imask in our GeneralGrid. |
|---|
| 511 | allocate(MaskVector(MCT_GGrid_lsize(dPOPGrid)), stat=ierr) |
|---|
| 512 | if(ierr/=0) call die(popname, "allocate(dPOPGrid)", ierr) |
|---|
| 513 | |
|---|
| 514 | call MCT_GGrid_exportIAttr(dPOPGrid,"grid_imask",MaskVector,k) |
|---|
| 515 | |
|---|
| 516 | if(MCT_GGrid_lsize(dPOPGrid)/=k) then |
|---|
| 517 | call die(popname,"MCT_GGrid_exportIAttr failed") |
|---|
| 518 | endif |
|---|
| 519 | |
|---|
| 520 | do i=1,k |
|---|
| 521 | if(MaskVector(i)==0) then |
|---|
| 522 | if(abs(OinputAV%rAttr(1,i)-MaskVector(i)) > 1e-4) then |
|---|
| 523 | call die(popname,"GeneralGrid Mask does not match & |
|---|
| 524 | &matrix file mask") |
|---|
| 525 | endif |
|---|
| 526 | endif |
|---|
| 527 | enddo |
|---|
| 528 | |
|---|
| 529 | deallocate(MaskVector,stat=ierr) |
|---|
| 530 | if(ierr/=0) call die(popname,"deallocate(MaskVector)",ierr) |
|---|
| 531 | |
|---|
| 532 | ! TEST MAPPING FOR HMV |
|---|
| 533 | |
|---|
| 534 | call AttrVect_gather(OinputAV,gatherAV_ocn,OGSMap, & |
|---|
| 535 | 0,POP_World,ierr) |
|---|
| 536 | |
|---|
| 537 | if(myProc == 0) then |
|---|
| 538 | unit = luavail() + 9000 |
|---|
| 539 | write(unit,*) Nox, Noy |
|---|
| 540 | k=0 |
|---|
| 541 | do i=1,Nox |
|---|
| 542 | do j=1,Noy |
|---|
| 543 | k=k+1 |
|---|
| 544 | write(unit,*) gatherAV_ocn%rAttr(1,k) |
|---|
| 545 | enddo |
|---|
| 546 | enddo |
|---|
| 547 | call MCT_AtrVt_clean(gatherAV_ocn) |
|---|
| 548 | endif |
|---|
| 549 | |
|---|
| 550 | ! Now, Test the MCT Spatial Integration/Averaging Services... |
|---|
| 551 | if(myProc==0)write(stdout,'(3a)') popname,':: on-Root test of MCT Spatial ', & |
|---|
| 552 | 'Integration Services...' |
|---|
| 553 | |
|---|
| 554 | ! simple unmasked integral case: |
|---|
| 555 | |
|---|
| 556 | call MCT_SpatialIntegral(OinputAV, integratedOinputAV, dPOPGrid, 'grid_area', & |
|---|
| 557 | comm=POP_World) |
|---|
| 558 | |
|---|
| 559 | if(myProc==0)then |
|---|
| 560 | do i=1,MCT_AtrVt_nReal(integratedOinputAV) |
|---|
| 561 | write(stdout,'(3a,i2,a,f12.6)') popname,':: Unmasked distributed MCT ', & |
|---|
| 562 | 'integral: integratedOinputAV%rAttr(',i,',1)=', & |
|---|
| 563 | integratedOinputAV%rAttr(i,1) |
|---|
| 564 | end do |
|---|
| 565 | endif |
|---|
| 566 | |
|---|
| 567 | call MCT_AtrVt_clean(integratedOinputAV) |
|---|
| 568 | |
|---|
| 569 | ! simple unmasked average case: |
|---|
| 570 | call MCT_SpatialAverage(OinputAV, integratedOinputAV, dPOPGrid, 'grid_area', & |
|---|
| 571 | comm=POP_World) |
|---|
| 572 | |
|---|
| 573 | if(myProc==0)then |
|---|
| 574 | do i=1,MCT_AtrVt_nReal(integratedOinputAV) |
|---|
| 575 | write(stdout,'(3a,i2,a,f12.6)') popname,':: Unmasked distributed MCT ', & |
|---|
| 576 | 'average: averagedOinputAV%rAttr(',i,',1)=', & |
|---|
| 577 | integratedOinputAV%rAttr(i,1) |
|---|
| 578 | end do |
|---|
| 579 | endif |
|---|
| 580 | call MCT_AtrVt_clean(integratedOinputAV) |
|---|
| 581 | |
|---|
| 582 | ! masked average case... |
|---|
| 583 | |
|---|
| 584 | call MCT_MaskedSpatialAverage(inAv=OinputAV, outAv=integratedOinputAV, & |
|---|
| 585 | GGrid=dPOPGrid, SpatialWeightTag='grid_area', & |
|---|
| 586 | iMaskTags='grid_imask', UseFastMethod=.TRUE., & |
|---|
| 587 | comm=POP_World) |
|---|
| 588 | |
|---|
| 589 | if(myProc==0)then |
|---|
| 590 | do i=1,MCT_AtrVt_nReal(integratedOinputAV) |
|---|
| 591 | write(stdout,'(3a,i2,a,f12.6)') popname,':: Masked distributed MCT ', & |
|---|
| 592 | 'average (both iMask & rMask = unity): averagedOinputAV%rAttr(',i,',1)=', & |
|---|
| 593 | integratedOinputAV%rAttr(i,1) |
|---|
| 594 | end do |
|---|
| 595 | endif |
|---|
| 596 | call MCT_AtrVt_clean(integratedOinputAV) |
|---|
| 597 | |
|---|
| 598 | call GGrid_test(dPOPGrid,"POP::dPOPGrid",3500+myProc) |
|---|
| 599 | |
|---|
| 600 | ! Fill the Ocean's output with test values: |
|---|
| 601 | ! the first attribute will be constant, while |
|---|
| 602 | ! the rest will contain interolated values from OinputAV |
|---|
| 603 | call AttrVect_copy(aVin=OinputAV,aVout=OoutputAV, & |
|---|
| 604 | rList=List_exportToChar(OinputAV%rList), & |
|---|
| 605 | TrList=List_exportToChar(OoutputAV%rList)) |
|---|
| 606 | |
|---|
| 607 | OoutputAV%rAttr(1,:) = 30. |
|---|
| 608 | |
|---|
| 609 | ! Now, send the Ocean's output to the Coupler... |
|---|
| 610 | if(myProc == 0) write(stdout,*) popname,':: Before MCT_SEND to CPL.' |
|---|
| 611 | call zeit_ci('OoutputAVsend') |
|---|
| 612 | call MCT_Send(OoutputAV,Cpl2Ocn) |
|---|
| 613 | call zeit_co('OoutputAVsend') |
|---|
| 614 | if(myProc == 0) write(stdout,*) popname,':: After MCT_SEND to CPL.' |
|---|
| 615 | |
|---|
| 616 | ! All Done |
|---|
| 617 | call zeit_ci('Ocleanup') |
|---|
| 618 | |
|---|
| 619 | ! Clean MCT datatypes |
|---|
| 620 | if(myProc==0) then |
|---|
| 621 | call MCT_GGrid_clean(POPGrid) |
|---|
| 622 | call MCT_GGrid_clean(gatherGGrid) |
|---|
| 623 | endif |
|---|
| 624 | |
|---|
| 625 | call MCT_GGrid_clean(scatterGGrid) |
|---|
| 626 | call MCT_GGrid_clean(dPOPGrid) |
|---|
| 627 | call MCT_AtrVt_clean(OinputAV) |
|---|
| 628 | call MCT_AtrVt_clean(OoutputAV) |
|---|
| 629 | call MCT_GSMap_clean(OGSMap) |
|---|
| 630 | call MCT_GSMap_clean(CPL_OGSMap) |
|---|
| 631 | call GlobalMap_clean(OGMap) |
|---|
| 632 | call MCT_Router_clean(Cpl2Ocn) |
|---|
| 633 | call MCTWorld_clean() |
|---|
| 634 | |
|---|
| 635 | call zeit_co('Ocleanup') |
|---|
| 636 | |
|---|
| 637 | ! write out timing info to fortran unit 47 |
|---|
| 638 | call zeit_allflush(POP_World,0,47) |
|---|
| 639 | |
|---|
| 640 | |
|---|
| 641 | end subroutine |
|---|
| 642 | |
|---|
| 643 | |
|---|
| 644 | |
|---|
| 645 | |
|---|
| 646 | |
|---|
| 647 | |
|---|
| 648 | |
|---|
| 649 | |
|---|
| 650 | |
|---|
