47 INTEGER(kind=ip_i4_p),
intent(inout) :: kinfo
49 integer(kind=ip_i4_p) :: cplid,partid,varid,mapid
50 INTEGER(kind=ip_i4_p) :: nf,lsize,nflds,npc
51 integer(kind=ip_i4_p) :: dt,ltime,lag,getput
52 integer(kind=ip_i4_p) :: msec
53 real (kind=ip_r8_p),
allocatable :: array(:)
54 real (kind=ip_r8_p),
allocatable :: array2(:)
55 real (kind=ip_r8_p),
allocatable :: array3(:)
56 real (kind=ip_r8_p),
allocatable :: array4(:)
57 real (kind=ip_r8_p),
allocatable :: array5(:)
58 logical :: a2on,a3on,a4on,a5on
59 integer(kind=ip_i4_p) :: mseclag
60 character(len=ic_xl) :: rstfile
61 character(len=ic_xxl) :: lstring
62 integer(kind=ip_i4_p) :: llstring
63 character(len=ic_med) :: vstring
64 integer(kind=ip_i4_p) :: lvarnum
65 type(mct_string) :: mstring
66 character(len=64) :: vname
68 character(len=*),
parameter :: subname =
'(oasis_advance_init)' 69 logical,
parameter :: local_timers_on = .false.
79 write(
nulprt,*) subname,
estr,
'called on non coupling task' 88 write(
nulprt,*)
' subname at time time+lag act: field ' 89 write(
nulprt,*)
' diags : fldname min max sum ' 103 if (pcpointer%valid)
then 106 ltime = pcpointer%ltime
107 getput= pcpointer%getput
108 rstfile=trim(pcpointer%rstfile)
109 partid= pcpointer%partID
110 mapid = pcpointer%mapperid
115 WRITE(
nulprt,*)
'----------------------------------------------------------------' 116 WRITE(
nulprt,*) subname,
' Field cplid :',cplid
117 WRITE(
nulprt,*) subname,
' read restart:',npc,trim(pcpointer%fldlist)
119 WRITE(
nulprt,*) subname,
' getput , mapid :',getput, mapid
120 WRITE(
nulprt,*)
'----------------------------------------------------------------' 128 IF (lag > dt .OR. lag <= -dt)
THEN 129 WRITE(
nulprt,*) subname,
estr,
'lag out of dt range cplid/dt/lag=',cplid,dt,lag
140 IF ( (getput ==
oasis3_put .AND. lag > 0) )
THEN 142 lsize = mct_avect_lsize(pcpointer%aVect1)
143 nflds = mct_avect_nrattr(pcpointer%aVect1)
145 ALLOCATE(array(lsize))
146 ALLOCATE(array2(lsize))
147 ALLOCATE(array3(lsize))
148 ALLOCATE(array4(lsize))
149 ALLOCATE(array5(lsize))
164 varid = pcpointer%varid(nf)
165 call mct_avect_getrlist(mstring,nf,pcpointer%aVect1)
166 vname = mct_string_tochar(mstring)
167 call mct_string_clean(mstring)
170 namid=cplid,array1din=array,&
171 readrest=.true., a2on=a2on,array2=array2, &
172 a3on=a3on,array3=array3, &
173 a4on=a4on,array4=array4,a5on=a5on,array5=array5, &
177 write(
nulprt,*) subname,
' advance_run ',cplid,trim(pcpointer%fldlist)
200 IF (pcpointer%valid)
then 203 ltime = pcpointer%ltime
204 getput= pcpointer%getput
205 rstfile=trim(pcpointer%rstfile)
206 partid= pcpointer%partID
211 WRITE(
nulprt,*)
'----------------------------------------------------------------' 212 WRITE(
nulprt,*) subname,
' Field cplid :',cplid
213 WRITE(
nulprt,*) subname,
' loctrans:',npc,trim(pcpointer%fldlist)
214 WRITE(
nulprt,*)
'----------------------------------------------------------------' 226 if (len_trim(rstfile) < 1)
then 227 write(
nulprt,*) subname,
estr,
'restart undefined' 231 lstring = pcpointer%fldlist
232 llstring = len_trim(lstring)
233 if (llstring <= 20)
then 234 write(
nulprt,*) subname,
' at ',msec,mseclag,
' RTRN: ', &
235 trim(lstring),
' ',trim(rstfile)
237 write(
nulprt,*) subname,
' at ',msec,mseclag,
' RTRN: ',lstring(1:20), &
238 lstring(21:llstring),
' ',trim(rstfile)
241 lsize = mct_avect_lsize(pcpointer%aVect1)
243 write(vstring,
'(a,i6.6,a)')
'loc',pcpointer%namID,
'_cnt' 245 ivarname=trim(vstring),abort=.false.)
247 write(vstring,
'(a,i6.6,a)')
'loc',pcpointer%namID,
'_' 250 abort=.false.,nampre=trim(vstring))
252 call mct_avect_init(pcpointer%aVect2,pcpointer%aVect1,lsize)
253 call mct_avect_zero(pcpointer%aVect2)
254 write(vstring,
'(a,i6.6,a)')
'av2loc',pcpointer%namID,
'_' 257 abort=.false.,nampre=trim(vstring),&
258 didread=pcpointer%aVon(2))
259 if (.not. pcpointer%aVon(2))
then 260 call mct_avect_clean(pcpointer%avect2)
263 call mct_avect_init(pcpointer%aVect3,pcpointer%aVect1,lsize)
264 call mct_avect_zero(pcpointer%aVect3)
265 write(vstring,
'(a,i6.6,a)')
'av3loc',pcpointer%namID,
'_' 268 abort=.false.,nampre=trim(vstring),&
269 didread=pcpointer%aVon(3))
270 if (.not. pcpointer%aVon(3))
then 271 call mct_avect_clean(pcpointer%avect3)
274 call mct_avect_init(pcpointer%aVect4,pcpointer%aVect1,lsize)
275 call mct_avect_zero(pcpointer%aVect4)
276 write(vstring,
'(a,i6.6,a)')
'av4loc',pcpointer%namID,
'_' 279 abort=.false.,nampre=trim(vstring),&
280 didread=pcpointer%aVon(4))
281 if (.not. pcpointer%aVon(4))
then 282 call mct_avect_clean(pcpointer%avect4)
285 call mct_avect_init(pcpointer%aVect5,pcpointer%aVect1,lsize)
286 call mct_avect_zero(pcpointer%aVect5)
287 write(vstring,
'(a,i6.6,a)')
'av5loc',pcpointer%namID,
'_' 290 abort=.false.,nampre=trim(vstring),&
291 didread=pcpointer%aVon(5))
292 if (.not. pcpointer%aVon(5))
then 293 call mct_avect_clean(pcpointer%avect5)
297 write(
nulprt,*) subname,
' DEBUG read loctrans restart',&
298 cplid,pcpointer%avcnt
299 write(
nulprt,*) subname,
' DEBUG read loctrans restart',cplid,&
300 minval(pcpointer%avect1%rAttr),&
301 maxval(pcpointer%avect1%rAttr)
321 array1din,array1dout,array2dout,readrest,&
322 a2on,array2,a3on,array3,a4on,array4,a5on,array5, &
327 integer(kind=ip_i4_p),
intent(in) :: mop
328 INTEGER(kind=ip_i4_p),
intent(in) :: varid
329 INTEGER(kind=ip_i4_p),
intent(in) :: msec
330 INTEGER(kind=ip_i4_p),
intent(inout) :: kinfo
332 INTEGER(kind=ip_i4_p),
optional :: nff
333 INTEGER(kind=ip_i4_p),
optional :: namid
335 REAL (kind=ip_r8_p),
optional :: array1din(:)
336 REAL (kind=ip_r8_p),
optional :: array1dout(:)
337 REAL (kind=ip_r8_p),
optional :: array2dout(:,:)
338 logical ,
optional :: readrest
340 logical ,
optional :: a2on
341 REAL (kind=ip_r8_p),
optional :: array2(:)
342 logical ,
optional :: a3on
343 REAL (kind=ip_r8_p),
optional :: array3(:)
344 logical ,
optional :: a4on
345 REAL (kind=ip_r8_p),
optional :: array4(:)
346 logical ,
optional :: a5on
347 REAL (kind=ip_r8_p),
optional :: array5(:)
348 logical ,
optional :: writrest
349 INTEGER(kind=ip_i4_p),
optional :: varnum
351 character(len=ic_lvar):: vname
352 INTEGER(kind=ip_i4_p) :: cplid,rouid,mapid,partid
353 INTEGER(kind=ip_i4_p) :: nfav,nsav,nsa,n,nc,nf,npc
354 INTEGER(kind=ip_i4_p) :: lsize,nflds,ierr
355 integer(kind=ip_i4_p) :: tag,dt,ltime,lag,getput,maxtime,conserv
356 character(len=ic_med) :: consopt
357 logical :: sndrcv,output,input,unpack
358 logical :: snddiag,rcvdiag
360 LOGICAL :: didread, readabort
361 real(kind=ip_double_p):: sndmult,sndadd,rcvmult,rcvadd
362 character(len=ic_xl) :: rstfile
363 character(len=ic_xl) :: rstfile2
364 character(len=ic_xl) :: inpfile
365 integer(kind=ip_i4_p) :: nx,ny
366 integer(kind=ip_i4_p) :: mseclag
367 integer(kind=ip_i4_p) :: lvarnum
368 real(kind=ip_r8_p) :: rcnt
369 character(len=ic_med) :: tstring
370 character(len=ic_med) :: fstring
371 character(len=ic_med) :: cstring
372 character(len=ic_med) :: vstring
373 character(len=ic_xxl) :: lstring
374 integer(kind=ip_i4_p) :: llstring
379 TYPE(mct_avect) :: avtest
380 type(mct_avect) :: avtmp
381 type(mct_avect) :: avtmp2
382 type(mct_avect) :: avtmp3
383 type(mct_avect) :: avtmp4
384 type(mct_avect) :: avtmp5
385 type(mct_avect) :: avtmpW
388 logical,
parameter :: local_timers_on = .false.
389 character(len=*),
parameter :: subname =
'(oasis_advance_run)' 390 character(len=*),
parameter :: F01 =
'(a,i3.3)' 401 write(
nulprt,*) subname,
estr,
'called on non coupling task' 411 if (
present(varnum))
then 419 write(
nulprt,*) subname,
' DEBUG vname ',varid,lvarnum,
' ',trim(vname)
423 if (
present(readrest))
then 433 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
434 write(
nulprt,*) subname,
estr,
'mop invalid expecting OASIS_Out or OASIS_In = ',mop
444 if (
present(namid))
then 452 if (cplid == namid) runit = .true.
455 WRITE(
nulprt,*) subname,
estr,
'namid not found for var = ',trim(vname)
467 if (
present(a2on)) arrayon(2) = a2on
468 if (
present(a3on)) arrayon(3) = a3on
469 if (
present(a4on)) arrayon(4) = a4on
470 if (
present(a5on)) arrayon(5) = a5on
473 write(
nulprt,*) subname,
' lreadrest :',lreadrest,
' arrayon = ',arrayon
484 if (
present(namid))
then 486 if (cplid == namid) runit = .true.
496 if (.not.pcpointer%valid)
then 497 WRITE(
nulprt,*) subname,
estr,
'invalid prism_coupler for var = ',trim(vname)
504 getput = pcpointer%getput
509 write(
nulprt,*) subname,
estr,
'model def_var in-out does not match model get-put call for var = ',trim(vname)
516 rouid = pcpointer%routerid
517 mapid = pcpointer%mapperid
521 ltime = pcpointer%ltime
522 sndrcv = pcpointer%sndrcv
523 rstfile = trim(pcpointer%rstfile)
524 inpfile = trim(pcpointer%inpfile)
525 maxtime = pcpointer%maxtime
526 output = pcpointer%output
527 input = pcpointer%input
528 partid = pcpointer%partID
529 conserv = pcpointer%conserv
530 consopt = pcpointer%consopt
531 snddiag = pcpointer%snddiag
532 rcvdiag = pcpointer%rcvdiag
533 sndadd = pcpointer%sndadd
534 sndmult = pcpointer%sndmult
535 rcvadd = pcpointer%rcvadd
536 rcvmult = pcpointer%rcvmult
540 if (
present(writrest))
then 541 if (writrest .and. mop /=
oasis_out)
then 542 write(
nulprt,*) subname,
estr,
'mop must be OASIS_Out if writrest is true, mop=',mop
545 if (writrest) pcpointer%writrest = writrest
548 unpack = (sndrcv .OR. input)
560 WRITE(
nulprt,*) subname,
' DEBUG nx, ny = ',nx,ny
568 IF (abs(lag) > dt)
THEN 569 WRITE(
nulprt,*) subname,
estr,
'lag setting greater than dt for var = ',trim(vname)
580 IF (getput ==
oasis3_put .AND. lag > 0 .AND. lreadrest)
THEN 584 IF (.not.
present(nff))
THEN 585 WRITE(
nulprt,*) subname,
estr,
'nff optional argument not passed but expected for var = ',trim(vname)
588 IF (len_trim(rstfile) < 1)
THEN 589 WRITE(
nulprt,*) subname,
estr,
'restart file undefined for var = ',trim(vname)
592 lsize = mct_avect_lsize(pcpointer%aVect1)
594 lstring = pcpointer%fldlist
595 llstring = len_trim(lstring)
596 if (llstring <= 20)
then 597 WRITE(
nulprt,*) subname,
' at ',msec,mseclag,
' RRST: ', &
598 trim(lstring),
' ',trim(rstfile)
600 WRITE(
nulprt,*) subname,
' at ',msec,mseclag,
' RRST: ',lstring(1:20),&
601 lstring(21:llstring),
' ',trim(rstfile)
605 CALL mct_avect_init(avtmp,rlist=pcpointer%fldlist,lsize=lsize)
613 write(vstring,
'(a2,i1.1,a1)')
'av',n,
'_' 623 avtmp%rAttr(nff,1:lsize) = 0.0
625 abort=readabort,nampre=vstring,didread=didread)
626 if (n == 1) array1din(1:lsize) = avtmp%rAttr(nff,1:lsize)
627 if (n == 2) array2(1:lsize) = avtmp%rAttr(nff,1:lsize)
628 if (n == 3) array3(1:lsize) = avtmp%rAttr(nff,1:lsize)
629 if (n == 4) array4(1:lsize) = avtmp%rAttr(nff,1:lsize)
630 if (n == 5) array5(1:lsize) = avtmp%rAttr(nff,1:lsize)
632 if (.not.readabort .and. .not.didread)
then 633 WRITE(
nulprt,*) subname,
wstr,
'restart field missing with readabort = ',readabort
634 WRITE(
nulprt,*) subname,
wstr,
'restart field missing for file = ',trim(rstfile)
635 WRITE(
nulprt,*) subname,
wstr,
'restart field missing for hot = ',n
636 WRITE(
nulprt,*) subname,
wstr,
'restart field missing setting values to zero' 640 CALL mct_avect_clean(avtmp)
656 write(
nulprt,*) subname,
' DEBUG msec,mseclag = ',msec,mseclag
661 if (mod(mseclag,dt) == 0) time_now = .true.
667 if (msec >= maxtime)
then 668 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
669 write(
nulprt,*) subname,
estr,
'model time beyond namcouple maxtime = ',msec,maxtime
678 if (pcpointer%ctime /=
ispval .and. msec >= 0 .and. msec < pcpointer%ctime)
then 679 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
680 write(
nulprt,*) subname,
estr,
'model seems to be running backwards = ',pcpointer%ctime
695 if (pcpointmp%valid)
then 696 if (
prism_part(pcpointmp%partID)%lsize > 0)
then 699 write(
nulprt,
'(2a,4i6,2l3,i8)') subname,
'deadlock_chkA ',varid,nc,n,npc,sndrcv,pcpointmp%sndrcv,msec
700 write(
nulprt,
'(2a,1x,a,2i8,1x,a,2i8)') subname,
'deadlock_chkB ',trim(pcpointer%fldlist),pcpointer%ltime,pcpointer%dt,trim(pcpointmp%fldlist),pcpointmp%ltime,pcpointmp%dt
703 if ((sndrcv .and. pcpointmp%sndrcv .and. time_now) .and. &
704 ((pcpointmp%ltime /=
ispval .and. msec > pcpointmp%ltime + pcpointmp%dt) .or. &
705 (pcpointmp%ltime ==
ispval .and. pcpointer%ltime /=
ispval .and. msec >= pcpointmp%dt )))
then 706 write(
nulprt,
'(3a)') subname,
estr,
'coupling skipped at earlier time, potential deadlock ' 707 write(
nulprt,
'(3a,i8,2a)') subname,
estr,
'my coupler = ',cplid,
' variable = ',&
708 trim(pcpointer%fldlist)
709 write(
nulprt,
'(3a,i12,a,i12)') subname,
estr,
'current time = ',msec,
' mseclag = ',mseclag
710 write(
nulprt,
'(3a,2i12)') subname,
estr,
'my coupler last time and dt = ',pcpointer%ltime,pcpointer%dt
711 write(
nulprt,
'(3a,i8,2a)') subname,
estr,
'skipped coupler = ',n,
' variable = ',&
712 trim(pcpointmp%fldlist)
713 write(
nulprt,
'(3a,2i12)') subname,
estr,
'skipped coupler last time and dt = ',&
714 pcpointmp%ltime,pcpointmp%dt
730 write(
nulprt,*) subname,
estr,
'coupling sequence out of order, potential deadlock ' 731 write(
nulprt,*) subname,
estr,
'my coupler = ',cplid,
' variable = ',&
732 trim(pcpointer%fldlist)
733 write(
nulprt,*) subname,
' ERRRO: sequence number = ',pcpointer%seq
734 write(
nulprt,*) subname,
estr,
'current time = ',msec,
' mseclag = ',mseclag
736 WRITE(
nulprt,*) subname,
estr,
'model sequence does not match coupling sequence' 752 nfav = mct_avect_indexra(pcpointer%avect1,trim(vname))
753 nsav = mct_avect_lsize(pcpointer%avect1)
754 if (lag > 0 .and. lreadrest) nsa=
size(array1din)
755 if (
present(array1din )) nsa =
size(array1din )
756 if (
present(array1dout)) nsa =
size(array1dout)
757 if (
present(array2dout)) nsa =
size(array2dout)
760 write(
nulprt,*) subname,
' DEBUG nfav,nsav,nsa = ',nfav,nsav,nsa
763 if (nsav /= nsa)
then 764 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
765 write(
nulprt,*) subname,
estr,
'in field size passed into get/put compare to expected size ',nsav,nsa
769 if (nfav < 1 .or. nfav > mct_avect_nrattr(pcpointer%avect1))
then 770 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
771 write(
nulprt,*) subname,
estr,
'ivalid variable name nfav = ',nfav
783 (getput ==
oasis3_put .and. trim(pcpointer%maploc) ==
"dst" ))
then 784 if (arrayon(2) .or. arrayon(3) .or. &
785 arrayon(4) .or. arrayon(5))
then 786 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
787 write(
nulprt,*) subname,
estr,
'higher order mapping not allowed on get side' 788 write(
nulprt,*) subname,
estr,
'consider changing map location from dst to src' 793 if ((arrayon(2) .and. .not.
present(array2)) .or. &
794 (arrayon(3) .and. .not.
present(array3)) .or. &
795 (arrayon(4) .and. .not.
present(array4)) .or. &
796 (arrayon(5) .and. .not.
present(array5)))
then 797 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
798 write(
nulprt,*) subname,
estr,
'arrayon true but array not sent' 806 if (arrayon(2) .and. .not. pcpointer%aVon(2))
then 807 call mct_avect_init(pcpointer%aVect2,pcpointer%aVect1,nsav)
808 call mct_avect_zero(pcpointer%aVect2)
809 pcpointer%aVon(2) = .true.
811 write(
nulprt,*) subname,
' at ',msec,mseclag,
' ALLO: ',&
812 trim(vname),
' ',
'aVect2' 816 if (arrayon(3) .and. .not. pcpointer%aVon(3))
then 817 call mct_avect_init(pcpointer%aVect3,pcpointer%aVect1,nsav)
818 call mct_avect_zero(pcpointer%aVect3)
819 pcpointer%aVon(3) = .true.
821 write(
nulprt,*) subname,
' at ',msec,mseclag,
' ALLO: ',&
822 trim(vname),
' ',
'aVect3' 826 if (arrayon(4) .and. .not. pcpointer%aVon(4))
then 827 call mct_avect_init(pcpointer%aVect4,pcpointer%aVect1,nsav)
828 call mct_avect_zero(pcpointer%aVect4)
829 pcpointer%aVon(4) = .true.
831 write(
nulprt,*) subname,
' at ',msec,mseclag,
' ALLO: ',&
832 trim(vname),
' ',
'aVect4' 836 if (arrayon(5) .and. .not. pcpointer%aVon(5))
then 837 call mct_avect_init(pcpointer%aVect5,pcpointer%aVect1,nsav)
838 call mct_avect_zero(pcpointer%aVect5)
839 pcpointer%aVon(5) = .true.
841 write(
nulprt,*) subname,
' at ',msec,mseclag,
' ALLO: ',&
842 trim(vname),
' ',
'aVect5' 856 write(tstring,f01)
'pcpy_',cplid
861 if (lreadrest .or. pcpointer%trans ==
ip_instant)
then 865 pcpointer%avect1%rAttr(nfav,n) = array1din(n)
866 if (pcpointer%aVon(2))
then 867 if (
present(array2))
then 868 pcpointer%avect2%rAttr(nfav,n) = array2(n)
870 pcpointer%avect2%rAttr(nfav,n) = 0.0
873 if (pcpointer%aVon(3))
then 874 if (
present(array3))
then 875 pcpointer%avect3%rAttr(nfav,n) = array3(n)
877 pcpointer%avect3%rAttr(nfav,n) = 0.0
880 if (pcpointer%aVon(4))
then 881 if (
present(array4))
then 882 pcpointer%avect4%rAttr(nfav,n) = array4(n)
884 pcpointer%avect4%rAttr(nfav,n) = 0.0
887 if (pcpointer%aVon(5))
then 888 if (
present(array5))
then 889 pcpointer%avect5%rAttr(nfav,n) = array5(n)
891 pcpointer%avect5%rAttr(nfav,n) = 0.0
895 pcpointer%avcnt(nfav) = 1
902 pcpointer%avect1%rAttr(nfav,n) = &
903 pcpointer%avect1%rAttr(nfav,n) + array1din(n)
904 if (pcpointer%aVon(2))
then 905 if (
present(array2))
then 906 pcpointer%avect2%rAttr(nfav,n) = &
907 pcpointer%avect2%rAttr(nfav,n) + array2(n)
910 if (pcpointer%aVon(3))
then 911 if (
present(array3))
then 912 pcpointer%avect3%rAttr(nfav,n) = &
913 pcpointer%avect3%rAttr(nfav,n) + array3(n)
916 if (pcpointer%aVon(4))
then 917 if (
present(array4))
then 918 pcpointer%avect4%rAttr(nfav,n) = &
919 pcpointer%avect4%rAttr(nfav,n) + array4(n)
922 if (pcpointer%aVon(5))
then 923 if (
present(array5))
then 924 pcpointer%avect5%rAttr(nfav,n) = &
925 pcpointer%avect5%rAttr(nfav,n) + array5(n)
929 pcpointer%avcnt(nfav) = pcpointer%avcnt(nfav) + 1
935 pcpointer%avect1%rAttr(nfav,n) = &
936 pcpointer%avect1%rAttr(nfav,n) + array1din(n)
937 if (pcpointer%aVon(2))
then 938 if (
present(array2))
then 939 pcpointer%avect2%rAttr(nfav,n) = &
940 pcpointer%avect2%rAttr(nfav,n) + array2(n)
943 if (pcpointer%aVon(3))
then 944 if (
present(array3))
then 945 pcpointer%avect3%rAttr(nfav,n) = &
946 pcpointer%avect3%rAttr(nfav,n) + array3(n)
949 if (pcpointer%aVon(4))
then 950 if (
present(array4))
then 951 pcpointer%avect4%rAttr(nfav,n) = &
952 pcpointer%avect4%rAttr(nfav,n) + array4(n)
955 if (pcpointer%aVon(5))
then 956 if (
present(array5))
then 957 pcpointer%avect5%rAttr(nfav,n) = &
958 pcpointer%avect5%rAttr(nfav,n) + array5(n)
962 pcpointer%avcnt(nfav) = 1
964 elseif (pcpointer%trans ==
ip_max)
then 967 if (pcpointer%aVon(2) .or. pcpointer%aVon(3) .or. &
968 pcpointer%aVon(4) .or. pcpointer%aVon(5))
then 969 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
970 write(
nulprt,*) subname,
estr,
'higher order mapping with MAX transform not supported' 974 if (pcpointer%avcnt(nfav) == 0)
then 975 pcpointer%avect1%rAttr(nfav,n) = array1din(n)
977 pcpointer%avect1%rAttr(nfav,n) = &
978 max(pcpointer%avect1%rAttr(nfav,n),array1din(n))
981 pcpointer%avcnt(nfav) = 1
983 elseif (pcpointer%trans ==
ip_min)
then 986 if (pcpointer%aVon(2) .or. pcpointer%aVon(3) .or. &
987 pcpointer%aVon(4) .or. pcpointer%aVon(5))
then 988 write(
nulprt,*) subname,
estr,
'at ',msec,mseclag,
' for var = ',trim(vname)
989 write(
nulprt,*) subname,
estr,
'higher order mapping with MIN transform not supported' 993 if (pcpointer%avcnt(nfav) == 0)
then 994 pcpointer%avect1%rAttr(nfav,n) = array1din(n)
996 pcpointer%avect1%rAttr(nfav,n) = &
997 min(pcpointer%avect1%rAttr(nfav,n),array1din(n))
1000 pcpointer%avcnt(nfav) = 1
1003 write(
nulprt,*) subname,
estr,
'transform not known for var = ',trim(vname),pcpointer%trans
1008 if (
oasis_debug >= 2 .and. trim(cstring) /=
'none')
then 1009 write(
nulprt,*) subname,
' at ',msec,mseclag,
' PACK: ',&
1010 trim(vname),
' ',trim(cstring)
1014 write(
nulprt,*) subname,
' DEBUG loctrans update ',cplid,
' ',&
1015 trim(cstring),pcpointer%avcnt(nfav)
1035 do nf = 1,pcpointer%nflds
1039 write(
nulprt,*) subname,
' at ',msec,mseclag,
' STAT: ',nf,
' NOT READY' 1044 write(
nulprt,*) subname,
' at ',msec,mseclag,
' STAT: ',nf,
' READY' 1065 if (pcpointer%ltime /=
ispval .and. msec <= pcpointer%ltime)
then 1066 write(
nulprt,*) subname,
estr,
'model did not advance in time correctly for var = ',trim(vname)
1067 write(
nulprt,*) subname,
estr,
'msec, ltime = ',msec,pcpointer%ltime
1078 write(tstring,f01)
'pavg_',cplid
1080 do nf = 1,pcpointer%nflds
1081 if (pcpointer%avcnt(nf) > 1)
then 1082 rcnt = 1.0/pcpointer%avcnt(nf)
1084 pcpointer%avect1%rAttr(nf,n) = &
1085 pcpointer%avect1%rAttr(nf,n) * rcnt
1086 if (pcpointer%aVon(2))
then 1087 pcpointer%avect2%rAttr(nf,n) = &
1088 pcpointer%avect2%rAttr(nf,n) * rcnt
1090 if (pcpointer%aVon(3))
then 1091 pcpointer%avect3%rAttr(nf,n) = &
1092 pcpointer%avect3%rAttr(nf,n) * rcnt
1094 if (pcpointer%aVon(4))
then 1095 pcpointer%avect4%rAttr(nf,n) = &
1096 pcpointer%avect4%rAttr(nf,n) * rcnt
1098 if (pcpointer%aVon(5))
then 1099 pcpointer%avect5%rAttr(nf,n) = &
1100 pcpointer%avect5%rAttr(nf,n) * rcnt
1105 write(
nulprt,*) subname,
' DEBUG loctrans calc0 = ',cplid,nf,&
1107 write(
nulprt,*) subname,
' DEBUG loctrans calc1 = ',cplid,nf,&
1108 minval(pcpointer%avect1%rAttr(nf,:)),&
1109 maxval(pcpointer%avect1%rAttr(nf,:))
1111 if (pcpointer%aVon(2)) &
1112 write(
nulprt,*) subname,
' DEBUG loctrans calc2 = ',cplid,nf,&
1113 minval(pcpointer%avect2%rAttr(nf,:)),&
1114 maxval(pcpointer%avect2%rAttr(nf,:))
1115 if (pcpointer%aVon(3)) &
1116 write(
nulprt,*) subname,
' DEBUG loctrans calc3 = ',cplid,nf,&
1117 minval(pcpointer%avect3%rAttr(nf,:)),&
1118 maxval(pcpointer%avect3%rAttr(nf,:))
1119 if (pcpointer%aVon(4)) &
1120 write(
nulprt,*) subname,
' DEBUG loctrans calc4 = ',cplid,nf,&
1121 minval(pcpointer%avect4%rAttr(nf,:)),&
1122 maxval(pcpointer%avect4%rAttr(nf,:))
1123 if (pcpointer%aVon(5)) &
1124 write(
nulprt,*) subname,
' DEBUG loctrans calc5 = ',cplid,nf,&
1125 minval(pcpointer%avect5%rAttr(nf,:)),&
1126 maxval(pcpointer%avect5%rAttr(nf,:))
1140 if (mseclag >= maxtime)
then 1145 if (len_trim(rstfile) > 0)
then 1146 if ((getput ==
oasis3_put .and. lag > 0 .and. mseclag == maxtime) .or. &
1147 (getput ==
oasis3_put .and. pcpointer%writrest))
then 1150 if (lag > 0 .and. mseclag == maxtime)
then 1154 pcpointer%writrest = .false.
1155 write(rstfile2,
'(a,i9.9,a,a)')
'TC',msec,
'_',trim(rstfile)
1158 write(tstring,f01)
'wrst_',cplid
1162 if (pcpointer%aVon(2)) &
1165 if (pcpointer%aVon(3)) &
1168 if (pcpointer%aVon(4)) &
1171 if (pcpointer%aVon(5)) &
1176 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1177 llstring = len_trim(lstring)
1178 if (llstring <= 20)
then 1179 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WRST: ', &
1180 trim(lstring),
' ',trim(rstfile2)
1182 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WRST: ', lstring(1:20), &
1183 lstring(21:llstring),
' ',trim(rstfile2)
1199 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1200 llstring = len_trim(lstring)
1201 if (llstring <= 20)
then 1202 write(
nulprt,*) subname,
' at ',msec,mseclag,
' SEND: ', &
1205 write(
nulprt,*) subname,
' at ',msec,mseclag,
' SEND: ',lstring(1:20), &
1206 lstring(21:llstring)
1210 if (sndadd /= 0.0_ip_double_p .or. sndmult /= 1.0_ip_double_p)
then 1213 write(
nulprt,*) subname,
' DEBUG sndmult,add = ',sndmult,sndadd
1214 write(
nulprt,*) subname,
' DEBUG put b4 sndmult,add = ',cplid,&
1215 minval(pcpointer%avect1%rAttr),&
1216 maxval(pcpointer%avect1%rAttr)
1218 pcpointer%avect1%rAttr(:,:) = pcpointer%avect1%rAttr(:,:)*sndmult &
1223 write(tstring,f01)
'pmap_',cplid
1226 write(
nulprt,*) subname,
' DEBUG put av11 b4 map = ',cplid,&
1227 minval(pcpointer%avect1%rAttr),&
1228 maxval(pcpointer%avect1%rAttr)
1229 if (pcpointer%aVon(2)) &
1230 write(
nulprt,*) subname,
' DEBUG put av2 b4 map = ',cplid,&
1231 minval(pcpointer%avect2%rAttr),&
1232 maxval(pcpointer%avect2%rAttr)
1233 if (pcpointer%aVon(3)) &
1234 write(
nulprt,*) subname,
' DEBUG put av3 b4 map = ',cplid,&
1235 minval(pcpointer%avect3%rAttr),&
1236 maxval(pcpointer%avect3%rAttr)
1237 if (pcpointer%aVon(4)) &
1238 write(
nulprt,*) subname,
' DEBUG put av4 b4 map = ',cplid,&
1239 minval(pcpointer%avect4%rAttr),&
1240 maxval(pcpointer%avect4%rAttr)
1241 if (pcpointer%aVon(5)) &
1242 write(
nulprt,*) subname,
' DEBUG put av5 b4 map = ',cplid,&
1243 minval(pcpointer%avect5%rAttr),&
1244 maxval(pcpointer%avect5%rAttr)
1253 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1254 'Balance: ',pcpointer%namID,
' Before interpo ', mpi_wtime()
1255 call mct_avect_zero(pcpointer%avect1m)
1258 pcpointer%avect1m,
prism_mapper(mapid),conserv,consopt, &
1259 pcpointer%aVon ,pcpointer%avect2, &
1260 pcpointer%avect3,pcpointer%avect4, &
1261 pcpointer%avect5,tstrinp=tstring)
1264 pcpointer%avect1m,
prism_mapper(mapid),conserv,consopt, &
1265 pcpointer%aVon ,pcpointer%avect2, &
1266 pcpointer%avect3,pcpointer%avect4, &
1270 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1271 'Balance: ',pcpointer%namID,
' After interpo ', mpi_wtime()
1273 write(tstring,f01)
'psnd_',cplid
1276 write(
nulprt,*) subname,
' DEBUG put av1m b4 send = ',cplid,&
1277 minval(pcpointer%avect1m%rAttr),&
1278 maxval(pcpointer%avect1m%rAttr)
1282 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1283 'Balance: ',pcpointer%namID,
' Before MPI put ', mpi_wtime()
1285 call mct_isend(pcpointer%avect1m,
prism_router(rouid)%router,tag)
1287 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1288 'Balance: ',pcpointer%namID,
' After MPI put ', mpi_wtime()
1291 write(tstring,f01)
'psnd_',cplid
1294 write(
nulprt,*) subname,
' DEBUG put av1 b4 send = ',cplid,&
1295 minval(pcpointer%avect1%rAttr),&
1296 maxval(pcpointer%avect1%rAttr)
1300 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1301 'Balance: ',pcpointer%namID,
' Before MPI put ', mpi_wtime()
1303 call mct_isend(pcpointer%avect1,
prism_router(rouid)%router,tag)
1305 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1306 'Balance: ',pcpointer%namID,
' After MPI put ', mpi_wtime()
1312 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1313 llstring = len_trim(lstring)
1314 if (llstring <= 20)
then 1315 write(
nulprt,*) subname,
' at ',msec,mseclag,
' RECV: ', &
1318 write(
nulprt,*) subname,
' at ',msec,mseclag,
' RECV: ',lstring(1:20), &
1319 lstring(21:llstring)
1325 write(tstring,f01)
'grcv_',cplid
1327 call mct_avect_zero(pcpointer%avect1m)
1329 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1330 'Balance: ',pcpointer%namID,
' Before MPI get ', mpi_wtime()
1331 call mct_recv(pcpointer%avect1m,
prism_router(rouid)%router,tag)
1333 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1334 'Balance: ',pcpointer%namID,
' After MPI get ', mpi_wtime()
1337 write(
nulprt,*) subname,
' DEBUG get af recv = ',cplid,&
1338 minval(pcpointer%avect1m%rAttr),&
1339 maxval(pcpointer%avect1m%rAttr)
1342 write(tstring,f01)
'gmap_',cplid
1350 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1351 'Balance: ',pcpointer%namID,
' Before interpo ', mpi_wtime()
1352 call mct_avect_zero(pcpointer%avect1)
1355 pcpointer%avect1,
prism_mapper(mapid),conserv,consopt,tstrinp=tstring)
1361 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1362 'Balance: ',pcpointer%namID,
' After interpo ', mpi_wtime()
1365 write(
nulprt,*) subname,
' DEBUG get af map = ',cplid,&
1366 minval(pcpointer%avect1%rAttr),&
1367 maxval(pcpointer%avect1%rAttr)
1370 write(tstring,f01)
'grcv_',cplid
1372 call mct_avect_zero(pcpointer%avect1)
1375 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1376 'Balance: ',pcpointer%namID,
' Before MPI get ', mpi_wtime()
1377 call mct_recv(pcpointer%avect1,
prism_router(rouid)%router,tag)
1379 WRITE(
nullucia, fmt=
'(A,I3.3,A,F16.5)') &
1380 'Balance: ',pcpointer%namID,
' After MPI get ', mpi_wtime()
1383 write(
nulprt,*) subname,
' DEBUG get af recv = ',cplid,&
1384 minval(pcpointer%avect1%rAttr),&
1385 maxval(pcpointer%avect1%rAttr)
1389 if (rcvadd /= 0.0_ip_double_p .or. rcvmult /= 1.0_ip_double_p)
then 1390 pcpointer%avect1%rAttr(:,:) = pcpointer%avect1%rAttr(:,:)*rcvmult &
1393 write(
nulprt,*) subname,
' DEBUG rcvmult,add = ',rcvmult,rcvadd
1394 write(
nulprt,*) subname,
' DEBUG get af rcvmult,add = ',cplid,&
1395 minval(pcpointer%avect1%rAttr),&
1396 maxval(pcpointer%avect1%rAttr)
1416 write(tstring,f01)
'wout_',cplid
1419 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1420 llstring = len_trim(lstring)
1421 if (llstring <= 20)
then 1422 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WRIT: ', &
1425 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WRIT: ',lstring(1:20), &
1426 lstring(21:llstring)
1430 write(fstring,
'(A,I2.2)')
'_'//trim(
compnm)//
'_',cplid
1436 call mct_avect_init(avtest,pcpointer%avect1,&
1437 mct_avect_lsize(pcpointer%avect1))
1438 write(tstring,f01)
'rinp_',cplid
1441 write(
nulprt,*) subname,
' DEBUG write/read test avfbf should be zero ',&
1442 sum(pcpointer%avect1%rAttr-avtest%rAttr)
1443 call mct_avect_clean(avtest)
1455 if (.not.lreadrest) pcpointer%ltime = msec
1457 pcpointer%avcnt(:) = 0
1458 call mct_avect_zero(pcpointer%avect1)
1459 if (pcpointer%aVon(2)) &
1460 call mct_avect_zero(pcpointer%avect2)
1461 if (pcpointer%aVon(3)) &
1462 call mct_avect_zero(pcpointer%avect3)
1463 if (pcpointer%aVon(4)) &
1464 call mct_avect_zero(pcpointer%avect4)
1465 if (pcpointer%aVon(5)) &
1466 call mct_avect_zero(pcpointer%avect5)
1468 write(
nulprt,*) subname,
' DEBUG put reset status = ' 1471 if (.not.lreadrest) pcpointer%ltime = msec
1474 write(
nulprt,*) subname,
' DEBUG get reset status = ' 1485 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1486 llstring = len_trim(lstring)
1487 if (llstring <= 20)
then 1488 write(
nulprt,*) subname,
' at ',msec,mseclag,
' SKIP: ', &
1491 write(
nulprt,*) subname,
' at ',msec,mseclag,
' SKIP: ',lstring(1:20), &
1492 lstring(21:llstring)
1499 pcpointer%ctime = msec
1506 IF ((mseclag + dt >= maxtime .AND. &
1508 len_trim(rstfile) > 0) .or. &
1509 (getput ==
oasis3_put .and. pcpointer%writrest .and. len_trim(rstfile) > 0))
then 1511 if (mseclag + dt >= maxtime)
then 1514 pcpointer%writrest = .false.
1515 write(rstfile2,
'(a,i9.9,a,a)')
'TA',msec,
'_',trim(rstfile)
1519 write(tstring,f01)
'wtrn_',cplid
1521 WRITE(vstring,
'(a,i6.6,a)')
'loc',pcpointer%namID,
'_cnt' 1523 ivarname=trim(vstring))
1524 write(vstring,
'(a,i6.6,a)')
'loc',pcpointer%namID,
'_' 1527 if (pcpointer%aVon(2))
then 1528 write(vstring,
'(a,i6.6,a)')
'av2loc',pcpointer%namID,
'_' 1532 if (pcpointer%aVon(3))
then 1533 write(vstring,
'(a,i6.6,a)')
'av3loc',pcpointer%namID,
'_' 1537 if (pcpointer%aVon(4))
then 1538 write(vstring,
'(a,i6.6,a)')
'av4loc',pcpointer%namID,
'_' 1542 if (pcpointer%aVon(5))
then 1543 write(vstring,
'(a,i6.6,a)')
'av5loc',pcpointer%namID,
'_' 1549 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1550 llstring = len_trim(lstring)
1551 if (llstring <= 20)
then 1552 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WTRN: ', &
1553 trim(lstring),
' ',trim(rstfile2)
1555 write(
nulprt,*) subname,
' at ',msec,mseclag,
' WTRN: ',lstring(1:20), &
1556 lstring(21:llstring),
' ',trim(rstfile2)
1561 write(
nulprt,*) subname,
' DEBUG write loctrans restart',cplid,&
1563 write(
nulprt,*) subname,
' DEBUG write loctrans restart',cplid,&
1564 minval(pcpointer%avect1%rAttr),&
1565 maxval(pcpointer%avect1%rAttr)
1574 IF (time_now .AND. unpack)
THEN 1586 lstring = mct_avect_exportrlist2c(pcpointer%avect1)
1587 llstring = len_trim(lstring)
1588 if (llstring <= 20)
then 1589 write(
nulprt,*) subname,
' at ',msec,mseclag,
' READ: ', &
1592 write(
nulprt,*) subname,
' at ',msec,mseclag,
' READ: ',lstring(1:20), &
1593 lstring(21:llstring)
1597 write(tstring,f01)
'grin_',cplid
1599 if (trim(inpfile) /= trim(
cspval))
then 1601 msec,filename=trim(inpfile))
1603 fstring =
'_'//trim(
compnm)
1605 msec,f_string=fstring)
1610 write(
nulprt,*) subname,
' at ',msec,mseclag,
' UPCK: ',trim(vname)
1612 write(tstring,f01)
'gcpy_',cplid
1615 if (
present(array1dout)) array1dout(:) = &
1616 pcpointer%avect1%rAttr(nfav,:)
1617 if (
present(array2dout)) array2dout(:,:) = &
1618 reshape(pcpointer%avect1%rAttr(nfav,:),shape(array2dout))
1621 if (
present(array1dout))
write(
nulprt,*) subname,
' DEBUG array copy = ',&
1622 cplid,minval(array1dout),maxval(array1dout)
1623 if (
present(array2dout))
write(
nulprt,*) subname,
' DEBUG array copy = ',&
1624 cplid,minval(array2dout),maxval(array2dout)
1631 write(
nulprt,*) subname,
' at ',msec,mseclag,
' KINF: ',trim(vname),kinfo
1650 avon,av2,av3,av4,av5,tstrinp)
1655 type(mct_avect) ,
intent(in) :: av1
1656 type(mct_avect) ,
intent(inout) :: avd
1658 integer(kind=ip_i4_p) ,
intent(in),
optional :: conserv
1659 character(len=ic_med) ,
intent(in),
optional :: consopt
1660 logical ,
intent(in),
optional :: avon(:)
1661 type(mct_avect) ,
intent(in),
optional :: av2
1662 type(mct_avect) ,
intent(in),
optional :: av3
1663 type(mct_avect) ,
intent(in),
optional :: av4
1664 type(mct_avect) ,
intent(in),
optional :: av5
1665 character(len=*) ,
intent(in),
optional :: tstrinp
1667 integer(kind=ip_i4_p) :: fsize,lsizes,lsized,nf,ni,n,m,ierr
1668 real(kind=ip_r8_p) :: sumtmp, wts_sums, wts_sumd, zradi, zlagr
1669 real(kind=ip_r8_p) :: wts_sums1(1), wts_sumd1(1)
1670 integer(kind=ip_i4_p),
allocatable :: imasks(:),imaskd(:)
1671 real(kind=ip_r8_p),
allocatable :: areas(:),aread(:)
1672 real(kind=ip_r8_p),
allocatable :: av_sums(:),av_sumd(:)
1673 type(mct_avect) :: avdtmp
1674 type(mct_avect) :: av2g
1675 type(mct_avect) :: avone
1676 character(len=ic_med) :: lconsopt
1677 character(len=ic_med) :: tstring
1679 logical :: locavon(avsmax)
1680 integer(kind=ip_i4_p) :: avonsize
1681 integer(kind=ip_i4_p) :: higher_order_check
1682 character(len=*),
parameter :: subname =
'(oasis_advance_map)' 1691 if (
present(consopt))
then 1702 if (
present(avon))
then 1703 avonsize =
size(avon)
1704 if (avonsize > avsmax)
then 1705 WRITE(
nulprt,*) subname,
estr,
'avon size',avonsize,
' passed in is too large',avsmax
1708 locavon(1:avonsize) = avon(1:avonsize)
1711 if (
present(av2) .or.
present(av3) .or.
present(av4) .or.
present(av5))
then 1712 WRITE(
nulprt,*) subname,
estr,
'av2-5 passed but avon not passed' 1720 higher_order_check = 1
1728 if (higher_order_check == 0)
then 1731 if (locavon(n) .and. n > mapper%nwgts)
then 1732 WRITE(
nulprt,*) subname,
estr,
'higher_order_check = ',higher_order_check
1733 WRITE(
nulprt,*) subname,
estr,
'missing weights for higher order field' 1734 WRITE(
nulprt,*) subname,
estr,
'missing weights output ',n,avsmax,mapper%nwgts,locavon(n)
1741 if ((locavon(n) .and. n > mapper%nwgts) .or. &
1742 (.not. locavon(n) .and. n <= mapper%nwgts))
then 1743 WRITE(
nulprt,*) subname,
estr,
'higher_order_check = ',higher_order_check
1744 WRITE(
nulprt,*) subname,
estr,
'mismatch of higher order fields passed and weights' 1745 WRITE(
nulprt,*) subname,
estr,
'mismatch weights output ',n,avsmax,mapper%nwgts,locavon(n)
1755 if (locavon(1))
then 1756 if (mct_avect_nrattr(av1) /= mct_avect_nrattr(avd))
then 1757 WRITE(
nulprt,*) subname,
estr,
'in av1 num of flds' 1761 call mct_smat_avmult(av1, mapper%sMatP(1), avd)
1765 if (locavon(2).or.locavon(3).or.locavon(4).or.locavon(5))
then 1766 lsized = mct_avect_lsize(avd)
1767 call mct_avect_init(avdtmp,avd,lsized)
1769 if (locavon(2))
then 1770 if (mct_avect_nrattr(av2) /= mct_avect_nrattr(avd))
then 1771 WRITE(
nulprt,*) subname,
estr,
'in av2 num of flds' 1775 call mct_smat_avmult(av2, mapper%sMatP(2), avdtmp)
1777 avd%rAttr = avd%rAttr + avdtmp%rAttr
1780 if (locavon(3))
then 1781 if (mct_avect_nrattr(av3) /= mct_avect_nrattr(avd))
then 1782 WRITE(
nulprt,*) subname,
estr,
'in av3 num of flds' 1786 call mct_smat_avmult(av3, mapper%sMatP(3), avdtmp)
1788 avd%rAttr = avd%rAttr + avdtmp%rAttr
1791 if (locavon(4))
then 1792 if (mct_avect_nrattr(av4) /= mct_avect_nrattr(avd))
then 1793 WRITE(
nulprt,*) subname,
estr,
'in av4 num of flds' 1797 call mct_smat_avmult(av4, mapper%sMatP(4), avdtmp)
1799 avd%rAttr = avd%rAttr + avdtmp%rAttr
1802 if (locavon(5))
then 1803 if (mct_avect_nrattr(av5) /= mct_avect_nrattr(avd))
then 1804 WRITE(
nulprt,*) subname,
estr,
'in av5 num of flds' 1808 call mct_smat_avmult(av5, mapper%sMatP(5), avdtmp)
1810 avd%rAttr = avd%rAttr + avdtmp%rAttr
1813 call mct_avect_clean(avdtmp)
1820 IF (
PRESENT(conserv))
THEN 1830 if ((
prism_part(mapper%spart)%mpicom /= mpi_comm_null .and.
prism_part(mapper%dpart)%mpicom == mpi_comm_null) .or. &
1831 (
prism_part(mapper%spart)%mpicom == mpi_comm_null .and.
prism_part(mapper%dpart)%mpicom /= mpi_comm_null))
then 1832 WRITE(
nulprt,*) subname,
estr,
'illegal conserve on non overlapping pes ' 1836 IF (
prism_part(mapper%spart)%mpicom /= mpi_comm_null)
then 1838 fsize = mct_avect_nrattr(av1)
1839 allocate(av_sums(fsize),av_sumd(fsize))
1846 lsizes = mct_avect_lsize(mapper%av_ms)
1847 allocate(imasks(lsizes),areas(lsizes))
1848 nf = mct_avect_indexia(mapper%av_ms,
'mask')
1849 imasks(:) = mapper%av_ms%iAttr(nf,:)
1850 nf = mct_avect_indexra(mapper%av_ms,
'area')
1851 areas(:) = mapper%av_ms%rAttr(nf,:)*zradi
1860 call mct_avect_init(avone,rlist=
'one',lsize=lsizes)
1861 avone%rAttr = 1.0_ip_r8_p
1863 mask=imasks,wts=areas,consopt=lconsopt)
1864 wts_sums = wts_sums1(1)
1865 call mct_avect_clean(avone)
1871 lsized = mct_avect_lsize(mapper%av_md)
1872 allocate(imaskd(lsized),aread(lsized))
1873 nf = mct_avect_indexia(mapper%av_md,
'mask')
1874 imaskd(:) = mapper%av_md%iAttr(nf,:)
1875 nf = mct_avect_indexra(mapper%av_md,
'area')
1876 aread(:) = mapper%av_md%rAttr(nf,:)*zradi
1879 call mct_avect_init(avone,rlist=
'one',lsize=lsized)
1880 avone%rAttr = 1.0_ip_r8_p
1882 mask=imaskd,wts=aread,consopt=lconsopt)
1883 wts_sumd = wts_sumd1(1)
1884 call mct_avect_clean(avone)
1888 write(
nulprt,*) subname,
' DEBUG conserve src mask ',minval(imasks),&
1889 maxval(imasks),sum(imasks)
1890 write(
nulprt,*) subname,
' DEBUG conserve dst mask ',minval(imaskd),&
1891 maxval(imaskd),sum(imaskd)
1892 write(
nulprt,*) subname,
' DEBUG conserve src area ',minval(areas),&
1893 maxval(areas),sum(areas)
1894 write(
nulprt,*) subname,
' DEBUG conserve dst area ',minval(aread),&
1895 maxval(aread),sum(aread)
1896 write(
nulprt,*) subname,
' DEBUG conserve wts_sum ',wts_sums,wts_sumd
1905 mask=imasks,wts=areas,consopt=lconsopt)
1907 mask=imaskd,wts=aread,consopt=lconsopt)
1911 if (
prism_part(mapper%spart)%mpicom /= mpi_comm_null)
write(
nulprt,*) subname,
' DEBUG src sum b4 conserve ',av_sums
1912 if (
prism_part(mapper%dpart)%mpicom /= mpi_comm_null)
write(
nulprt,*) subname,
' DEBUG dst sum b4 conserve ',av_sumd
1917 if (wts_sumd == 0.0_ip_r8_p)
then 1918 WRITE(
nulprt,*) subname,
estr,
'global conserve sums to zero ' 1922 zlagr = (av_sumd(m) - av_sums(m)) / wts_sumd
1924 if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) - zlagr
1931 if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p)
then 1932 WRITE(
nulprt,*) subname,
estr,
'cglpos conserve one of the sums is zero' 1934 elseif (av_sumd(m) /= 0.0_ip_r8_p)
then 1935 zlagr = av_sums(m) / av_sumd(m)
1937 if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
1944 if (wts_sumd == 0.0_ip_r8_p .or. wts_sums == 0.0_ip_r8_p)
then 1945 WRITE(
nulprt,*) subname,
estr,
'cbasbal conserve both sums are zero' 1949 zlagr = (av_sumd(m) - (av_sums(m)*(wts_sumd/wts_sums))) / wts_sumd
1951 if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) - zlagr
1958 if (av_sumd(m) == 0.0_ip_r8_p .and. av_sums(m) /= 0.0_ip_r8_p)
then 1959 WRITE(
nulprt,*) subname,
estr,
'cbaspos conserve one of the sums is zero' 1961 elseif (av_sumd(m) /= 0.0_ip_r8_p)
then 1962 zlagr = (av_sums(m)/av_sumd(m)) * (wts_sumd/wts_sums)
1964 if (imaskd(n) == 0) avd%rAttr(m,n) = avd%rAttr(m,n) * zlagr
1970 WRITE(
nulprt,*) subname,
estr,
'conserv option unknown = ',conserv
1977 mask=imasks,wts=areas,consopt=lconsopt)
1979 mask=imaskd,wts=aread,consopt=lconsopt)
1980 if (
prism_part(mapper%spart)%mpicom /= mpi_comm_null)
write(
nulprt,*) subname,
' DEBUG src sum af conserve ',av_sums
1981 if (
prism_part(mapper%dpart)%mpicom /= mpi_comm_null)
write(
nulprt,*) subname,
' DEBUG dst sum af conserve ',av_sumd
1986 deallocate(imasks,imaskd,areas,aread)
1987 deallocate(av_sums,av_sumd)
2004 type(mct_avect) ,
intent(in) :: av
2005 real(kind=ip_r8_p) ,
intent(inout) :: sum(:)
2006 type(mct_gsmap) ,
intent(in) :: gsmap
2007 integer(kind=ip_i4_p),
intent(in) :: mpicom
2008 integer(kind=ip_i4_p),
intent(in),
optional :: mask(:)
2009 real(kind=ip_r8_p) ,
intent(in),
optional :: wts(:)
2010 character(len=ic_med),
intent(in),
optional :: consopt
2012 integer(kind=ip_i4_p) :: n,m,ierr,mytask
2013 integer(kind=ip_i4_p) :: lsize,fsize
2014 real(kind=ip_r8_p),
allocatable :: lsum(:)
2015 real(kind=ip_r8_p),
allocatable :: lwts(:)
2016 real(kind=ip_r16_p),
allocatable :: lsum16(:)
2017 real(kind=ip_r16_p),
allocatable :: sum16(:)
2018 real(kind=ip_r8_p),
allocatable :: reproarr(:,:)
2019 type(mct_avect) :: av1, av1g
2020 character(len=ic_med) :: lconsopt
2021 character(len=*),
parameter :: subname =
'(oasis_advance_avsum)' 2025 if (mpicom == mpi_comm_null)
then 2031 if (
present(consopt))
then 2035 fsize = mct_avect_nrattr(av)
2036 lsize = mct_avect_lsize(av)
2038 allocate(lsum(fsize))
2040 allocate(lwts(lsize))
2043 if (
size(sum) /= fsize)
then 2044 WRITE(
nulprt,*) subname,
estr,
'size sum ne size av' 2048 if (
present(mask))
then 2049 if (
size(mask) /= lsize)
then 2050 WRITE(
nulprt,*) subname,
estr,
'size mask ne size av' 2054 if (mask(n) /= 0) lwts(n) = 0.0_ip_r8_p
2058 if (
present(wts))
then 2059 if (
size(wts) /= lsize)
then 2060 WRITE(
nulprt,*) subname,
estr,
'size wts ne size av' 2064 lwts(n) = lwts(n) * wts(n)
2068 if (lconsopt ==
'gather')
then 2069 call mct_avect_init(av1,av,lsize)
2072 av1%rAttr(m,n) = av%rAttr(m,n)*lwts(n)
2075 call mct_avect_gather(av1,av1g,gsmap,0,mpicom)
2076 call mpi_comm_rank(mpicom,mytask,ierr)
2078 if (mytask == 0)
then 2079 do n = 1,mct_avect_lsize(av1g)
2081 sum(m) = sum(m) + av1g%rAttr(m,n)
2086 call mct_avect_clean(av1)
2087 if (mytask == 0)
then 2088 call mct_avect_clean(av1g)
2091 elseif (lconsopt ==
'lsum8' .or. lconsopt ==
'opt')
then 2095 lsum(m) = lsum(m) + av%rAttr(m,n)*lwts(n)
2098 call oasis_mpi_sum(lsum,sum,mpicom,string=trim(subname)//
':sum',all=.true.)
2100 elseif (lconsopt ==
'lsum16')
then 2101 #ifdef __NO_16BYTE_REALS 2102 WRITE(
nulprt,*) subname,
estr,
'consopt lsum16 not support with __NO_16BYTE_REALS cpp' 2105 allocate(lsum16(fsize))
2106 allocate(sum16(fsize))
2107 lsum16 = 0.0_ip_r16_p
2110 lsum16(m) = lsum16(m) +
real(av%rAttr(m,n),ip_r16_p)*
real(lwts(n),ip_r16_p)
2113 call oasis_mpi_sum(lsum16,sum16,mpicom,string=trim(subname)//
':sum',all=.true.)
2118 elseif (lconsopt ==
'reprosum' .or. lconsopt ==
'ddpdd' .or. lconsopt ==
'bfb')
then 2119 allocate(reproarr(lsize,fsize))
2122 reproarr(n,m) = av%rAttr(m,n)*lwts(n)
2125 if (lconsopt ==
'reprosum' .or. lconsopt ==
'bfb')
then 2130 deallocate(reproarr)
2133 WRITE(
nulprt,*) subname,
estr,
'consopt unknown: '//trim(lconsopt)
2152 type(mct_avect) ,
intent(in) :: av
2153 integer(kind=ip_i4_p),
intent(in) :: mpicom
2154 integer(kind=ip_i4_p),
intent(in),
optional :: mask(:)
2155 real(kind=ip_r8_p) ,
intent(in),
optional :: wts(:)
2157 integer(kind=ip_i4_p) :: n,m,ierr,mype
2158 integer(kind=ip_i4_p) :: lsize,fsize
2159 logical :: first_call
2160 real(kind=ip_r8_p) :: lval
2161 real(kind=ip_r8_p),
allocatable :: lsum(:)
2162 real(kind=ip_r8_p),
allocatable :: lmin(:)
2163 real(kind=ip_r8_p),
allocatable :: lmax(:)
2164 real(kind=ip_r8_p),
allocatable :: gsum(:)
2165 real(kind=ip_r8_p),
allocatable :: gmin(:)
2166 real(kind=ip_r8_p),
allocatable :: gmax(:)
2167 real(kind=ip_r8_p),
allocatable :: lwts(:)
2168 type(mct_string) :: mstring
2169 character(len=64):: itemc
2170 character(len=*),
parameter :: subname =
'(oasis_advance_avdiag)' 2174 if (mpicom == mpi_comm_null)
then 2179 fsize = mct_avect_nrattr(av)
2180 lsize = mct_avect_lsize(av)
2182 allocate(lsum(fsize))
2183 allocate(lmin(fsize))
2184 allocate(lmax(fsize))
2185 allocate(gsum(fsize))
2186 allocate(gmin(fsize))
2187 allocate(gmax(fsize))
2189 allocate(lwts(lsize))
2193 if (
present(mask))
then 2194 if (
size(mask) /= lsize)
then 2195 WRITE(
nulprt,*) subname,
estr,
'size mask ne size av' 2199 if (mask(n) /= 0) lwts(n) = 0.0_ip_r8_p
2203 if (
present(wts))
then 2204 if (
size(wts) /= lsize)
then 2205 WRITE(
nulprt,*) subname,
estr,
'size wts ne size av' 2209 lwts(n) = lwts(n) * wts(n)
2219 lval = av%rAttr(m,n)*lwts(n)
2220 lsum(m) = lsum(m) + lval
2221 if (lwts(n) /= 0.0_ip_r8_p)
then 2222 if (first_call)
then 2225 first_call = .false.
2227 lmin(m) = min(lmin(m),lval)
2228 lmax(m) = max(lmax(m),lval)
2235 call mpi_comm_rank(mpicom,mype,ierr)
2236 call oasis_mpi_sum(lsum,gsum,mpicom,string=trim(subname)//
':sum',all=.false.)
2237 call oasis_mpi_min(lmin,gmin,mpicom,string=trim(subname)//
':min',all=.false.)
2238 call oasis_mpi_max(lmax,gmax,mpicom,string=trim(subname)//
':max',all=.false.)
2242 call mct_avect_getrlist(mstring,m,av)
2243 itemc = mct_string_tochar(mstring)
2244 call mct_string_clean(mstring)
2245 write(
nulprt,
'(a,a16,3g21.12)')
' diags: ',trim(itemc),gmin(m),gmax(m),gsum(m)
2249 deallocate(lsum,lmin,lmax)
2250 deallocate(gsum,gmin,gmax)
integer(kind=ip_i4_p), public lastseqtime
last coupler sequence time
integer(kind=ip_intwp_p), parameter oasis_recvout
integer(kind=ip_intwp_p), parameter ip_cglbpos
Generic overloaded interface into MPI sum reduction.
subroutine, public oasis_io_read_array(rstfile, mpicom, iarray, ivarname, rarray, rvarname, abort)
Reads an integer or real field from a file into an array.
integer(kind=ip_intwp_p), parameter oasis_sentout
subroutine, public oasis_debug_note(string)
Used to write information from a subroutine, write info to log file at some debug level...
Provides a common location for several OASIS variables.
subroutine, public oasis_reprosum_calc(arr, arr_gsum, nsummands, dsummands, nflds, ddpdd_sum, arr_gbl_max, arr_gbl_max_out, arr_max_levels, arr_max_levels_out, gbl_max_nsummands, gbl_max_nsummands_out, gbl_count, repro_sum_validate, repro_sum_stats, rel_diff, commid)
Compute the global sum of each field in "arr" using the indicated communicator with a reproducible ye...
Provides reusable IO routines for OASIS.
integer(kind=ip_intwp_p), parameter oasis_ok
subroutine, public oasis_io_write_avfile(rstfile, av, gsmap, mpicom, nx, ny, nampre)
Writes all fields from an attribute vector to a file.
integer(kind=ip_i4_p) lucia_debug
Generic overloaded interface into MPI max reduction.
integer(kind=ip_intwp_p), parameter oasis_in
type(prism_part_type), dimension(mpart), public prism_part
list of defined partitions
integer(kind=ip_intwp_p) nulprt
Generic overloaded interface into MPI broadcast.
integer(kind=ip_intwp_p), parameter oasis_fromrestout
real(ip_double_p), parameter eradius
type(prism_coupler_type), dimension(:), pointer, public prism_coupler_get
prism_coupler get array
integer(kind=ip_intwp_p), parameter ip_instant
subroutine, public oasis_abort(id_compid, cd_routine, cd_message, file, line, rcode)
OASIS abort method, publically available to users.
type(prism_coupler_type), dimension(:), pointer, public prism_coupler_put
prism_coupler put array
integer(kind=ip_intwp_p), parameter oasis_fromrest
integer(kind=ip_intwp_p), parameter oasis_sent
integer, parameter ip_r8_p
integer(kind=ip_intwp_p), parameter oasis_torestout
subroutine, public oasis_advance_run(mop, varid, msec, kinfo, nff, namid, array1din, array1dout, array2dout, readrest, a2on, array2, a3on, array3, a4on, array4, a5on, array5, writrest, varnum)
Advances the OASIS coupling.
character(len= *), parameter cspval
integer(kind=ip_intwp_p), parameter ip_min
integer(kind=ip_intwp_p), parameter oasis_torest
Initialize the OASIS coupler infrastructure.
integer(kind=ip_intwp_p), parameter ip_accumul
integer(kind=ip_intwp_p) nullucia
Provides a generic and simpler interface into MPI calls for OASIS.
integer(kind=ip_intwp_p), parameter ip_cbasbal
integer(kind=ip_intwp_p), parameter oasis3_get
Coupler data for managing all aspects of coupling in OASIS.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
Generic overloaded interface into MPI min reduction.
subroutine oasis_advance_avdiag(av, mpicom, mask, wts)
A generic method for writing the global sums of fields in an attribute vector.
OASIS partition data and methods.
integer(kind=ip_i4_p), parameter, public prism_coupler_avsmax
maximum number of higher order terms in mapping
integer(kind=ip_intwp_p), parameter oasis_recvd
integer(kind=ip_intwp_p), parameter oasis3_put
integer(kind=ip_intwp_p), parameter oasis_output
subroutine oasis_advance_map(av1, avd, mapper, conserv, consopt, avon, av2, av3, av4, av5, tstrinp)
Provides interpolation functionality.
subroutine, public oasis_advance_init(kinfo)
Initializes the OASIS fields.
logical, parameter map_barrier
integer(kind=ip_intwp_p), parameter oasis_waitgroup
subroutine, public oasis_coupler_bldvarname(varid, varnum, vname)
Build a consistent variable name based on bundles.
integer(kind=ip_intwp_p), parameter ip_max
integer(kind=ip_intwp_p), parameter oasis_comm_ready
Defines parameters for OASIS.
integer(kind=ip_intwp_p), parameter oasis_loctrans
OASIS variable data and methods.
character(len=ic_lvar) compnm
subroutine, public oasis_timer_start(timer_label, barrier)
Start a timer.
subroutine, public oasis_io_write_avfbf(av, gsmap, mpicom, nx, ny, msec, f_string, filename)
Write each field in an attribute vector to an individual files.
integer(kind=ip_i4_p) oasis_debug
integer(kind=ip_intwp_p), parameter oasis_out
type(prism_router_type), dimension(:), pointer, public prism_router
prism_router array
subroutine, public oasis_timer_stop(timer_label)
Stop a timer.
character(len= *), parameter, public estr
integer(kind=ip_i4_p) mpi_comm_local
subroutine, public oasis_mpi_barrier(comm, string)
Call MPI_BARRIER for a particular communicator.
integer(kind=ip_intwp_p), parameter ip_cglobal
integer(kind=ip_intwp_p), parameter ip_average
type(prism_mapper_type), dimension(:), pointer, public prism_mapper
list of defined mappers
integer(kind=ip_intwp_p), parameter oasis_input
subroutine, public oasis_io_read_avfbf(av, gsmap, mpicom, msec, f_string, filename)
Read each field in an attribute vector from individual files.
logical, public allow_no_restart
flag to allow no restart files at startup
Advances the OASIS coupling.
subroutine, public oasis_flush(nu)
Flushes output to file.
subroutine oasis_advance_avsum(av, sum, gsmap, mpicom, mask, wts, consopt)
A generic method for summing fields in an attribute vector.
subroutine, public oasis_coupler_unbldvarname(varid, vname, varnum)
Deconstruct the varname based on oasis_coupler_bldvarname.
subroutine, public oasis_io_write_array(rstfile, mpicom, iarray, ivarname, rarray, rvarname)
Writes a real or integer array to a file.
integer(kind=ip_intwp_p), public prism_nvar
number of variables defined
Performance timer methods.
integer(kind=ip_i4_p), public prism_mcoupler
max couplers
type(prism_var_type), dimension(:), pointer, public prism_var
list of defined variables
OASIS reproducible sum method from P. Worley.
integer(ip_i4_p), parameter ispval
Mapper data for interpolating data between grids.
integer(kind=ip_intwp_p), parameter oasis_comm_wait
logical, parameter detailed_map_timing
integer(kind=ip_intwp_p), parameter ip_cbaspos
integer(kind=ip_intwp_p), parameter ip_cnone
integer(kind=ip_i4_p), public lastseq
last coupler sequence
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
OASIS map (interpolation) data and methods.
character(len= *), parameter, public wstr
subroutine, public oasis_io_read_avfile(rstfile, av, gsmap, mpicom, abort, nampre, didread)
Reads all fields for an attribute vector from a file.