41 type(mct_router) :: router
49 type(mct_avect) :: avect1
50 type(mct_avect) :: avect1m
51 type(mct_avect) :: avect2
52 type(mct_avect) :: avect3
53 type(mct_avect) :: avect4
54 type(mct_avect) :: avect5
56 character(len=ic_xl) :: rstfile
58 character(len=ic_xl) :: inpfile
59 character(len=ic_xxl) :: fldlist
60 integer(kind=ip_i4_p) :: nflds
61 integer(kind=ip_i4_p),
pointer :: varid(:)
63 integer(kind=ip_i4_p) :: namid
64 integer(kind=ip_i4_p) :: partid
65 integer(kind=ip_i4_p) :: rpartid
66 integer(kind=ip_i4_p) :: routerid
67 integer(kind=ip_i4_p) :: mapperid
68 character(len=ic_med) :: maploc
69 integer(kind=ip_i4_p) :: ops
70 integer(kind=ip_i4_p) :: comp
71 integer(kind=ip_i4_p) :: tag
72 integer(kind=ip_i4_p) :: seq
73 integer(kind=ip_i4_p) :: dt
74 integer(kind=ip_i4_p) :: lag
75 integer(kind=ip_i4_p) :: maxtime
76 integer(kind=ip_i4_p) :: trans
77 integer(kind=ip_i4_p) :: conserv
78 character(len=ic_med) :: consopt
79 integer(kind=ip_i4_p) :: getput
85 real(kind=ip_double_p):: sndmult
86 real(kind=ip_double_p):: sndadd
87 real(kind=ip_double_p):: rcvmult
88 real(kind=ip_double_p):: rcvadd
90 integer(kind=ip_i4_p) :: ltime
91 integer(kind=ip_i4_p) :: ctime
92 integer(kind=ip_i4_p),
pointer :: avcnt(:)
93 integer(kind=ip_i4_p),
pointer :: status(:)
128 integer(kind=ip_i4_p) :: n,n1,n2,nn,nv,nm,nv1,nv1a,nns,lnn,nc,nf,nvf,npc,r1,ierr
129 integer(kind=ip_i4_p) :: pe,nflds1,nflds2,ncnt
130 integer(kind=ip_i4_p) :: part1, part2
131 integer(kind=ip_i4_p) :: spart,dpart
136 integer(kind=ip_i4_p) :: mapID,namID
137 type(mct_smat),
pointer :: sMati(:)
138 integer(kind=ip_i4_p) :: ncid,dimid,status
139 integer(kind=ip_i4_p) :: lsize,gsize
140 integer(kind=ip_i4_p) :: svarid
141 integer(kind=ip_i4_p),
allocatable :: varidtmp(:)
142 integer(kind=ip_i4_p) :: part
143 integer(kind=ip_i4_p),
pointer :: varid1(:)
144 character(len=ic_med) :: cstring,delim,vname,mapopt,mapopt1
145 character(len=ic_lvar):: myfld
146 integer(kind=ip_i4_p) :: myfldi
147 character(len=ic_xxl) :: myfldlist
148 character(len=ic_lvar):: otfld
149 character(len=ic_xxl) :: otfldlist
150 integer(kind=ip_i4_p) :: nx,ny
151 character(len=ic_lvar):: gridname
152 character(len=ic_long):: tmp_mapfile
153 integer(kind=ip_i4_p) :: flag
154 logical :: found, exists, found2
155 integer(kind=ip_i4_p) :: mynvar
156 integer(kind=ip_i4_p) :: nwgts, arrlen
157 character(len=ic_lvar):: tmpfld
160 integer(kind=ip_i4_p) :: ifind,nfind
161 integer(kind=ip_i4_p) ,
pointer :: gridID(:)
162 character(len=ic_lvar),
pointer :: myvar(:)
163 integer(kind=ip_i4_p) ,
pointer :: myops(:)
164 integer(kind=ip_i4_p) ,
pointer :: mynum(:)
165 integer(kind=ip_i4_p) ,
pointer :: nallvar(:)
166 character(len=ic_lvar),
pointer :: allvar(:,:)
167 integer(kind=ip_i4_p) ,
pointer :: allops(:,:)
168 integer(kind=ip_i4_p) ,
pointer :: allnum(:,:)
169 integer(kind=ip_i4_p) ,
pointer :: namsrc_checkused(:)
170 integer(kind=ip_i4_p) ,
pointer :: namsrc_checkused_g(:)
172 integer(kind=ip_i4_p) :: num
173 integer(kind=ip_i4_p) ,
pointer :: namnum(:)
174 integer(kind=ip_i4_p) ,
pointer :: fldnum(:)
175 character(len=ic_lvar),
pointer :: fld(:)
176 end type sortnamfld_type
177 type(sortnamfld_type) :: sortnsrc
178 type(sortnamfld_type) :: sortndst
180 integer(kind=ip_i4_p) :: num
181 integer(kind=ip_i4_p) ,
pointer :: modnum(:)
182 integer(kind=ip_i4_p) ,
pointer :: varnum(:)
183 character(len=ic_lvar),
pointer :: fld(:)
184 end type sortvarfld_type
185 type(sortvarfld_type) :: sortvars
186 type(sortvarfld_type) :: sorttest
187 integer(kind=ip_i4_p) ,
pointer :: sortkey(:)
188 character(len=ic_med) :: part2decomp
189 character(len=ic_med) :: smatread_method
190 integer,
parameter :: local_timers_on = 0
192 character(len=*),
parameter :: subname =
'(oasis_coupler_setup)' 198 IF (local_timers_on >= 1)
then 210 write(
nulprt,*) subname,
' part2decomp = ',trim(part2decomp)
211 write(
nulprt,*) subname,
' smatread_method = ',trim(smatread_method)
252 pcpointer%rstfile =
"" 253 pcpointer%writrest= .false.
254 pcpointer%inpfile =
"" 255 pcpointer%fldlist =
"" 258 pcpointer%valid = .false.
260 allocate(pcpointer%varid(1))
261 pcpointer%varid(:) =
ispval 262 pcpointer%aVon(:) = .false.
265 pcpointer%routerID =
ispval 266 pcpointer%mapperID =
ispval 267 pcpointer%maploc =
"" 271 pcpointer%maxtime = 0
273 pcpointer%sndrcv = .false.
274 pcpointer%output = .false.
275 pcpointer%input = .false.
280 pcpointer%snddiag = .false.
281 pcpointer%rcvdiag = .false.
282 pcpointer%sndmult = 1.0_ip_double_p
283 pcpointer%sndadd = 0.0_ip_double_p
284 pcpointer%rcvmult = 1.0_ip_double_p
285 pcpointer%rcvadd = 0.0_ip_double_p
325 if (myvar(n1) == myvar(n2))
then 326 WRITE(
nulprt,*) subname,
estr,
'variable name defined more than once by def_var = ',trim(myvar(n1))
338 write(
nulprt,*) subname,
' bcast mynvar ',mynvar
344 write(
nulprt,*) subname,
' bcast myvar ',trim(myvar(1))
347 allvar(:,n) = myvar(:)
350 write(
nulprt,*) subname,
' bcast myops ',myops(1)
353 allops(:,n) = myops(:)
356 write(
nulprt,*) subname,
' bcast mynum ',mynum(1)
359 allnum(:,n) = mynum(:)
363 deallocate(myvar,myops)
366 write(
nulprt,*) subname,
' model variable info:' 368 write(
nulprt,
'(8x,a,2i6)')
' model,nvars = ',nm,nallvar(nm)
369 do nv = 1,nallvar(nm)
371 if (allops(nv,nm) ==
oasis_out) cstring =
'prism_out' 372 if (allops(nv,nm) ==
oasis_in) cstring =
'prism_in' 373 write(
nulprt,
'(16x,a,2i6,2x,a,2i6,2x,a)')
' model,idx,var,num,ops = ',nm,nv,&
374 trim(allvar(nv,nm)),allnum(nv,nm),allops(nv,nm),trim(cstring)
387 allocate(sortvars%fld(n1))
388 allocate(sortvars%modnum(n1))
389 allocate(sortvars%varnum(n1))
390 allocate(sortkey(n1))
398 sortvars%fld(n1) = allvar(n2,n)
399 sortvars%modnum(n1) = n
400 sortvars%varnum(n1) = n2
409 write(
nulprt,*) subname//
' Sorted array : sortvars' 410 do n1 = 1,sortvars%num
411 write(
nulprt,*) subname,
'sort sortvars',n1,sortkey(n1),sortvars%modnum(n1),sortvars%varnum(n1),trim(sortvars%fld(n1))
442 WRITE(
nulprt,*) subname,
estr,
'number of fields in namcouple inconsistent ',nn,n1,n2
453 allocate(sortnsrc%fld(n1))
454 allocate(sortnsrc%namnum(n1))
455 allocate(sortnsrc%fldnum(n1))
457 allocate(sortndst%fld(n2))
458 allocate(sortndst%namnum(n2))
459 allocate(sortndst%fldnum(n2))
462 allocate(namsrc_checkused(sortnsrc%num))
467 allocate(sortkey(sortnsrc%num))
473 sortnsrc%namnum(n1) = nn
474 sortnsrc%fldnum(n1) = n2
484 write(
nulprt,*) subname//
' Sorted array : sortnsrc' 485 do n1 = 1,sortnsrc%num
486 write(
nulprt,*) subname,
'sort sortnsrc',n1,sortkey(n1), &
487 sortnsrc%namnum(n1),sortnsrc%fldnum(n1),trim(sortnsrc%fld(n1))
494 allocate(sortkey(sortndst%num))
500 sortndst%namnum(n1) = nn
501 sortndst%fldnum(n1) = n2
511 write(
nulprt,*) subname//
' Sorted array : sortndst' 512 do n1 = 1,sortndst%num
513 write(
nulprt,*) subname,
'sort sortndst',n1,sortkey(n1), &
514 sortndst%namnum(n1),sortndst%fldnum(n1),trim(sortndst%fld(n1))
524 write(
nulprt,*) subname,
' Test sort code: ' 527 allocate(sorttest%fld(n1))
528 allocate(sorttest%modnum(n1))
529 allocate(sorttest%varnum(n1))
530 allocate(sortkey(n1))
533 sorttest%fld(:) =
'A' 534 do n1 = 1,sorttest%num
536 if (n1 == 1) sorttest%fld(n1) =
'D' 537 if (n1 == 2) sorttest%fld(n1) =
'C' 538 if (n1 == 4) sorttest%fld(n1) =
'C' 539 if (n1 == 5) sorttest%fld(n1) =
'D' 540 if (n1 == 8) sorttest%fld(n1) =
'C' 541 if (n1 == 9) sorttest%fld(n1) =
'B' 542 if (n1 == 10) sorttest%fld(n1) =
'C' 543 sorttest%modnum(n1) = n1+100
544 sorttest%varnum(n1) = n1
551 write(
nulprt,*) subname//
' Sorted array : sorttest' 552 do n1 = 1,sorttest%num
553 write(
nulprt,*) subname,
'sort sorttest',n1,sortkey(n1), &
554 sorttest%modnum(n1),sorttest%varnum(n1),trim(sorttest%fld(n1))
558 call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
559 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
560 do n1 = ifind,ifind+nfind-1
561 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sorttest%fld(n1))
565 call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
566 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
567 do n1 = ifind,ifind+nfind-1
568 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sorttest%fld(n1))
572 call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
573 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
574 do n1 = ifind,ifind+nfind-1
575 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sorttest%fld(n1))
579 call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
580 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
581 do n1 = ifind,ifind+nfind-1
582 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sorttest%fld(n1))
586 call cplfind(sorttest%num, sorttest%fld, tmpfld, ifind, nfind)
587 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
588 do n1 = ifind,ifind+nfind-1
589 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sorttest%fld(n1))
593 deallocate(sorttest%fld)
594 deallocate(sorttest%modnum)
595 deallocate(sorttest%varnum)
597 write(
nulprt,*) subname,
' Test cplfind: ' 598 n1 = max(min(sortndst%num,sortndst%num/3),1)
599 tmpfld = sortndst%fld(n1)
600 call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
601 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
602 do n1 = ifind,ifind+nfind-1
603 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sortndst%fld(n1))
606 n1 = max(min(sortndst%num,1),1)
607 tmpfld = sortndst%fld(n1)
608 call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
609 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
610 do n1 = ifind,ifind+nfind-1
611 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sortndst%fld(n1))
614 n1 = max(min(sortndst%num,2),1)
615 tmpfld = sortndst%fld(n1)
616 call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
617 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
618 do n1 = ifind,ifind+nfind-1
619 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sortndst%fld(n1))
622 n1 = max(min(sortndst%num,sortndst%num-1),1)
623 tmpfld = sortndst%fld(n1)
624 call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
625 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
626 do n1 = ifind,ifind+nfind-1
627 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sortndst%fld(n1))
630 n1 = max(min(sortndst%num,sortndst%num),1)
631 tmpfld = sortndst%fld(n1)
632 call cplfind(sortndst%num, sortndst%fld, tmpfld, ifind, nfind)
633 write(
nulprt,*) subname,
' cpl find1 ',trim(tmpfld),ifind,nfind
634 do n1 = ifind,ifind+nfind-1
635 write(
nulprt,*) subname,
' cpl find2 ',n1,trim(sortndst%fld(n1))
666 WRITE(
nulprt,*) subname,
' get part and fld ',nv1,part1,trim(myfld)
676 call cplfind(sortnsrc%num, sortnsrc%fld, myfld, ifind, nfind)
678 call cplfind(sortndst%num, sortndst%fld, myfld, ifind, nfind)
685 do nf = ifind,ifind+nfind-1
691 nn = sortnsrc%namnum(nf)
692 myfldi = sortnsrc%fldnum(nf)
697 nn = sortndst%namnum(nf)
698 myfldi = sortndst%fldnum(nf)
707 WRITE(
nulprt,*) subname,
' found fld1 ',trim(myfld),nv1,nf
708 WRITE(
nulprt,*) subname,
' found fld2 ',trim(myfld),nns,nn,myfldi,flag
727 WRITE(
nulprt,*) subname,
' migrate namcouple to part ' 759 write(
nulprt,*) subname,
estr,
'var must be either OASIS_In or OASIS_Out for var = ',trim(myfld)
764 write(
nulprt,
'(1x,2a,4i6,2a)') subname,
' ca: myfld',nn,
compid,&
765 nv1,myfldi,
' ',trim(myfld)
774 otfld =
'NOmatchNOyesNOyesNO' 779 WRITE(
nulprt,*) subname,
' otfld ',trim(otfld)
788 call cplfind(sortvars%num, sortvars%fld, otfld, ifind, nfind)
796 do nvf = ifind, ifind+nfind-1
803 namsrc_checkused(nf) = 1
805 write(
nulprt,*) subname,
' set src checkused ',trim(myfld),
':',trim(otfld),nf
812 do while (n1 < sortnsrc%num .and. .not.found2)
814 if (nn == sortnsrc%namnum(n1) .and. myfldi == sortnsrc%fldnum(n1))
then 815 namsrc_checkused(n1) = 1
818 write(
nulprt,*) subname,
' set dst checkused ',trim(myfld),
':',trim(otfld),n1
826 nm = sortvars%modnum(nvf)
827 nv = sortvars%varnum(nvf)
830 write(
nulprt,*) subname,
' match otfld ',trim(otfld),nn
846 write(
nulprt,*) subname,
estr,
'send recv pair both Out = ', &
847 trim(myfld),
' ',trim(otfld)
851 write(
nulprt,*) subname,
estr,
'send recv pair both In = ', &
852 trim(myfld),
' ',trim(otfld)
862 if (trim(myfld) /= trim(otfld))
then 863 write(
nulprt,*) subname,
estr,
'namcouple field names do not match in/out = ', &
864 trim(myfld),
' ',trim(otfld)
873 if (
prism_var(nv1)%num /= allnum(nv,nm))
then 874 write(
nulprt,*) subname,
estr,
'namcouple bundle fields do not match for ',trim(myfld),
' ',trim(otfld)
875 write(
nulprt,*) subname,
estr,
'namcouple bundle numbers are ',
prism_var(nv1)%num,allnum(nv,nm)
884 if (flag ==
oasis_in .and. found)
then 885 write(
nulprt,*) subname,
estr,
'found two sources for field = ',trim(otfld)
899 WRITE(
nulprt,*) subname,
' set prism_coupler ' 910 pcpointer%nflds = pcpointer%nflds + 1
932 if (pcpointer%nflds == 1)
then 933 pcpointer%fldlist = trim(myfldlist)
934 deallocate(pcpointer%varid)
936 pcpointer%varid(:) =
ispval 939 svarid =
size(pcpointer%varid)
940 if (myfldi > svarid .or. pcpointer%nflds > svarid)
then 941 WRITE(
nulprt,*) subname,
estr,
'multiple field coupling setup error',svarid,myfldi,pcpointer%nflds
945 pcpointer%varid(myfldi) = nv1
954 WRITE(
nulprt,*) subname,
estr,
'increase mvarcpl in mod_oasis_var' 965 if (pcpointer%valid)
then 966 if (pcpointer%comp /= nm)
then 967 WRITE(
nulprt,*) subname,
estr,
'mismatch in field comp for var = ',trim(myfld)
970 if (pcpointer%namID /= nn)
then 971 WRITE(
nulprt,*) subname,
estr,
'mismatch in field namID for var = ',trim(myfld)
974 if (pcpointer%partID /= part1)
then 975 WRITE(
nulprt,*) subname,
estr,
'mismatch in field partID for var = ',trim(myfld)
987 pcpointer%mapperID = -1
988 pcpointer%partID = part1
989 pcpointer%rpartID= part1
997 pcpointer%sndrcv = .false.
998 pcpointer%output = .false.
999 pcpointer%input = .false.
1014 WRITE(
nulprt,*) subname,
' inout flags ' 1019 pcpointer%output = .true.
1023 pcpointer%input = .true.
1028 pcpointer%sndrcv = .true.
1030 pcpointer%tag = nm*100*1000 +
compid*1000 + nn
1033 pcpointer%tag =
compid*100*1000 + nm*1000 + nn
1041 if (pcpointer%routerID ==
ispval)
then 1045 write(
nulprt,*) subname,
estr,
'check prism_mrouter in oasis_coupler_setup ' 1057 WRITE(
nulprt,*) subname,
' mapper ' 1063 if (trim(tmp_mapfile) ==
'idmap' .and. trim(
namscrmet(nn)) /= trim(
cspval))
then 1064 if (trim(
namscrmet(nn)) ==
'CONSERV')
then 1073 if (trim(tmp_mapfile) /=
'idmap')
then 1083 if (trim(
prism_mapper(n)%file) == trim(tmp_mapfile) .and. &
1097 write(
nulprt,*) subname,
estr,
'check prism_mmapper in oasis_coupler_setup ' 1109 write(
nulprt,*) subname,
' DEBUG new mapper for file ',&
1114 pcpointer%mapperID = mapid
1118 pcpointer%valid = .true.
1131 if (local_timers_on >= 1)
then 1140 allocate(namsrc_checkused_g(sortnsrc%num))
1143 do n1 = 1,sortnsrc%num
1144 if (namsrc_checkused_g(n1) /= 1)
then 1150 if (found)
call oasis_abort(file=__file__,line=__line__)
1151 deallocate(namsrc_checkused_g)
1154 deallocate(allvar,nallvar,allops,allnum)
1155 deallocate(namsrc_checkused)
1156 deallocate(sortnsrc%fld)
1157 deallocate(sortnsrc%namnum)
1158 deallocate(sortnsrc%fldnum)
1159 deallocate(sortndst%fld)
1160 deallocate(sortndst%namnum)
1161 deallocate(sortndst%fldnum)
1162 deallocate(sortvars%fld)
1163 deallocate(sortvars%modnum)
1164 deallocate(sortvars%varnum)
1181 if (pcpointer%valid)
then 1185 nflds2 = nflds2 +
prism_var(pcpointer%varid(n1))%num
1188 write(
nulprt,*) subname,
' fldlist rebuild nflds1,nflds2 for ',trim(pcpointer%fldlist)
1189 write(
nulprt,*) subname,
' fldlist rebuild nflds1,nflds2 ',nflds1,nflds2
1191 if (nflds2 < nflds1)
then 1192 write(
nulprt,*) subname,
estr,
'fldlist rebuild nflds2 < nflds1 for ',trim(pcpointer%fldlist)
1193 write(
nulprt,*) subname,
estr,
'fldlist reset error in fld cnt = ',nflds1,nflds2
1197 write(
nulprt,*) subname,
' fldlist rebuild nflds2 > nflds1 for ',trim(pcpointer%fldlist)
1199 allocate(varid1(nflds1))
1200 varid1(1:nflds1) = pcpointer%varid(1:nflds1)
1201 myfldlist = pcpointer%fldlist
1202 pcpointer%fldlist =
"" 1203 deallocate(pcpointer%varid)
1204 allocate(pcpointer%varid(nflds2))
1209 pcpointer%varid(ncnt) = varid1(n1)
1211 if (ncnt == 1) delim =
"" 1212 if (len_trim(pcpointer%fldlist) > 0.99 * len(pcpointer%fldlist))
then 1213 write(
nulprt,*) subname,
estr,
'fldlist rebuild too long, limit is ',len(pcpointer%fldlist),
' chars' 1214 write(
nulprt,*) subname,
estr,
'current rebuid fldlist is ',trim(pcpointer%fldlist)
1218 write(pcpointer%fldlist,
'(a)') trim(pcpointer%fldlist)//trim(delim)//trim(vname)
1220 write(
nulprt,*) subname,
' fldlist rebuild n1, n2 ',n1,n2,ncnt
1221 write(
nulprt,*) subname,
' fldlist rebuild fldlist ',ncnt,trim(pcpointer%fldlist)
1222 write(
nulprt,*) subname,
' fldlist rebuild varid ',ncnt,pcpointer%varid(ncnt)
1234 write(
nulprt,*) subname,
' couplers setup' 1264 if (local_timers_on >= 3)
call oasis_timer_stop(
'cpl_setup_n4_global_barrier')
1275 write(
nulprt,*) subname,
' DEBUG cb:initialize coupler ',nc,npc,pcpointer%valid
1279 if (pcpointer%valid)
then 1282 write(
nulprt,*) subname,
' DEBUG ci:initialize coupler ',nc,npc
1286 namid = pcpointer%namID
1287 part1 = pcpointer%partID
1288 mapid = pcpointer%mapperID
1290 if (part1 <= 0)
then 1291 write(
nulprt,*) subname,
estr,
'part1 invalid = ',part1
1299 gsize = mct_gsmap_gsize(
prism_part(part1)%gsmap)
1302 write(
nulprt,
'(1x,2a,5i10)') subname,
' DEBUG ci:part1 info ',namid,part1,mapid,gsize,lsize
1303 write(
nulprt,
'(1x,2a,4i12)') subname,
' DEBUG ci:part1a',
prism_part(part1)%gsmap%ngseg,&
1305 do n1 = 1,min(
prism_part(part1)%gsmap%ngseg,10)
1306 write(
nulprt,
'(1x,2a,4i12)') subname,
' DEBUG ci:part1b',n1,&
1313 call mct_avect_init(pcpointer%avect1,rlist=trim(pcpointer%fldlist),lsize=lsize)
1314 call mct_avect_zero(pcpointer%avect1)
1315 pcpointer%aVon(1) = .true.
1317 write(
nulprt,*) subname,
' DEBUG ci:avect1 initialized ' 1325 pcpointer%nflds = mct_avect_nrattr(pcpointer%avect1)
1326 allocate(pcpointer%status(pcpointer%nflds))
1327 allocate(pcpointer%avcnt (pcpointer%nflds))
1328 pcpointer%avcnt(:) = 0
1349 gsize = mct_gsmap_gsize(
prism_part(part2)%gsmap)
1367 inquire(file=trim(
prism_mapper(mapid)%file),exist=exists)
1370 write(
nulprt,*) subname,
' DEBUG ci: inquire mapfile ',&
1376 if (.not.exists)
then 1388 write(
nulprt,*) subname,
estr,
'map file does not exist and SCRIPR not set = ',&
1399 status = nf90_open(trim(
prism_mapper(mapid)%file),nf90_nowrite,ncid)
1401 status = nf90_inq_dimid(ncid,
'dst_grid_size',dimid)
1402 status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1403 write(
nulprt,*) subname,
" DEBUG dst_grid_size ",gsize
1404 status = nf90_inq_dimid(ncid,
'src_grid_size',dimid)
1405 status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1406 write(
nulprt,*) subname,
" DEBUG src_grid_size ",gsize
1409 status = nf90_inq_dimid(ncid,
'dst_grid_size',dimid)
1411 status = nf90_inq_dimid(ncid,
'src_grid_size',dimid)
1412 status = nf90_inquire_dimension(ncid,dimid,len=gsize)
1454 write(
nulprt,*) subname,
estr,
'mapper opt changed',&
1469 write(
nulprt,*) subname,
' using part2decomp = ',trim(part2decomp)
1470 write(
nulprt,*) subname,
' mapopt, mapopt1 = ',trim(mapopt),
' ',trim(mapopt1)
1473 if (trim(part2decomp) ==
'decomp_wghtfile')
then 1477 if (smatread_method ==
"ceg")
then 1515 if (mapopt1 ==
'dst')
then 1516 call mct_smat_expgrowi(smati(1), gridid, length=arrlen)
1517 elseif (mapopt1 ==
'src')
then 1518 call mct_smat_expgcoli(smati(1), gridid, length=arrlen)
1520 write(
nulprt,*) subname,
estr,
'invalid mapopt = ',trim(mapopt)
1524 call mct_smat_clean(smati(n))
1530 write(
nulprt,*) subname,
' gridID0 ',trim(mapopt),
' ',trim(mapopt1)
1531 write(
nulprt,*) subname,
' gridID1 ',
size(gridid),arrlen, gsize
1532 if (arrlen > 0)
then 1533 write(
nulprt,*) subname,
' gridID2 ',minval(gridid),maxval(gridid)
1534 write(
nulprt,*) subname,
' gridID3 ',minval(gridid(1:arrlen)),maxval(gridid(1:arrlen))
1535 write(
nulprt,*) subname,
' gridID4 ',gridid(1:10)
1541 if (local_timers_on >= 1)
then 1547 if (part2decomp ==
'decomp_wghtfile')
then 1565 if (smatread_method ==
"ceg")
then 1566 if (local_timers_on >= 1)
then 1576 if (local_timers_on >= 1)
then 1588 write(
nulprt,*) subname,
" DEBUG part_create part1 gsize",
prism_part(part1)%gsize
1589 do r1 = 1,min(
prism_part(part1)%gsmap%ngseg,10)
1590 write(
nulprt,*) subname,
" DEBUG part_create part1 info ",&
1595 write(
nulprt,*) subname,
" DEBUG part_create part2 gsize",
prism_part(part2)%gsize
1596 do r1 = 1,min(
prism_part(part2)%gsmap%ngseg,10)
1597 write(
nulprt,*) subname,
" DEBUG part_create part2 info ",
prism_part(part2)%gsmap%start(r1),&
1602 if (local_timers_on >= 1)
then 1612 call mct_smatp_init(
prism_mapper(mapid)%sMatP(n), smati(n), &
1614 call mct_smat_clean(smati(n))
1621 write(cstring,
'(a1,i4.4,a1)')
'm',mapid,
'-' 1624 write(
nulprt,*) subname,subname,
" mct_rearr_print ",trim(cstring),
" smpx:" 1626 write(
nulprt,*) subname,subname,
" mct_rearr_print ",trim(cstring),
" smpy:" 1636 write(
nulprt,*) subname,
" DEBUG ci:done initializing prism_mapper",mapid,&
1637 " nElements = ",lsize,
" nwgts = ",nwgts
1654 call mct_avect_init(
prism_mapper(mapid)%av_ms,ilist=
'mask',rlist=
'area',lsize=lsize)
1664 call mct_avect_init(
prism_mapper(mapid)%av_md,ilist=
'mask',rlist=
'area',lsize=lsize)
1698 write(
nulprt,
'(1x,2a,4i12)') subname,
' DEBUG ci:part2 info ',part2,mapid,gsize,lsize
1699 write(
nulprt,
'(1x,2a,4i12)') subname,
' DEBUG ci:part2a',
prism_part(part2)%gsmap%ngseg,&
1701 do n1 = 1,min(
prism_part(part2)%gsmap%ngseg,10)
1702 write(
nulprt,
'(1x,2a,4i12)') subname,
' DEBUG ci:part2b',n1,
prism_part(part2)%gsmap%start(n1),&
1707 call mct_avect_init(pcpointer%avect1m,rlist=trim(pcpointer%fldlist),lsize=lsize)
1708 call mct_avect_zero(pcpointer%avect1m)
1710 write(
nulprt,*) subname,
' DEBUG ci:avect1m initialized ' 1718 pcpointer%rpartID = part2
1743 if (local_timers_on >= 1)
then 1761 namid = pcpointer%namID
1762 part1 = pcpointer%partID
1763 mapid = pcpointer%mapperID
1774 if (pcpointer%sndrcv)
then 1777 write(
nulprt,*) subname,
' DEBUG ci:initialize router ',pcpointer%routerID,&
1778 pcpointer%comp,pcpointer%rpartID
1782 if (
compid == pcpointer%comp)
then 1788 write(
nulprt,*) subname,
' DEBUG self router between part ',pcpointer%rpartID,
' and part ',pcpntpair%rpartID, &
1789 ' with router ',pcpointer%routerID,
' and router ',pcpntpair%routerID,
' for compid ',
compid 1792 call mct_router_init(
prism_part(pcpointer%rpartID)%gsmap,
prism_part(pcpntpair%rpartID)%gsmap, &
1794 call mct_router_init(
prism_part(pcpntpair%rpartID)%gsmap,
prism_part(pcpointer%rpartID)%gsmap, &
1799 write(
nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
1802 do r1 = 1,min(
prism_part(pcpointer%rpartID)%gsmap%ngseg,10)
1803 write(
nulprt,*) subname,
" DEBUG router gs1 info ",
prism_part(pcpointer%rpartID)%gsmap%start(r1),&
1806 do r1 = 1,min(
prism_part(pcpointer%partID)%gsmap%ngseg,10)
1807 write(
nulprt,*) subname,
" DEBUG router gs2 info ",
prism_part(pcpointer%partID)%gsmap%start(r1),&
1810 do r1 = 1,min(
prism_part(pcpntpair%rpartID)%gsmap%ngseg,10)
1811 write(
nulprt,*) subname,
" DEBUG router gs3 info ",
prism_part(pcpntpair%rpartID)%gsmap%start(r1),&
1814 do r1 = 1,min(
prism_part(pcpntpair%partid)%gsmap%ngseg,10)
1815 write(
nulprt,*) subname,
" DEBUG router gs4 info ",
prism_part(pcpntpair%partid)%gsmap%start(r1),&
1818 do r1 = 1,
prism_router(pcpointer%routerID)%router%nprocs
1819 write(
nulprt,*) subname,
" DEBUG router info ",pcpointer%routerID,r1, &
1827 write(
nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
1830 do r1 = 1,
prism_router(pcpntpair%routerID)%router%nprocs
1831 write(
nulprt,*) subname,
" DEBUG router info ",pcpntpair%routerID,r1, &
1842 call mct_router_init(pcpointer%comp,
prism_part(pcpointer%rpartID)%gsmap, &
1847 write(
nulprt,*) subname,
" DEBUG ci:done initializing prism_router",&
1850 do r1 = 1,
prism_router(pcpointer%routerID)%router%nprocs
1851 write(
nulprt,*) subname,
" DEBUG router info ",pcpointer%routerID,r1, &
1873 write(
nulprt,*) subname,
' couplers initialized' 1907 integer(ip_i4_p),
intent(in) :: cplid
1910 integer(ip_i4_p) :: mapid, rouid, parid, namid, nflds, rpard
1911 integer(ip_i4_p) :: spart,dpart
1912 character(len=*),
parameter :: subname =
'(oasis_coupler_print)' 1916 mapid = pcprint%mapperid
1917 rouid = pcprint%routerid
1918 parid = pcprint%partid
1919 rpard = pcprint%rpartid
1920 namid = pcprint%namid
1921 nflds = pcprint%nflds
1924 write(
nulprt,*) subname,
' model and cplid',
compid,cplid
1926 write(
nulprt,*) subname,
' timerid send ',cplid,trim(pcprint%fldlist)
1927 write(
nulprt,*) subname,
' send fields ',trim(pcprint%fldlist)
1929 write(
nulprt,*) subname,
' to model ',pcprint%comp
1930 write(
nulprt,*) subname,
' using router ',rouid
1931 write(
nulprt,*) subname,
' transform ',pcprint%trans
1932 write(
nulprt,*) subname,
' snd diagnose ',pcprint%snddiag
1933 write(
nulprt,*) subname,
' snd fld mult ',pcprint%sndmult
1934 write(
nulprt,*) subname,
' snd fld add ',pcprint%sndadd
1937 write(
nulprt,*) subname,
' timerid recv ',cplid,trim(pcprint%fldlist)
1938 write(
nulprt,*) subname,
' recv fields ',trim(pcprint%fldlist)
1939 write(
nulprt,*) subname,
' from model ',pcprint%comp
1941 write(
nulprt,*) subname,
' using router ',rouid
1942 write(
nulprt,*) subname,
' rcv diagnose ',pcprint%rcvdiag
1943 write(
nulprt,*) subname,
' rcv fld mult ',pcprint%rcvmult
1944 write(
nulprt,*) subname,
' rcv fld add ',pcprint%rcvadd
1946 write(
nulprt,*) subname,
' namcouple op ',pcprint%ops
1947 write(
nulprt,*) subname,
' valid ',pcprint%valid
1948 write(
nulprt,*) subname,
' namcouple id ',namid
1949 write(
nulprt,*) subname,
' variable ids ',pcprint%varid(1:nflds)
1950 write(
nulprt,*) subname,
' sndrcv flag ',pcprint%sndrcv
1951 write(
nulprt,*) subname,
' output flag ',pcprint%output
1952 write(
nulprt,*) subname,
' input flag ',pcprint%input
1953 write(
nulprt,*) subname,
' input file ',trim(pcprint%inpfile)
1954 write(
nulprt,*) subname,
' restart file ',trim(pcprint%rstfile)
1955 write(
nulprt,*) subname,
' tag ',pcprint%tag
1956 write(
nulprt,*) subname,
' seq ',pcprint%seq
1957 write(
nulprt,*) subname,
' maxtime ',pcprint%maxtime
1958 write(
nulprt,*) subname,
' dt, lag ',pcprint%dt,pcprint%lag
1968 write(
nulprt,*) subname,
' maploc ',trim(pcprint%maploc)
1977 write(
nulprt,*) subname,
' conserve ',pcprint%conserv
1978 write(
nulprt,*) subname,
' conserve opt ',pcprint%consopt
1982 write(
nulprt,*) subname,
' s/d partids ',spart,dpart
1984 write(
nulprt,*) subname,
' from/to partition',trim(
prism_part(spart)%gridname),
' ',&
2015 integer(ip_i4_p),
intent(in) :: varid
2016 integer(ip_i4_p),
intent(in) :: varnum
2017 character(len=*),
intent(out) :: vname
2019 character(len=*),
parameter :: subname =
'(oasis_coupler_bldvarname)' 2030 write(vname,
'(a,i3.3)') trim(
prism_var(varid)%name)//
'.',varnum
2036 write(
nulprt,*) subname,
' check vname ',varnum,trim(vname)
2058 integer(ip_i4_p),
intent(in) :: varid
2059 character(len=*),
intent(in) :: vname
2060 integer(ip_i4_p),
intent(out) :: varnum
2062 integer(ip_i4_p) :: vlen
2063 character(len=16) :: clen
2064 character(len=*),
parameter :: subname =
'(oasis_coupler_unbldvarname)' 2069 vlen = len_trim(vname)
2070 clen = vname(vlen-2:vlen)
2071 read(clen,
'(i3.3)') varnum
2073 write(
nulprt,*) subname,
' check vlen ',vlen,trim(clen)
2080 write(
nulprt,*) subname,
' check varnum ',varnum,trim(vname)
2105 subroutine cplfind(num, fldlist, fld, ifind, nfind)
2111 integer,
parameter :: IN =
ip_i4_p 2112 integer,
parameter :: CL =
ic_lvar 2116 integer(IN),
intent(in) :: num
2117 character(len=CL),
intent(in) :: fldlist(:)
2118 character(len=CL),
intent(in) :: fld
2119 integer(IN) ,
intent(out) :: ifind
2120 integer(IN) ,
intent(out) :: nfind
2125 integer(IN) :: is,ie,im
2129 character(*),
parameter :: subName =
'(cplfind) ' 2148 if (.not.found)
then 2150 if (fld == fldlist(im)) found = .true.
2152 if (.not.found)
then 2154 if (fld == fldlist(im)) found = .true.
2159 do while (.not.found .and. ie > is)
2164 if (fld == fldlist(im))
then 2166 elseif (fld > fldlist(im))
then 2179 do while (fld == fldlist(is-1) .and. is > 1)
2184 do while (fld == fldlist(ie+1) .and. ie < num)
2189 nfind = (ie - is + 1)
integer(kind=ip_i4_p), public lastseqtime
last coupler sequence time
character(len=ic_med), dimension(:), pointer, public namfldcoo
conserv fld option (bfb, opt)
integer(kind=ip_intwp_p), parameter ip_output
character(len=jpeighty), dimension(:), pointer, public namsrcfld
list of src fields
real(kind=ip_realwp_p), dimension(:), pointer, public namfldsmu
src multiplier term
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.
Provides reusable IO routines for OASIS.
integer(kind=ip_i4_p), public nnamcpl
number of namcouple inputs
character(len=ic_lvar), dimension(:), pointer, public namdstgrd
dst grid name
integer(kind=ip_i4_p) lucia_debug
subroutine, public oasis_part_create(id_part, TYPE, gsize, nx, ny, gridname, gscomm, mpicom, gridID)
Create a new partition internally, needed for mapping.
Generic overloaded interface into MPI max reduction.
Router information for rearranging data on tasks.
integer(kind=ip_i4_p), dimension(:), pointer, public namfldseq
SEQ value.
subroutine, public oasis_map_smatreaddnc_ceg(sMat, SgsMap, DgsMap, newdom, fileName, mytask, mpicom, nwgts, areasrc, areadst, ni_i, nj_i, ni_o, nj_o)
Read in mapping matrix data from a SCRIP netCDF file using smart scatter (ceg)
integer(kind=ip_intwp_p), parameter oasis_in
integer(kind=ip_i4_p), dimension(:), pointer, public namfldtrn
fields transform, ip_instant,...
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.
character(len=ic_med), public nammapdec
namcouple map decomp value
character(len=ic_med), public nammatxrd
namcouple matrix read option
integer(kind=ip_intwp_p), parameter ip_expout
integer(kind=ip_i4_p) mpi_comm_global
type(prism_coupler_type), dimension(:), pointer, public prism_coupler_get
prism_coupler get array
integer(kind=ip_intwp_p), parameter ip_instant
character(len=ic_med), dimension(:), pointer, public nammaploc
mapping location (src or dst pes)
integer(kind=ip_i4_p), dimension(:), pointer, public namflddti
coupling period (secs)
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
subroutine, public oasis_map_smatreaddnc_orig(sMat, SgsMap, DgsMap, newdom, fileName, mytask, mpicom, nwgts, areasrc, areadst, ni_i, nj_i, ni_o, nj_o)
Read in mapping matrix data from a SCRIP netCDF weights file.
character(len=jpeighty), dimension(:), pointer, public namdstfld
list of dst fields
character(len=ic_med), dimension(:), pointer, public namrstfil
restart file name
subroutine, public oasis_string_listgetname(list, k, name, rc)
Get name of k-th field in list.
integer, parameter ip_i4_p
integer(kind=ip_i4_p) compid
subroutine oasis_coupler_print(cplid, pcprint)
Print routine for oasis_couplers.
integer(kind=ip_i4_p), dimension(:), pointer, public namfldcon
conserv fld operation
character(len= *), parameter cspval
Initialize the OASIS coupler infrastructure.
integer(kind=ip_i4_p) mpi_rank_local
integer, parameter ip_double_p
integer(kind=ip_i4_p) prism_amodels
Character string manipulation methods.
integer(kind=ip_intwp_p), parameter ip_exported
integer(kind=ip_intwp_p) nullucia
Provides a generic and simpler interface into MPI calls for OASIS.
integer(kind=ip_i4_p), dimension(:), pointer, public namfldops
operation, ip_expout,...
integer(kind=ip_intwp_p), parameter oasis3_get
Coupler data for managing all aspects of coupling in OASIS.
subroutine cplfind(num, fldlist, fld, ifind, nfind)
Search a character field list for a matching values.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
subroutine, public oasis_sys_sortikey(num, arr, sortkey)
Sort an integer array using a sort key.
character(len=ic_lvar), dimension(:), pointer, public namsrcgrd
src grid name
real(kind=ip_realwp_p), dimension(:), pointer, public namflddad
dst additive term
logical, dimension(:), pointer, public namchecki
checkin flag
OASIS partition data and methods.
integer(kind=ip_i4_p), dimension(:), pointer, public namsrc_nx
src nx grid size
integer(kind=ip_i4_p), parameter, public prism_coupler_avsmax
maximum number of higher order terms in mapping
integer(kind=ip_intwp_p), parameter oasis3_put
subroutine, public oasis_sys_sortc(num, fld, sortkey)
Sort a character array and compute a sort key.
character(len=ic_med), dimension(:), pointer, public nammapopt
mapping option (bfb, sum, or opt)
character(len=ic_med), dimension(:), pointer, public namscrmet
scrip method (CONSERV, DISTWGT, BILINEAR, BICUBIC, GAUSWGT)
real(kind=ip_realwp_p), dimension(:), pointer, public namflddmu
dst multipler term
integer(kind=ip_i4_p), dimension(:), pointer, public namsrc_ny
src ny grid size
integer(kind=ip_i4_p), dimension(:), allocatable mpi_root_global
subroutine, public oasis_map_genmap(mapid, namid)
Routine to generate mapping weights data via a direct SCRIP call.
subroutine, public oasis_coupler_bldvarname(varid, varnum, vname)
Build a consistent variable name based on bundles.
integer(kind=ip_intwp_p), parameter oasis_comm_ready
integer(kind=ip_i4_p), public prism_mmapper
max mappers
Defines parameters for OASIS.
OASIS variable data and methods.
subroutine, public oasis_io_read_avfld(filename, av, gsmap, mpicom, avfld, filefld, fldtype)
Reads single field from a file into an attribute Vector.
subroutine, public oasis_timer_start(timer_label, barrier)
Start a timer.
integer(kind=ip_i4_p) oasis_debug
integer(kind=ip_intwp_p), parameter oasis_out
subroutine, public oasis_timer_stop(timer_label)
Stop a timer.
type(prism_router_type), dimension(:), pointer, public prism_router
prism_router array
character(len= *), parameter, public estr
integer(kind=ip_i4_p) mpi_comm_local
integer function, public oasis_string_listgetnum(str)
return number of fields in string list
subroutine, public oasis_mpi_barrier(comm, string)
Call MPI_BARRIER for a particular communicator.
real(kind=ip_realwp_p), dimension(:), pointer, public namfldsad
src additive term
integer, parameter ic_lvar
type(prism_mapper_type), dimension(:), pointer, public prism_mapper
list of defined mappers
integer(kind=ip_intwp_p), parameter oasis_notdef
integer(kind=ip_i4_p), dimension(:), pointer, public namfldlag
coupling lag (secs)
integer(kind=ip_i4_p), parameter, public mvarcpl
max namcouples per variable
character(len=ic_med), dimension(:), pointer, public naminpfil
input file name
integer(kind=ip_i4_p) prism_mrouter
max routers
logical, public allow_no_restart
flag to allow no restart files at startup
integer(kind=ip_i4_p), public prism_nmapper
mapper counter
integer(kind=ip_intwp_p), parameter ip_input
subroutine, public oasis_flush(nu)
Flushes output to file.
character(len=ic_long), dimension(:), pointer, public nammapfil
mapping file name
integer(kind=ip_i4_p), dimension(:), pointer, public namdst_nx
dst nx grid size
integer(kind=ip_i4_p), dimension(:), pointer, public namnn2sort
sorted namcpl for nn, define sort number, computed later
subroutine, public oasis_coupler_unbldvarname(varid, vname, varnum)
Deconstruct the varname based on oasis_coupler_bldvarname.
integer(kind=ip_i4_p) prism_nrouter
router counter
integer(kind=ip_intwp_p), public prism_nvar
number of variables defined
subroutine, public oasis_coupler_setup()
Main routine to setup couplers.
integer(kind=ip_i4_p), public namruntim
namcouple runtime
Performance timer methods.
integer(ip_intwp_p), public maxvar
number of potential variables, derived from namcouple input
integer(kind=ip_i4_p), public prism_mcoupler
max couplers
integer(kind=ip_i4_p), dimension(:), pointer, public namdst_ny
dst ny grid size
type(prism_var_type), dimension(:), pointer, public prism_var
list of defined variables
Reads the namcouple file for use in OASIS.
integer(ip_i4_p), parameter ispval
logical, dimension(:), pointer, public namchecko
checkout flag
integer(kind=ip_intwp_p), parameter oasis_comm_wait
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.
character(len=ic_med), dimension(:), pointer, public namscrnor
scrip conserv normalization (FRACAREA, DESTAREA, FRACNNEI)
OASIS map (interpolation) data and methods.