-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathcrsdomwri.f90
156 lines (156 loc) · 6.63 KB
/
crsdomwri.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
MODULE crsdomwri
USE timing
USE dom_oce
USE in_out_manager
USE par_kind, ONLY: wp
USE lib_mpp
USE iom_def
USE iom
USE crs
USE crsdom
USE crslbclnk
IMPLICIT NONE
PRIVATE
PUBLIC :: crs_dom_wri
CONTAINS
SUBROUTINE crs_dom_wri
INTEGER :: ji, jj, jk
INTEGER :: inum
INTEGER :: iif, iil, ijf, ijl
CHARACTER(LEN = 21) :: clnam
REAL(KIND = wp), DIMENSION(jpi_crs, jpj_crs) :: zprt, zprw
REAL(KIND = wp), DIMENSION(jpi_crs, jpj_crs, jpk) :: zdepu, zdepv
IF (lwp) WRITE(numout, FMT = *)
IF (lwp) WRITE(numout, FMT = *) 'crs_dom_wri : create NetCDF mesh and mask file'
IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~'
clnam = 'mesh_mask_crs'
CALL iom_open(TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib)
CALL iom_rstput(0, 0, inum, 'tmask', tmask_crs, ktype = jp_i1)
CALL iom_rstput(0, 0, inum, 'umask', umask_crs, ktype = jp_i1)
CALL iom_rstput(0, 0, inum, 'vmask', vmask_crs, ktype = jp_i1)
CALL iom_rstput(0, 0, inum, 'fmask', fmask_crs, ktype = jp_i1)
!$ACC KERNELS
tmask_i_crs(:, :) = tmask_crs(:, :, 1)
iif = nn_hls
iil = nlci_crs - nn_hls + 1
ijf = nn_hls
ijl = nlcj_crs - nn_hls + 1
tmask_i_crs(1 : iif, :) = 0._wp
tmask_i_crs(iil : jpi_crs, :) = 0._wp
tmask_i_crs(:, 1 : ijf) = 0._wp
tmask_i_crs(:, ijl : jpj_crs) = 0._wp
tpol_crs(1 : jpiglo_crs, :) = 1._wp
fpol_crs(1 : jpiglo_crs, :) = 1._wp
!$ACC END KERNELS
IF (jperio == 3 .OR. jperio == 4) THEN
!$ACC KERNELS
tpol_crs(jpiglo_crs / 2 + 1 : jpiglo_crs, :) = 0._wp
fpol_crs(1 : jpiglo_crs, :) = 0._wp
!$ACC END KERNELS
IF (mjg_crs(nlej_crs) == jpiglo_crs) THEN
!$ACC KERNELS
DO ji = iif + 1, iil - 1
tmask_i_crs(ji, nlej_crs - 1) = tmask_i_crs(ji, nlej_crs - 1) * tpol_crs(mig_crs(ji), 1)
END DO
!$ACC END KERNELS
END IF
END IF
IF (jperio == 5 .OR. jperio == 6) THEN
!$ACC KERNELS
tpol_crs(1 : jpiglo_crs, :) = 0._wp
fpol_crs(jpiglo_crs / 2 + 1 : jpiglo_crs, :) = 0._wp
!$ACC END KERNELS
END IF
CALL iom_rstput(0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1)
CALL dom_uniq_crs(zprw, 'U')
zprt = umask_crs(:, :, 1) * zprw
CALL iom_rstput(0, 0, inum, 'umaskutil', zprt, ktype = jp_i1)
CALL dom_uniq_crs(zprw, 'V')
zprt = vmask_crs(:, :, 1) * zprw
CALL iom_rstput(0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1)
CALL dom_uniq_crs(zprw, 'F')
zprt = fmask_crs(:, :, 1) * zprw
CALL iom_rstput(0, 0, inum, 'fmaskutil', zprt, ktype = jp_i1)
CALL iom_rstput(0, 0, inum, 'glamt', glamt_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'glamu', glamu_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'glamv', glamv_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'glamf', glamf_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gphit', gphit_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gphiu', gphiu_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gphiv', gphiv_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gphif', gphif_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'e1t', e1t_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e1u', e1u_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e1v', e1v_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e1f', e1f_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e2t', e2t_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e2u', e2u_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e2v', e2v_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'e2f', e2f_crs, ktype = jp_r8)
CALL iom_rstput(0, 0, inum, 'ff', ff_crs, ktype = jp_r8)
!$ACC KERNELS
zprt(:, :) = tmask_crs(:, :, 1) * REAL(mbkt_crs(:, :), wp)
!$ACC END KERNELS
CALL iom_rstput(0, 0, inum, 'mbathy', zprt, ktype = jp_i2)
CALL iom_rstput(0, 0, inum, 'e3t', e3t_crs)
CALL iom_rstput(0, 0, inum, 'e3w', e3w_crs)
CALL iom_rstput(0, 0, inum, 'e3u', e3u_crs)
CALL iom_rstput(0, 0, inum, 'e3v', e3v_crs)
CALL iom_rstput(0, 0, inum, 'gdept', gdept_crs, ktype = jp_r4)
!$ACC KERNELS
DO jk = 1, jpk
DO jj = 1, jpj_crsm1
DO ji = 1, jpi_crsm1
zdepu(ji, jj, jk) = MIN(gdept_crs(ji, jj, jk), gdept_crs(ji + 1, jj, jk)) * umask_crs(ji, jj, jk)
zdepv(ji, jj, jk) = MIN(gdept_crs(ji, jj, jk), gdept_crs(ji, jj + 1, jk)) * vmask_crs(ji, jj, jk)
END DO
END DO
END DO
!$ACC END KERNELS
CALL crs_lbc_lnk(zdepu, 'U', 1.)
CALL crs_lbc_lnk(zdepv, 'V', 1.)
CALL iom_rstput(0, 0, inum, 'gdepu', zdepu, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gdepv', zdepv, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gdepw', gdepw_crs, ktype = jp_r4)
CALL iom_rstput(0, 0, inum, 'gdept_1d', gdept_1d)
CALL iom_rstput(0, 0, inum, 'gdepw_1d', gdepw_1d)
CALL iom_rstput(0, 0, inum, 'e3t_1d', e3t_1d)
CALL iom_rstput(0, 0, inum, 'e3w_1d', e3w_1d)
CALL iom_rstput(0, 0, inum, 'ocean_volume_t', ocean_volume_crs_t)
CALL iom_rstput(0, 0, inum, 'facvol_t', facvol_t)
CALL iom_rstput(0, 0, inum, 'facvol_w', facvol_w)
CALL iom_rstput(0, 0, inum, 'facsurfu', facsurfu)
CALL iom_rstput(0, 0, inum, 'facsurfv', facsurfv)
CALL iom_rstput(0, 0, inum, 'e1e2w_msk', e1e2w_msk)
CALL iom_rstput(0, 0, inum, 'e2e3u_msk', e2e3u_msk)
CALL iom_rstput(0, 0, inum, 'e1e3v_msk', e1e3v_msk)
CALL iom_rstput(0, 0, inum, 'e1e2w', e1e2w_crs)
CALL iom_rstput(0, 0, inum, 'e2e3u', e2e3u_crs)
CALL iom_rstput(0, 0, inum, 'e1e3v', e1e3v_crs)
CALL iom_rstput(0, 0, inum, 'bt', bt_crs)
CALL iom_rstput(0, 0, inum, 'r1_bt', r1_bt_crs)
CALL iom_rstput(0, 0, inum, 'crs_surfu_wgt', crs_surfu_wgt)
CALL iom_rstput(0, 0, inum, 'crs_surfv_wgt', crs_surfv_wgt)
CALL iom_rstput(0, 0, inum, 'crs_volt_wgt', crs_volt_wgt)
CALL iom_close(inum)
END SUBROUTINE crs_dom_wri
SUBROUTINE dom_uniq_crs(puniq, cdgrd)
CHARACTER(LEN = 1), INTENT(IN ) :: cdgrd
REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: puniq
REAL(KIND = wp) :: zshift
INTEGER :: ji
LOGICAL, DIMENSION(SIZE(puniq, 1), SIZE(puniq, 2), 1) :: lldbl
REAL(KIND = wp), DIMENSION(jpi_crs, jpj_crs) :: ztstref
!$ACC KERNELS
zshift = jpi_crs * jpj_crs * (narea - 1)
ztstref(:, :) = RESHAPE((/(zshift + REAL(ji, wp), ji = 1, jpi_crs * jpj_crs)/), (/jpi_crs, jpj_crs/))
puniq(:, :) = ztstref(:, :)
!$ACC END KERNELS
CALL crs_lbc_lnk(puniq, cdgrd, 1.)
!$ACC KERNELS
lldbl(:, :, 1) = puniq(:, :) == ztstref(:, :)
puniq(:, :) = 1.
puniq(nldi_crs : nlei_crs, nldj_crs : nlej_crs) = REAL(COUNT(lldbl(nldi_crs : nlei_crs, nldj_crs : nlej_crs, :), dim = 3), wp)
!$ACC END KERNELS
END SUBROUTINE dom_uniq_crs
END MODULE crsdomwri