22 use gengrid_kinds,
only: cl, cs, dbl_kind, real_kind, int_kind
23 use angles,
only: find_ang, find_angq, find_angchk
24 use vertices,
only: fill_vertices, fill_bottom, fill_top
25 use mapped_mask,
only: make_frac_land
26 use postwgts,
only: make_postwgts
27 use tripolegrid,
only: write_tripolegrid
28 use cicegrid,
only: write_cicegrid
29 use scripgrid,
only: write_scripgrid
30 use topoedits,
only: add_topoedits, apply_topoedits
31 use charstrings,
only: logmsg, res, atmres, dirsrc, dirout, fv3dir, editsfile
32 use charstrings,
only: maskfile, maskname, topofile, toponame, editsfile, staggerlocs, cdate, history
33 use debugprint,
only: checkseam, checkxlatlon, checkpoint
39 real(dbl_kind) :: dxt, dyt
41 real(kind=dbl_kind),
parameter :: pi = 3.14159265358979323846_dbl_kind
42 real(kind=dbl_kind),
parameter :: deg2rad = pi/180.0_dbl_kind
44 real(real_kind),
allocatable,
dimension(:,:) :: ww3dpth
45 integer(int_kind),
allocatable,
dimension(:,:) :: ww3mask
47 character(len=CL) :: fsrc, fdst, fwgt
48 character(len= 2) :: cstagger
50 integer :: rc,ncid,id,xtype
51 integer :: i,j,k,n,i2,j2
53 integer :: localpet, npet
54 logical :: fexist = .false.
56 type(esmf_regridmethod_flag) :: method
60 character(len= 6) :: i4fmt =
'(i4.4)' 61 character(len=CS) :: form1
62 character(len=CS) :: form2
63 character(len= 6) :: cnx
69 call esmf_vmgetglobal(vm, rc=rc)
70 call esmf_initialize(vm=vm, logkindflag=esmf_logkind_multi, rc=rc)
71 call esmf_vmget(vm, localpet=localpet, pecount=npet, rc=rc)
72 if (esmf_logfounderror(rctocheck=rc, msg=esmf_logerr_passthru, &
73 line=__line__, file=__file__))
call esmf_finalize(endflag=esmf_end_abort)
75 if (localpet == 0) roottask =.true.
77 print *,npet,
' More than one task specified; Aborting ' 78 call esmf_finalize(endflag=esmf_end_abort)
85 call read_inputnml(
'grid.nml')
87 print
'(a,2i6)',
' output grid requested ',ni,nj
88 print
'(a,2i6)',
' supergrid size used ', nx,ny
89 print
'(a)',
' output grid tag '//trim(res)
90 print
'(a)',
' supergrid source directory '//trim(dirsrc)
91 print
'(a)',
' output grid directory '//trim(dirout)
92 print
'(a)',
' atm mosaic directory '//trim(fv3dir)
93 print
'(a)',
' MOM6 topography file '//trim(topofile)
94 print
'(a)',
' MOM6 edits file '//trim(editsfile)
95 print *,
'editmask flag ',editmask
96 print *,
'debug flag ',debug
97 print *,
'do_postwgts flag ',do_postwgts
102 call esmf_logwrite(
"Starting gen_fixgrid", esmf_logmsg_info)
107 ivertcu = ivertct + 1; jvertcu = jvertct + 0
108 ivertcv = ivertct + 0; jvertcv = jvertct + 1
109 ivertbu = ivertct + 1; jvertbu = jvertct + 1
111 print
'(a8,4i6)',
'iVertCt ',(ivertct(i),i=1,4)
112 print
'(a8,4i6)',
'jVertCt ',(jvertct(i),i=1,4)
114 print
'(a8,4i6)',
'iVertCu ',(ivertcu(i),i=1,4)
115 print
'(a8,4i6)',
'jVertCu ',(jvertcu(i),i=1,4)
117 print
'(a8,4i6)',
'iVertCv ',(ivertcv(i),i=1,4)
118 print
'(a8,4i6)',
'jVertCv ',(jvertcv(i),i=1,4)
120 print
'(a8,4i6)',
'iVertBu ',(ivertbu(i),i=1,4)
121 print
'(a8,4i6)',
'jVertBu ',(jvertbu(i),i=1,4)
124 latct_vert = -9999.0 ; lonct_vert = -9999.0
125 latcu_vert = -9999.0 ; loncu_vert = -9999.0
126 latcv_vert = -9999.0 ; loncv_vert = -9999.0
127 latbu_vert = -9999.0 ; lonbu_vert = -9999.0
133 fsrc = trim(dirsrc)//
'/'//trim(maskfile)
135 rc = nf90_open(fsrc, nf90_nowrite, ncid)
136 print
'(a)',
'reading ocean mask from '//trim(fsrc)
137 if(rc .ne. 0)print
'(a)',
'nf90_open = '//trim(nf90_strerror(rc))
139 wet4 = 0.0; wet8 = 0.0
140 rc = nf90_inq_varid(ncid, trim(maskname), id)
141 rc = nf90_inquire_variable(ncid, id, xtype=xtype)
142 if(xtype .eq. 5)rc = nf90_get_var(ncid, id, wet4)
143 if(xtype .eq. 6)rc = nf90_get_var(ncid, id, wet8)
144 rc = nf90_close(ncid)
146 if(xtype.eq. 6)wet4 =
real(wet8,4)
152 fsrc = trim(dirsrc)//
'/'//trim(topofile)
154 rc = nf90_open(fsrc, nf90_nowrite, ncid)
155 print
'(a)',
'reading ocean topography from '//trim(fsrc)
156 if(rc .ne. 0)print
'(a)',
'nf90_open = '//trim(nf90_strerror(rc))
159 rc = nf90_inq_varid(ncid, trim(toponame), id)
160 rc = nf90_inquire_variable(ncid, id, xtype=xtype)
161 if(xtype .eq. 5)rc = nf90_get_var(ncid, id, dp4)
162 if(xtype .eq. 6)rc = nf90_get_var(ncid, id, dp8)
163 rc = nf90_close(ncid)
165 if(xtype.eq. 6)dp4 =
real(dp8,4)
174 if(trim(editsfile) ==
'none')
then 175 print
'(a)',
'Need a valid editsfile to make mask edits ' 178 inquire(file=trim(dirsrc)//
'/'//trim(editsfile),exist=fexist)
179 if (.not. fexist)
then 180 print
'(a)',
'Required topoedits file '//trim(editsfile) &
181 //
'for land mask changes is missing ' 185 fsrc = trim(dirsrc)//
'/'//trim(editsfile)
186 fdst = trim(dirout)//
'/'//
'ufs.'//trim(editsfile)
187 call add_topoedits(fsrc,fdst)
199 fsrc = trim(dirsrc)//
'/'//trim(editsfile)
200 if(editmask)fsrc = trim(dirout)//
'/'//
'ufs.'//trim(editsfile)
202 if (trim(editsfile) /=
'none')
then 203 inquire(file=trim(fsrc),exist=fexist)
204 if (.not. fexist)
then 205 print
'(a)',
'Required topoedits file '//trim(fsrc)//
' is missing ' 209 call apply_topoedits(fsrc)
215 fsrc = trim(dirsrc)//
'/'//
'ocean_hgrid.nc' 217 rc = nf90_open(fsrc, nf90_nowrite, ncid)
218 print
'(a)',
'reading supergrid from '//trim(fsrc)
219 if(rc .ne. 0)print
'(a)',
'nf90_open = '//trim(nf90_strerror(rc))
221 rc = nf90_inq_varid(ncid,
'x', id)
222 rc = nf90_get_var(ncid, id, x)
224 rc = nf90_inq_varid(ncid,
'y', id)
225 rc = nf90_get_var(ncid, id, y)
227 rc = nf90_inq_varid(ncid,
'dx', id)
228 rc = nf90_get_var(ncid, id, dx)
230 rc = nf90_inq_varid(ncid,
'dy', id)
231 rc = nf90_get_var(ncid, id, dy)
233 rc = nf90_close(ncid)
234 sg_maxlat = maxval(y)
235 write(logmsg,
'(a,f12.2)')
'max lat in super grid ',maxval(y)
236 print
'(a)',trim(logmsg)
246 ulon(i,j) = x(i2,j2)*deg2rad
247 ulat(i,j) = y(i2,j2)*deg2rad
249 htn(i,j) = (dx(i2-1,j2) + dx(i2,j2))*100._dbl_kind
250 hte(i,j) = (dy(i2,j2-1) + dy(i2,j2))*100._dbl_kind
252 lonbu(i,j) = x(i2,j2)
253 latbu(i,j) = y(i2,j2)
255 lonct(i,j) = x(i2-1,j2-1)
256 loncu(i,j) = x(i2, j2-1)
257 loncv(i,j) = x(i2-1,j2 )
259 latct(i,j) = y(i2-1,j2-1)
260 latcu(i,j) = y(i2, j2-1)
261 latcv(i,j) = y(i2-1,j2 )
263 dxt = dx(i2-1,j2-1) + dx(i2,j2-1)
264 dyt = dy(i2-1,j2-1) + dy(i2-1,j2)
265 areact(i,j) = dxt*dyt
277 if(latbu(i,j) .eq. sg_maxlat)ipole(1) = i
280 if(latbu(i,j) .eq. sg_maxlat)ipole(2) = i
282 write(logmsg,
'(a,2i6,2f12.2)')
'poles found at i = ',ipole, latbu(ipole(1),nj), &
284 print
'(a)',trim(logmsg)
290 call find_ang((/1,ni/),(/1,nj/),lonbu,latbu,lonct,anglet)
291 write(logmsg,
'(a,2f12.2)')
'ANGLET min,max: ',minval(anglet),maxval(anglet)
292 print
'(a)',trim(logmsg)
293 write(logmsg,
'(a,2f12.2)')
'ANGLET edges i=1,i=ni: ',anglet(1,nj),anglet(ni,nj)
294 print
'(a)',trim(logmsg)
298 i2 = ipole(2)+(ipole(1)-i)+1
299 xangct(i) = -anglet(i2,nj)
306 call find_angq((/1,ni/),(/1,nj/),xangct,anglet,angle)
307 angle(ni,:) = -angle(1,:)
310 write(logmsg,
'(a,2f12.2)')
'ANGLE min,max: ',minval(angle),maxval(angle)
311 print
'(a)',trim(logmsg)
312 write(logmsg,
'(a,2f12.2)')
'ANGLE edges i=1,i=ni: ',angle(1,nj),angle(ni,nj)
313 print
'(a)',trim(logmsg)
319 call find_angchk((/1,ni/),(/1,nj/),angle,angchk)
320 angchk(1,:) = -angchk(ni,:)
323 write(logmsg,
'(a,2f12.2)')
'ANGCHK min,max: ',minval(angchk),maxval(angchk)
324 print
'(a)',trim(logmsg)
325 write(logmsg,
'(a,2f12.2)')
'ANGCHK edges i=1,i=ni: ',angchk(1,nj),angchk(ni,nj)
326 print
'(a)',trim(logmsg)
336 write(logmsg,
'(a,2e12.5)')
'min vals of hte at folds ', minval(hte(ni/2,:)),minval(hte(ni,:))
337 print
'(a)',trim(logmsg)
340 if(hte(ii,j) .le. 1.0)hte(ii,j) = 0.5*(hte(ii-1,j) + hte(ii+1,j))
342 if(hte(ii,j) .le. 1.0)hte(ii,j) = 0.5*(hte(ii-1,j) + hte( 1,j))
344 write(logmsg,
'(a,2e12.5)')
'min vals of hte at folds ', minval(hte(ni/2,:)),minval(hte(ni,:))
345 print
'(a)',trim(logmsg)
351 if(debug)
call checkseam
354 i2 = ipole(2)+(ipole(1)-i)+1
355 xlonct(i) = lonct(i2,nj)
356 xlatct(i) = latct(i2,nj)
360 i2 = ipole(2)+(ipole(1)-i)
362 xloncu(i) = loncu(i2,nj)
363 xlatcu(i) = latcu(i2,nj)
366 if(debug)
call checkxlatlon
370 dlatbu(i) = latbu(i,1) + 2.0*(latcu(i,1) - latbu(i,1))
371 dlatcv(i) = latct(i,1) + 2.0*(latct(i,1) - latcv(i,1))
379 call fill_vertices(2,nj , ivertct,jvertct, latbu,lonbu, latct_vert,lonct_vert)
380 call fill_bottom(ivertct,jvertct, latbu,lonbu, latct_vert,lonct_vert,dlatbu)
382 call fill_vertices(2,nj , ivertcu,jvertcu, latcv,loncv, latcu_vert,loncu_vert)
383 call fill_bottom(ivertcu,jvertcu, latcv,loncv, latcu_vert,loncu_vert,dlatcv)
386 call fill_vertices(1,nj-1, ivertcv,jvertcv, latcu,loncu, latcv_vert,loncv_vert)
387 call fill_top(ivertcv,jvertcv, latcu,loncu, latcv_vert,loncv_vert, xlatcu, xloncu)
389 call fill_vertices(1,nj-1, ivertbu,jvertbu, latct,lonct, latbu_vert,lonbu_vert)
390 call fill_top(ivertbu,jvertbu, latct,lonct, latbu_vert,lonbu_vert, xlatct, xlonct)
392 if(debug)
call checkpoint
394 if(minval(latct_vert) .lt. -1.e3)stop
395 if(minval(lonct_vert) .lt. -1.e3)stop
396 if(minval(latcu_vert) .lt. -1.e3)stop
397 if(minval(loncu_vert) .lt. -1.e3)stop
398 if(minval(latcv_vert) .lt. -1.e3)stop
399 if(minval(loncv_vert) .lt. -1.e3)stop
400 if(minval(latbu_vert) .lt. -1.e3)stop
401 if(minval(lonbu_vert) .lt. -1.e3)stop
402 deallocate(xlonct, xlatct, xloncu, xlatcu, dlatbu, dlatcv)
409 call date_and_time(date=cdate)
410 history =
'created on '//trim(cdate)//
' from '//trim(fsrc)
413 fdst = trim(dirout)//
'/'//
'tripole.mx'//trim(res)//
'.nc' 414 call write_tripolegrid(trim(fdst))
417 fdst = trim(dirout)//
'/'//
'grid_cice_NEMS_mx'//trim(res)//
'.nc' 418 call write_cicegrid(trim(fdst))
419 deallocate(ulon, ulat, htn, hte)
423 cstagger = trim(staggerlocs(k))
424 fdst = trim(dirout)//
'/'//trim(cstagger)//
'.mx'//trim(res)//
'_SCRIP.nc' 425 logmsg =
'creating SCRIP file '//trim(fdst)
426 print
'(a)',trim(logmsg)
427 call write_scripgrid(trim(fdst),trim(cstagger))
429 deallocate(latcv_vert, loncv_vert)
430 deallocate(latcu_vert, loncu_vert)
431 deallocate(latbu_vert, lonbu_vert)
435 cstagger = trim(staggerlocs(1))
436 fdst= trim(dirout)//
'/'//trim(cstagger)//
'.mx'//trim(res)//
'_SCRIP_land.nc' 437 logmsg =
'creating SCRIP file '//trim(fdst)
438 print
'(a)',trim(logmsg)
439 call write_scripgrid(trim(fdst),trim(cstagger),imask=int(wet4))
440 deallocate(latct_vert, lonct_vert)
448 write(form1,
'(a)')
'('//trim(cnx)//
'f14.8)' 449 write(form2,
'(a)')
'('//trim(cnx)//
'i2)' 451 allocate(ww3mask(1:ni,1:nj)); ww3mask = int(wet4)
452 allocate(ww3dpth(1:ni,1:nj)); ww3dpth = dp4
454 where(latct .ge. maximum_lat)ww3mask = 3
458 open(unit=21,file=trim(dirout)//
'/'//
'ww3.mx'//trim(res)//
'_x.inp',form=
'formatted')
459 open(unit=22,file=trim(dirout)//
'/'//
'ww3.mx'//trim(res)//
'_y.inp',form=
'formatted')
460 open(unit=23,file=trim(dirout)//
'/'//
'ww3.mx'//trim(res)//
'_bottom.inp',form=
'formatted')
461 open(unit=24,file=trim(dirout)//
'/'//
'ww3.mx'//trim(res)//
'_mapsta.inp',form=
'formatted')
463 open(unit=25,file=trim(dirout)//
'/'//
'ww3.mx'//trim(res)//
'_obstr.inp',form=
'formatted')
466 write( 21,trim(form1))lonct(:,j)
467 write( 22,trim(form1))latct(:,j)
470 write( 23,trim(form1))ww3dpth(:,j)
471 write( 24,trim(form2))ww3mask(:,j)
473 write( 25,trim(form2))ww3mask(:,j)*0
474 write( 25,trim(form2))ww3mask(:,j)*0
477 close(21);
close(22);
close(23);
close(24);
close(25)
478 deallocate(ww3mask);
deallocate(ww3dpth)
479 deallocate(wet4, wet8)
490 write(atmres,
'(a,i2)')
'C',npx
491 elseif (npx < 1000)
then 492 write(atmres,
'(a,i3)')
'C',npx
494 write(atmres,
'(a,i4)')
'C',npx
497 method=esmf_regridmethod_conserve
498 fsrc = trim(dirout)//
'/'//
'Ct.mx'//trim(res)//
'_SCRIP_land.nc' 499 fdst = trim(fv3dir)//
'/'//trim(atmres)//
'/'//trim(atmres)//
'_mosaic.nc' 500 fwgt = trim(dirout)//
'/'//
'Ct.mx'//trim(res)//
'.to.'//trim(atmres)//
'.nc' 501 logmsg =
'creating weight file '//trim(fwgt)
502 print
'(a)',trim(logmsg)
504 call esmf_regridweightgen(srcfile=trim(fsrc),dstfile=trim(fdst), &
505 weightfile=trim(fwgt), regridmethod=method, &
506 unmappedaction=esmf_unmappedaction_ignore, ignoredegenerate=.true., &
507 netcdf4fileflag=.true., tilefilepath=trim(fv3dir)//
'/'//trim(atmres)//
'/', rc=rc)
508 if (esmf_logfounderror(rctocheck=rc, msg=esmf_logerr_passthru, &
509 line=__line__, file=__file__))
call esmf_finalize(endflag=esmf_end_abort)
511 logmsg =
'creating mapped ocean mask for '//trim(atmres)
512 print
'(a)',trim(logmsg)
513 call make_frac_land(trim(fsrc), trim(fwgt))
521 method=esmf_regridmethod_bilinear
522 fdst = trim(dirout)//
'/'//
'Ct.mx'//trim(res)//
'_SCRIP.nc' 524 cstagger = trim(staggerlocs(k))
525 fsrc = trim(dirout)//
'/'//trim(cstagger)//
'.mx'//trim(res)//
'_SCRIP.nc' 526 fwgt = trim(dirout)//
'/'//
'tripole.mx'//trim(res)//
'.'//trim(cstagger)//
'.to.Ct.bilinear.nc' 527 logmsg =
'creating weight file '//trim(fwgt)
528 print
'(a)',trim(logmsg)
530 call esmf_regridweightgen(srcfile=trim(fsrc),dstfile=trim(fdst), &
531 weightfile=trim(fwgt), regridmethod=method, &
532 ignoredegenerate=.true., &
533 unmappedaction=esmf_unmappedaction_ignore, rc=rc)
534 if (esmf_logfounderror(rctocheck=rc, msg=esmf_logerr_passthru, &
535 line=__line__, file=__file__))
call esmf_finalize(endflag=esmf_end_abort)
544 if(trim(res) .ne.
'025')
then 545 method=esmf_regridmethod_bilinear
546 fsrc = trim(dirout)//
'/'//
'Ct.mx'//trim(res)//
'_SCRIP.nc' 548 cstagger = trim(staggerlocs(k))
549 fdst = trim(dirout)//
'/'//trim(cstagger)//
'.mx'//trim(res)//
'_SCRIP.nc' 550 fwgt = trim(dirout)//
'/'//
'tripole.mx'//trim(res)//
'.Ct.to.'//trim(cstagger)//
'.bilinear.nc' 551 logmsg =
'creating weight file '//trim(fwgt)
552 print
'(a)',trim(logmsg)
554 call esmf_regridweightgen(srcfile=trim(fsrc),dstfile=trim(fdst), &
555 weightfile=trim(fwgt), regridmethod=method, &
556 ignoredegenerate=.true., &
557 unmappedaction=esmf_unmappedaction_ignore, rc=rc)
558 if (esmf_logfounderror(rctocheck=rc, msg=esmf_logerr_passthru, &
559 line=__line__, file=__file__))
call esmf_finalize(endflag=esmf_end_abort)
567 if(do_postwgts)
call make_postwgts
573 deallocate(x, y, dx, dy)
574 deallocate(areact, anglet, angle, angchk)
575 deallocate(latct, lonct)
576 deallocate(latcv, loncv)
577 deallocate(latcu, loncu)
578 deallocate(latbu, lonbu)
program gen_fixgrid
Generate fixed grid files required for coupled model using the MOM6 super grid file and ocean mask fi...