1 |
C Atmospheric land mask appears to be shifted westward by 1 degree. |
2 |
C As a quick fix, rather than fix the atmospheric landmask, shift |
3 |
C the oceanic grid definition one degree westward. |
4 |
#define SHIFT_MASK |
5 |
|
6 |
C************************************************************************ |
7 |
C************************************************************************ |
8 |
|
9 |
#include "CPP_OPTIONS.h" |
10 |
|
11 |
CBOP |
12 |
C !ROUTINE: DO_COUPLED_UCLA |
13 |
C !INTERFACE: |
14 |
SUBROUTINE DO_COUPLED_UCLA( myTime, myIter, myThid ) |
15 |
|
16 |
C !DESCRIPTION: \bv |
17 |
C *================================================================== |
18 |
C | SUBROUTINE do_coupled_ucla |
19 |
C | o Couple MIT ocean model with UCLA atmosphere model |
20 |
C | - Initialize UCLA AGCM-OGCM interface |
21 |
C | - Transfer SST to UCLA atmosphere model |
22 |
C | - Get surface forcing fields from the UCLA atmosphere model |
23 |
C *================================================================== |
24 |
C | When myTime = startTime + ... |
25 |
C | 0.0 * coupling_dt: send ocean grid information to coupler |
26 |
C | get coupling interval from coupler |
27 |
C | send SST to coupler |
28 |
C | get surface fluxes from coupler |
29 |
C | 0.5 * coupling_dt: send SST to coupler |
30 |
C | 1.0 * coupling_dt: get surface fluxes from coupler |
31 |
C | 1.5 * coupling_dt: send SST to coupler |
32 |
C | 2.0 * coupling_dt: get surface fluxes from coupler |
33 |
C | ... |
34 |
C *================================================================== |
35 |
C \ev |
36 |
|
37 |
C !USES: |
38 |
IMPLICIT NONE |
39 |
C == Global variables == |
40 |
#include "SIZE.h" |
41 |
#include "EEPARAMS.h" |
42 |
#include "EESUPPORT.h" |
43 |
#include "PARAMS.h" |
44 |
#include "DYNVARS.h" |
45 |
#include "FFIELDS.h" |
46 |
#include "GRID.h" |
47 |
LOGICAL DIFFERENT_MULTIPLE |
48 |
EXTERNAL DIFFERENT_MULTIPLE |
49 |
|
50 |
C !LOCAL VARIABLES: |
51 |
C == Routine arguments == |
52 |
C note: under the multi-threaded model myiter and |
53 |
C mytime are local variables passed around as routine |
54 |
C arguments. Although this is fiddly it saves the need to |
55 |
C impose additional synchronisation points when they are |
56 |
C updated. |
57 |
C mytime - time counter for this thread (seconds) |
58 |
C myiter - iteration counter for this thread |
59 |
C mythid - thread number for this instance of the routine. |
60 |
_RL mytime |
61 |
INTEGER myiter, mythid |
62 |
CEOP |
63 |
#ifdef COUPLED_UCLA |
64 |
|
65 |
C coupling_dt - coupling interval (seconds) |
66 |
COMMON /COUPLING_DT/ coupling_dt |
67 |
Real*8 coupling_dt |
68 |
|
69 |
C Sea-ice and land mask (0 = land; 1 = sea ice; 2 = ocean) |
70 |
COMMON /ICEMASK/ icemask |
71 |
_RL icemask(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
72 |
|
73 |
C i,j,bi,bj - loop counters |
74 |
C terminate - when .TRUE. indicates that last SST request |
75 |
C from coupler is coming up |
76 |
C global, local - working variable and arrays |
77 |
INTEGER i,j,bi,bj,msgid |
78 |
COMMON /COUPLED_TERMINATE/ terminate, terminate_pending |
79 |
LOGICAL terminate, terminate_pending |
80 |
Real*8 global(Nx,Ny) |
81 |
_RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
82 |
|
83 |
C----------------------------------------------------------------------- |
84 |
C Initialize UCLA AGCM-OGCM interface |
85 |
C - Transfer T, U, and V longitude and latitude points: |
86 |
C T (longitude, latitude) is (xC, yC) |
87 |
C U (longitude, latitude) is (xG, yC) |
88 |
C V (longitude, latitude) is (xC, yG) |
89 |
C Note that units are in degrees for spherical-polar grid |
90 |
C and in m for Cartesian grids (see GRID.h for details) |
91 |
C - Get coupling interval (seconds) |
92 |
C----------------------------------------------------------------------- |
93 |
|
94 |
IF( myTime .EQ. startTime ) THEN |
95 |
terminate_pending = .FALSE. |
96 |
terminate = .FALSE. |
97 |
|
98 |
C-- Initialize UCLA coupler |
99 |
CALL INIT_UCLA_COUPLER (myThid) |
100 |
|
101 |
C-- Send grid information to coupler. |
102 |
CALL GATHER_2D( global, xC, mythid ) |
103 |
CALL SEND_T_LONGITUDE( global, mythid ) |
104 |
|
105 |
CALL GATHER_2D( global, yC, mythid ) |
106 |
CALL SEND_T_LATITUDE( global, mythid ) |
107 |
|
108 |
CALL GATHER_2D( global, xG, mythid ) |
109 |
CALL SEND_U_LONGITUDE( global, mythid ) |
110 |
|
111 |
CALL GATHER_2D( global, yG, mythid ) |
112 |
CALL SEND_V_LATITUDE( global, mythid ) |
113 |
|
114 |
C-- Initialize interpolation routines |
115 |
CALL INIT_INTERPOLATION( myThid ) |
116 |
|
117 |
C-- Get coupling interval in s from coupler. |
118 |
CALL GET_COUPLING_DT( coupling_dt, myTime, mythid ) |
119 |
CALL BROADCAST_R8( coupling_dt, mythid ) |
120 |
|
121 |
#ifdef COUPLED_DEBUG |
122 |
print*,'COUPLED_UCLA coupling_dt:', coupling_dt |
123 |
#endif COUPLED_DEBUG |
124 |
|
125 |
ENDIF |
126 |
|
127 |
C----------------------------------------------------------------------- |
128 |
C |
129 |
C Transfer SST to UCLA atmosphere model |
130 |
C Variable to transfer is theta(:,:,1,:,:) |
131 |
C (see DYNVARS.h for details) |
132 |
C |
133 |
C----------------------------------------------------------------------- |
134 |
IF( myTime .EQ. startTime .OR. |
135 |
& DIFFERENT_MULTIPLE( coupling_dt, |
136 |
& myTime-startTime+0.5*coupling_dt, |
137 |
& myTime-startTime+0.5*coupling_dt-deltaTClock )) THEN |
138 |
#ifdef COUPLED_DEBUG |
139 |
print*,'COUPLED_UCLA xfer SST myTime:', myTime |
140 |
#endif COUPLED_DEBUG |
141 |
DO bj = myByLo(myThid), myByHi(myThid) |
142 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
143 |
DO J=1-Oly,sNy+Oly |
144 |
DO I=1-Olx,sNx+Olx |
145 |
C-- Transfer SST to array local. |
146 |
C-- Mask to -1000 land points. |
147 |
local(I,J,bi,bj) = |
148 |
& ( theta(I,J,1,bi,bj) + 1000.0 _d 0 ) * |
149 |
& maskC(I,J,1,bi,bj) - 1000.0 _d 0 |
150 |
ENDDO |
151 |
ENDDO |
152 |
ENDDO |
153 |
ENDDO |
154 |
CALL GATHER_2D( global, local, myThid ) |
155 |
CALL SEND_SST( global, myThid ) |
156 |
CALL UCLA_O2GEIU (myTime, myThid) |
157 |
terminate = terminate_pending |
158 |
IF( terminate ) RETURN |
159 |
ENDIF |
160 |
|
161 |
C----------------------------------------------------------------------- |
162 |
C |
163 |
C Get surface forcing fields from the UCLA atmosphere model |
164 |
C Variables to transfer are listed below (see FFIELDS.h for details) |
165 |
C - fu, zonal surface wind stress, N/m^2 (>0 from East to West) |
166 |
C - fv, meridional surface wind stress, N/m^2 (>0 from North to South) |
167 |
C - EmPmR, Evaporation - Precipitation - Runoff, m/s (>0 for ocean salting) |
168 |
C - Qnet, Surface heat flux, W/m^2=kg/s^3 (>0 for ocean cooling) |
169 |
C - Qsw, Short-wave surface heat flux, W/m^2=kg/s^3 (>0 for ocean cooling) |
170 |
C |
171 |
C----------------------------------------------------------------------- |
172 |
IF( myTime .EQ. startTime .OR. |
173 |
& DIFFERENT_MULTIPLE( coupling_dt, |
174 |
& myTime-startTime, myTime-startTime-deltaTClock )) THEN |
175 |
CALL UCLA_G2OEIU (terminate_pending, myTime, mythid) |
176 |
#ifdef COUPLED_DEBUG |
177 |
print*,'COUPLED_UCLA xfer FLUXES myTime:', myTime |
178 |
#else COUPLED_DEBUG |
179 |
CALL GET_ICEMASK( global, mythid ) |
180 |
CALL SCATTER_2D( global, ICEMASK, myThid ) |
181 |
CALL GET_FU( global, mythid ) |
182 |
CALL SCATTER_2D( global, fu, myThid ) |
183 |
CALL GET_FV( global, mythid ) |
184 |
CALL SCATTER_2D( global, fv, myThid ) |
185 |
CALL GET_EMPMR( global, mythid ) |
186 |
CALL SCATTER_2D( global, EmPmR, myThid ) |
187 |
CALL GET_QNET( global, mythid ) |
188 |
CALL SCATTER_2D( global, Qnet, myThid ) |
189 |
CALL GET_QSW( global, mythid ) |
190 |
CALL SCATTER_2D( global, Qsw, myThid ) |
191 |
#endif COUPLED_DEBUG |
192 |
C Set all fluxes that correspond to atmosphere |
193 |
C model land or sea-ice mask to zero. |
194 |
cdm DO bj = myByLo(myThid), myByHi(myThid) |
195 |
cdm DO bi = myBxLo(myThid), myBxHi(myThid) |
196 |
cdm DO j=1,sNy |
197 |
cdm DO i=1,sNx |
198 |
cdm IF( icemask(i,j,bi,bj) .LT. 1.5 ) THEN |
199 |
cdm fu (i,j,bi,bj) = 0.0 |
200 |
cdm fv (i,j,bi,bj) = 0.0 |
201 |
cdm EmPmR(i,j,bi,bj) = 0.0 |
202 |
cdm Qnet (i,j,bi,bj) = 0.0 |
203 |
cdm Qsw (i,j,bi,bj) = 0.0 |
204 |
cdm ENDIF |
205 |
cdm ENDDO |
206 |
cdm ENDDO |
207 |
cdm ENDDO |
208 |
cdm ENDDO |
209 |
#ifndef SHORTWAVE_HEATING |
210 |
DO bj = myByLo(myThid), myByHi(myThid) |
211 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
212 |
DO J=1,sNy |
213 |
DO I=1,sNx |
214 |
Qnet(I,J,bi,bj) = Qnet(I,J,bi,bj) + Qsw(I,J,bi,bj) |
215 |
ENDDO |
216 |
ENDDO |
217 |
ENDDO |
218 |
ENDDO |
219 |
#endif SHORTWAVE_HEATING |
220 |
_EXCH_XY_R4( ICEMASK, myThid ) |
221 |
_EXCH_XY_R4( fu , myThid ) |
222 |
_EXCH_XY_R4( fv , myThid ) |
223 |
_EXCH_XY_R4( EmPmR , myThid ) |
224 |
_EXCH_XY_R4( Qnet , myThid ) |
225 |
_EXCH_XY_R4( Qsw , myThid ) |
226 |
ENDIF |
227 |
|
228 |
#endif COUPLED_UCLA |
229 |
RETURN |
230 |
END |
231 |
|
232 |
|
233 |
C************************************************************************ |
234 |
C************************************************************************ |
235 |
|
236 |
SUBROUTINE GATHER_2D( global, local, myThid ) |
237 |
C Gather elements of a 2-D array from all processes to process 0. |
238 |
IMPLICIT NONE |
239 |
#include "SIZE.h" |
240 |
#include "EEPARAMS.h" |
241 |
#include "EESUPPORT.h" |
242 |
C mythid - thread number for this instance of the routine. |
243 |
C global,local - working arrays used to transfer 2-D fields |
244 |
INTEGER mythid |
245 |
Real*8 global(Nx,Ny) |
246 |
_RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
247 |
|
248 |
#ifdef COUPLED_UCLA |
249 |
COMMON /GlobalLo/ mpi_myXGlobalLo, mpi_myYGlobalLo |
250 |
INTEGER mpi_myXGlobalLo(nPx*nPy) |
251 |
INTEGER mpi_myYGlobalLo(nPx*nPy) |
252 |
|
253 |
_RL temp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
254 |
INTEGER istatus(MPI_STATUS_SIZE), ierr |
255 |
INTEGER idest, itag, npe, ready_to_receive |
256 |
INTEGER iP, jP, iG,jG, i, j, bi, bj, lbuff |
257 |
|
258 |
C-- Make everyone wait except for master thread. |
259 |
_BARRIER |
260 |
_BEGIN_MASTER( myThid ) |
261 |
lbuff = (sNx+2*OLx)*nSx*(sNy+2*OLy)*nSy |
262 |
idest = 0 |
263 |
itag = 0 |
264 |
ready_to_receive = 0 |
265 |
|
266 |
IF( mpiMyId .EQ. 0 ) THEN |
267 |
|
268 |
C-- Process 0 fills-in its local data |
269 |
npe = 0 |
270 |
DO bj=1,nSy |
271 |
DO bi=1,nSx |
272 |
DO j=1,sNy |
273 |
DO i=1,sNx |
274 |
iP = (bi-1)*sNx+i |
275 |
jP = (bj-1)*sNy+j |
276 |
iG = mpi_myXGlobalLo(npe+1)-1+(bi-1)*sNx+i |
277 |
jG = mpi_myYGlobalLo(npe+1)-1+(bj-1)*sNy+j |
278 |
global(iG,jG) = local(i,j,bi,bj) |
279 |
ENDDO |
280 |
ENDDO |
281 |
ENDDO |
282 |
ENDDO |
283 |
|
284 |
C-- Process 0 polls and receives data from each process in turn |
285 |
DO npe = 1, numberOfProcs-1 |
286 |
CALL MPI_SEND (ready_to_receive, 1, MPI_INTEGER, |
287 |
& npe, itag, MPI_COMM_MODEL, ierr) |
288 |
CALL MPI_RECV (temp, lbuff, MPI_DOUBLE_PRECISION, |
289 |
& npe, itag, MPI_COMM_MODEL, istatus, ierr) |
290 |
|
291 |
C-- Process 0 gathers the local arrays into a global array. |
292 |
DO bj=1,nSy |
293 |
DO bi=1,nSx |
294 |
DO j=1,sNy |
295 |
DO i=1,sNx |
296 |
iP = (bi-1)*sNx+i |
297 |
jP = (bj-1)*sNy+j |
298 |
iG = mpi_myXGlobalLo(npe+1)-1+(bi-1)*sNx+i |
299 |
jG = mpi_myYGlobalLo(npe+1)-1+(bj-1)*sNy+j |
300 |
global(iG,jG) = temp(i,j,bi,bj) |
301 |
ENDDO |
302 |
ENDDO |
303 |
ENDDO |
304 |
ENDDO |
305 |
ENDDO |
306 |
|
307 |
ELSE |
308 |
|
309 |
C-- All proceses except 0 wait to be polled then send local array |
310 |
CALL MPI_RECV (ready_to_receive, 1, MPI_INTEGER, |
311 |
& idest, itag, MPI_COMM_MODEL, istatus, ierr) |
312 |
CALL MPI_SEND (local, lbuff, MPI_DOUBLE_PRECISION, |
313 |
& idest, itag, MPI_COMM_MODEL, ierr) |
314 |
|
315 |
ENDIF |
316 |
|
317 |
_END_MASTER( myThid ) |
318 |
_BARRIER |
319 |
|
320 |
#endif COUPLED_UCLA |
321 |
RETURN |
322 |
END |
323 |
|
324 |
|
325 |
C************************************************************************ |
326 |
C************************************************************************ |
327 |
|
328 |
SUBROUTINE SCATTER_2D( global, local, myThid ) |
329 |
C Scatter elements of a 2-D array from process 0 to all processes. |
330 |
IMPLICIT NONE |
331 |
#include "SIZE.h" |
332 |
#include "EEPARAMS.h" |
333 |
#include "EESUPPORT.h" |
334 |
C mythid - thread number for this instance of the routine. |
335 |
C global,local - working arrays used to transfer 2-D fields |
336 |
INTEGER mythid |
337 |
Real*8 global(Nx,Ny) |
338 |
_RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
339 |
|
340 |
#ifdef COUPLED_UCLA |
341 |
COMMON /GlobalLo/ mpi_myXGlobalLo, mpi_myYGlobalLo |
342 |
INTEGER mpi_myXGlobalLo(nPx*nPy) |
343 |
INTEGER mpi_myYGlobalLo(nPx*nPy) |
344 |
|
345 |
_RL temp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
346 |
INTEGER istatus(MPI_STATUS_SIZE), ierr |
347 |
INTEGER isource, itag, npe |
348 |
INTEGER iP, jP, iG,jG, i, j, bi, bj, lbuff |
349 |
|
350 |
C-- Make everyone wait except for master thread. |
351 |
_BARRIER |
352 |
_BEGIN_MASTER( myThid ) |
353 |
lbuff=(sNx+2*OLx)*nSx*(sNy+2*OLy)*nSy |
354 |
isource = 0 |
355 |
itag = 0 |
356 |
|
357 |
IF( mpiMyId .EQ. 0 ) THEN |
358 |
|
359 |
C-- Process 0 fills-in its local data |
360 |
npe = 0 |
361 |
DO bj=1,nSy |
362 |
DO bi=1,nSx |
363 |
DO j=1,sNy |
364 |
DO i=1,sNx |
365 |
iP = (bi-1)*sNx+i |
366 |
jP = (bj-1)*sNy+j |
367 |
iG = mpi_myXGlobalLo(npe+1)-1+(bi-1)*sNx+i |
368 |
jG = mpi_myYGlobalLo(npe+1)-1+(bj-1)*sNy+j |
369 |
local(i,j,bi,bj) = global(iG,jG) |
370 |
ENDDO |
371 |
ENDDO |
372 |
ENDDO |
373 |
ENDDO |
374 |
|
375 |
C-- Process 0 sends local arrays to all other processes |
376 |
DO npe = 1, numberOfProcs-1 |
377 |
DO bj=1,nSy |
378 |
DO bi=1,nSx |
379 |
DO j=1,sNy |
380 |
DO i=1,sNx |
381 |
iP = (bi-1)*sNx+i |
382 |
jP = (bj-1)*sNy+j |
383 |
iG = mpi_myXGlobalLo(npe+1)-1+(bi-1)*sNx+i |
384 |
jG = mpi_myYGlobalLo(npe+1)-1+(bj-1)*sNy+j |
385 |
temp(i,j,bi,bj) = global(iG,jG) |
386 |
ENDDO |
387 |
ENDDO |
388 |
ENDDO |
389 |
ENDDO |
390 |
CALL MPI_SEND (temp, lbuff, MPI_DOUBLE_PRECISION, |
391 |
& npe, itag, MPI_COMM_MODEL, ierr) |
392 |
ENDDO |
393 |
|
394 |
ELSE |
395 |
|
396 |
C-- All proceses except 0 receive local array from process 0 |
397 |
CALL MPI_RECV (local, lbuff, MPI_DOUBLE_PRECISION, |
398 |
& isource, itag, MPI_COMM_MODEL, istatus, ierr) |
399 |
|
400 |
ENDIF |
401 |
|
402 |
_END_MASTER( myThid ) |
403 |
_BARRIER |
404 |
|
405 |
C-- Fill in edges. |
406 |
_EXCH_XY_R8( local, myThid ) |
407 |
|
408 |
#endif COUPLED_UCLA |
409 |
RETURN |
410 |
END |
411 |
|
412 |
|
413 |
C************************************************************************ |
414 |
C************************************************************************ |
415 |
|
416 |
SUBROUTINE BROADCAST_R8( work, myThid ) |
417 |
C Broadcast RL scalar from process 0 to all processes. |
418 |
IMPLICIT NONE |
419 |
#include "SIZE.h" |
420 |
#include "EEPARAMS.h" |
421 |
#include "EESUPPORT.h" |
422 |
C mythid - thread number for this instance of the routine. |
423 |
C global,local - working variables |
424 |
INTEGER mythid |
425 |
Real*8 work |
426 |
#ifdef COUPLED_UCLA |
427 |
INTEGER istatus(MPI_STATUS_SIZE), ierr, msgid, npe |
428 |
|
429 |
C-- Make everyone wait except for master thread in master process. |
430 |
_BARRIER |
431 |
_BEGIN_MASTER( myThid ) |
432 |
|
433 |
C-- Process 0 sends variable to all other OGCM processes |
434 |
msgid = 0 |
435 |
IF( mpiMyId .EQ. 0 ) THEN |
436 |
DO npe = 1, numberOfProcs-1 |
437 |
CALL MPI_SEND (work, 1, MPI_DOUBLE_PRECISION, |
438 |
& npe, msgid, MPI_COMM_MODEL, ierr) |
439 |
ENDDO |
440 |
|
441 |
C-- All OGCM processes (except 0) receive variable from process 0 |
442 |
ELSE |
443 |
CALL MPI_RECV (work, 1, MPI_DOUBLE_PRECISION, |
444 |
& 0, msgid, MPI_COMM_MODEL, istatus, ierr) |
445 |
ENDIF |
446 |
|
447 |
_END_MASTER( myThid ) |
448 |
_BARRIER |
449 |
|
450 |
#endif COUPLED_UCLA |
451 |
RETURN |
452 |
END |
453 |
|
454 |
|
455 |
C************************************************************************ |
456 |
C************************************************************************ |
457 |
|
458 |
SUBROUTINE INIT_UCLA_COUPLER (myThid) |
459 |
C Initialize UCLA coupler |
460 |
IMPLICIT NONE |
461 |
|
462 |
#include "SIZE.h" |
463 |
#include "EEPARAMS.h" |
464 |
#include "EESUPPORT.h" |
465 |
|
466 |
INTEGER myThid |
467 |
#ifdef COUPLED_UCLA |
468 |
C-- Make everyone wait except for master thread in master process. |
469 |
_BARRIER |
470 |
_BEGIN_MASTER( myThid ) |
471 |
IF (mpiMyId .EQ. 0) THEN |
472 |
|
473 |
#ifndef COUPLED_DEBUG |
474 |
CALL COUPLE (.TRUE., Nx, Ny) |
475 |
#endif COUPLED_DEBUG |
476 |
|
477 |
ENDIF |
478 |
_END_MASTER( myThid ) |
479 |
_BARRIER |
480 |
#endif COUPLED_UCLA |
481 |
RETURN |
482 |
END |
483 |
|
484 |
|
485 |
C************************************************************************ |
486 |
C************************************************************************ |
487 |
|
488 |
SUBROUTINE SEND_T_LONGITUDE (global, myThid) |
489 |
C Send temperature longitude scale to coupler. |
490 |
IMPLICIT NONE |
491 |
|
492 |
#include "SIZE.h" |
493 |
#include "EEPARAMS.h" |
494 |
#include "EESUPPORT.h" |
495 |
|
496 |
C mythid - thread number for this instance of the routine. |
497 |
C global - working array used to transfer 2-D fields |
498 |
INTEGER mythid |
499 |
Real*8 global(Nx,Ny) |
500 |
|
501 |
#ifdef COUPLED_UCLA |
502 |
INTEGER i, j |
503 |
Real*8 tmp(Nx) |
504 |
|
505 |
C-- Make everyone wait except for master thread in master process. |
506 |
_BARRIER |
507 |
_BEGIN_MASTER( myThid ) |
508 |
IF (mpiMyId .EQ. 0) THEN |
509 |
|
510 |
do j=2,Ny |
511 |
do i=1,Nx |
512 |
if (global(i,1) .ne. global(i,j)) call abort () |
513 |
enddo |
514 |
enddo |
515 |
do i=1,Nx |
516 |
tmp(i) = global(i,1) |
517 |
#ifdef SHIFT_MASK |
518 |
& - 1.0 |
519 |
#endif |
520 |
enddo |
521 |
|
522 |
#ifndef COUPLED_DEBUG |
523 |
call set_t_longitude (tmp) |
524 |
#endif |
525 |
|
526 |
ENDIF |
527 |
_END_MASTER( myThid ) |
528 |
_BARRIER |
529 |
#endif /* COUPLED_UCLA */ |
530 |
RETURN |
531 |
END |
532 |
|
533 |
|
534 |
C************************************************************************ |
535 |
C************************************************************************ |
536 |
|
537 |
SUBROUTINE SEND_T_LATITUDE (global, myThid) |
538 |
C Send temperature latitude scale to coupler. |
539 |
IMPLICIT NONE |
540 |
|
541 |
#include "SIZE.h" |
542 |
#include "EEPARAMS.h" |
543 |
#include "EESUPPORT.h" |
544 |
|
545 |
C mythid - thread number for this instance of the routine. |
546 |
C global - working array used to transfer 2-D fields |
547 |
INTEGER mythid |
548 |
Real*8 global(Nx,Ny) |
549 |
|
550 |
#ifdef COUPLED_UCLA |
551 |
INTEGER i, j |
552 |
Real*8 tmp(Ny) |
553 |
|
554 |
C-- Make everyone wait except for master thread in master process. |
555 |
_BARRIER |
556 |
_BEGIN_MASTER( myThid ) |
557 |
IF( mpiMyId .EQ. 0 ) THEN |
558 |
|
559 |
do j=1,Ny |
560 |
do i=2,Nx |
561 |
if (global(1,j) .ne. global(i,j)) call abort () |
562 |
enddo |
563 |
enddo |
564 |
do j=1,Ny |
565 |
tmp(j) = global(1,j) |
566 |
enddo |
567 |
|
568 |
#ifndef COUPLED_DEBUG |
569 |
call set_t_latitude (tmp) |
570 |
#endif COUPLED_DEBUG |
571 |
|
572 |
ENDIF |
573 |
_END_MASTER( myThid ) |
574 |
_BARRIER |
575 |
#endif COUPLED_UCLA |
576 |
END |
577 |
|
578 |
|
579 |
C************************************************************************ |
580 |
C************************************************************************ |
581 |
|
582 |
SUBROUTINE SEND_U_LONGITUDE (global, myThid) |
583 |
C Send U longitude scale to coupler. |
584 |
IMPLICIT NONE |
585 |
|
586 |
#include "SIZE.h" |
587 |
#include "EEPARAMS.h" |
588 |
#include "EESUPPORT.h" |
589 |
|
590 |
C mythid - thread number for this instance of the routine. |
591 |
C global - working array used to transfer 2-D fields |
592 |
INTEGER mythid |
593 |
Real*8 global(Nx,Ny) |
594 |
|
595 |
#ifdef COUPLED_UCLA |
596 |
INTEGER i, j |
597 |
Real*8 tmp(Nx) |
598 |
|
599 |
C-- Make everyone wait except for master thread in master process. |
600 |
_BARRIER |
601 |
_BEGIN_MASTER( myThid ) |
602 |
IF (mpiMyId .EQ. 0) THEN |
603 |
|
604 |
do j=2,Ny |
605 |
do i=1,Nx |
606 |
if (global(i,1) .ne. global(i,j)) call abort () |
607 |
enddo |
608 |
enddo |
609 |
do i=1,Nx |
610 |
tmp(i) = global(i,1) |
611 |
#ifdef SHIFT_MASK |
612 |
& - 1.0 |
613 |
#endif |
614 |
enddo |
615 |
|
616 |
#ifndef COUPLED_DEBUG |
617 |
call set_u_longitude (tmp) |
618 |
#endif COUPLED_DEBUG |
619 |
|
620 |
ENDIF |
621 |
_END_MASTER( myThid ) |
622 |
_BARRIER |
623 |
#endif COUPLED_UCLA |
624 |
RETURN |
625 |
END |
626 |
|
627 |
|
628 |
C************************************************************************ |
629 |
C************************************************************************ |
630 |
|
631 |
SUBROUTINE SEND_V_LATITUDE (global, myThid) |
632 |
C Send V latitude scale to coupler. |
633 |
IMPLICIT NONE |
634 |
|
635 |
#include "SIZE.h" |
636 |
#include "EEPARAMS.h" |
637 |
#include "EESUPPORT.h" |
638 |
|
639 |
C global - working array used to transfer 2-D fields |
640 |
C mythid - thread number for this instance of the routine. |
641 |
INTEGER mythid |
642 |
Real*8 global(Nx,Ny) |
643 |
|
644 |
#ifdef COUPLED_UCLA |
645 |
INTEGER i, j |
646 |
Real*8 tmp(Ny) |
647 |
|
648 |
C-- Make everyone wait except for master thread in master process. |
649 |
_BARRIER |
650 |
_BEGIN_MASTER( myThid ) |
651 |
IF( mpiMyId .EQ. 0 ) THEN |
652 |
|
653 |
do j=1,Ny |
654 |
do i=2,Nx |
655 |
if (global(1,j) .ne. global(i,j)) call abort () |
656 |
enddo |
657 |
enddo |
658 |
do j=1,Ny |
659 |
tmp(j) = global(1,j) |
660 |
enddo |
661 |
|
662 |
#ifndef COUPLED_DEBUG |
663 |
call set_v_latitude (tmp) |
664 |
#endif COUPLED_DEBUG |
665 |
|
666 |
ENDIF |
667 |
_END_MASTER( myThid ) |
668 |
_BARRIER |
669 |
#endif COUPLED_UCLA |
670 |
END |
671 |
|
672 |
|
673 |
C************************************************************************ |
674 |
C************************************************************************ |
675 |
|
676 |
SUBROUTINE SEND_SST ( global, myThid ) |
677 |
C Send SST array to coupler. |
678 |
IMPLICIT NONE |
679 |
|
680 |
#include "SIZE.h" |
681 |
#include "EEPARAMS.h" |
682 |
#include "EESUPPORT.h" |
683 |
|
684 |
C global - working array used to transfer 2-D fields |
685 |
C mythid - thread number for this instance of the routine. |
686 |
INTEGER mythid |
687 |
Real*8 global(Nx,Ny) |
688 |
#ifdef COUPLED_UCLA |
689 |
C-- Make everyone wait except for master thread in master process. |
690 |
_BARRIER |
691 |
_BEGIN_MASTER( myThid ) |
692 |
IF (mpiMyId .EQ. 0) THEN |
693 |
|
694 |
#ifndef COUPLED_DEBUG |
695 |
CALL SSTINS (GLOBAL) |
696 |
#endif COUPLED_DEBUG |
697 |
|
698 |
ENDIF |
699 |
_END_MASTER( myThid ) |
700 |
_BARRIER |
701 |
#endif COUPLED_UCLA |
702 |
RETURN |
703 |
END |
704 |
|
705 |
|
706 |
C************************************************************************ |
707 |
C************************************************************************ |
708 |
|
709 |
SUBROUTINE INIT_INTERPOLATION (myThid) |
710 |
C Initialize UCLA coupler interpolation routines |
711 |
IMPLICIT NONE |
712 |
|
713 |
#include "SIZE.h" |
714 |
#include "EEPARAMS.h" |
715 |
#include "EESUPPORT.h" |
716 |
|
717 |
INTEGER myThid |
718 |
#ifdef COUPLED_UCLA |
719 |
C-- Make everyone wait except for master thread in master process. |
720 |
_BARRIER |
721 |
_BEGIN_MASTER( myThid ) |
722 |
IF (mpiMyId .EQ. 0) THEN |
723 |
|
724 |
#ifndef COUPLED_DEBUG |
725 |
CALL SETSCL |
726 |
#endif COUPLED_DEBUG |
727 |
|
728 |
ENDIF |
729 |
_END_MASTER( myThid ) |
730 |
_BARRIER |
731 |
#endif COUPLED_UCLA |
732 |
RETURN |
733 |
END |
734 |
|
735 |
|
736 |
C************************************************************************ |
737 |
C************************************************************************ |
738 |
|
739 |
SUBROUTINE GET_COUPLING_DT (coupling_dt, myTime, myThid) |
740 |
C Get coupling period in s |
741 |
IMPLICIT NONE |
742 |
|
743 |
#include "SIZE.h" |
744 |
#include "EEPARAMS.h" |
745 |
#include "EESUPPORT.h" |
746 |
|
747 |
Real*8 coupling_dt |
748 |
_RL myTime |
749 |
INTEGER mythid |
750 |
|
751 |
#ifdef COUPLED_UCLA |
752 |
C tbegin - initial AGCM reference time (hours) |
753 |
C time_norm - OGCM startTime offset relative to tbegin (hours) |
754 |
INTEGER year, imonth, dayomonth |
755 |
Real*8 gmt, tbegin, time0, time_norm |
756 |
common/time_var/ year, imonth, dayomonth, |
757 |
* gmt, tbegin, time0, time_norm |
758 |
|
759 |
C-- Make everyone wait except for master thread in master process. |
760 |
_BARRIER |
761 |
_BEGIN_MASTER( myThid ) |
762 |
IF (mpiMyId .EQ. 0) THEN |
763 |
|
764 |
#ifndef COUPLED_DEBUG |
765 |
call initoc_net |
766 |
* (year, imonth, dayomonth, gmt, |
767 |
* coupling_dt, tbegin, time0) |
768 |
time_norm = tbegin - myTime/3600.0 |
769 |
coupling_dt = coupling_dt * 3600.0 |
770 |
#else |
771 |
coupling_dt = 14400 |
772 |
#endif COUPLED_DEBUG |
773 |
|
774 |
ENDIF |
775 |
_END_MASTER( myThid ) |
776 |
_BARRIER |
777 |
#endif COUPLED_UCLA |
778 |
END |
779 |
|
780 |
|
781 |
C************************************************************************ |
782 |
C************************************************************************ |
783 |
|
784 |
SUBROUTINE GET_ICEMASK( global, myThid ) |
785 |
C Get atmospheric sea-ice mask (0 = land; 1 = sea ice; 2 = ocean). |
786 |
IMPLICIT NONE |
787 |
#include "SIZE.h" |
788 |
#include "EEPARAMS.h" |
789 |
#include "EESUPPORT.h" |
790 |
C global - working array used to transfer 2-D fields |
791 |
C mythid - thread number for this instance of the routine. |
792 |
Integer iglobal(Nx,Ny) |
793 |
Real*8 global (Nx,Ny) |
794 |
INTEGER mythid |
795 |
#ifdef COUPLED_UCLA |
796 |
INTEGER i, j |
797 |
|
798 |
C-- Make everyone wait except for master thread in master process. |
799 |
_BARRIER |
800 |
_BEGIN_MASTER( myThid ) |
801 |
IF( mpiMyId .EQ. 0 ) THEN |
802 |
|
803 |
#ifndef COUPLED_DEBUG |
804 |
CALL imkext (iglobal) |
805 |
#endif COUPLED_DEBUG |
806 |
|
807 |
C-- Convert to Real*8 |
808 |
DO j=1,Ny |
809 |
DO i=1,Nx |
810 |
global(i,j)=iglobal(i,j) |
811 |
ENDDO |
812 |
ENDDO |
813 |
|
814 |
ENDIF |
815 |
_END_MASTER( myThid ) |
816 |
_BARRIER |
817 |
#endif COUPLED_UCLA |
818 |
RETURN |
819 |
END |
820 |
|
821 |
|
822 |
C************************************************************************ |
823 |
C************************************************************************ |
824 |
|
825 |
SUBROUTINE GET_FU( global, myThid ) |
826 |
C Get zonal surface wind stress, N/m^2 (>0 from East to West) |
827 |
IMPLICIT NONE |
828 |
#include "SIZE.h" |
829 |
#include "EEPARAMS.h" |
830 |
#include "EESUPPORT.h" |
831 |
C global - working array used to transfer 2-D fields |
832 |
C mythid - thread number for this instance of the routine. |
833 |
Real*8 global(Nx,Ny) |
834 |
INTEGER mythid |
835 |
#ifdef COUPLED_UCLA |
836 |
INTEGER i, j |
837 |
|
838 |
C-- Make everyone wait except for master thread in master process. |
839 |
_BARRIER |
840 |
_BEGIN_MASTER( myThid ) |
841 |
IF( mpiMyId .EQ. 0 ) THEN |
842 |
|
843 |
#ifndef COUPLED_DEBUG |
844 |
CALL wsxext (global) |
845 |
#endif COUPLED_DEBUG |
846 |
|
847 |
C-- Convert from dynes/cm^2 to N/m^2 |
848 |
DO j=1,Ny |
849 |
DO i=1,Nx |
850 |
global(i,j)=global(i,j)*0.1 |
851 |
ENDDO |
852 |
ENDDO |
853 |
|
854 |
ENDIF |
855 |
_END_MASTER( myThid ) |
856 |
_BARRIER |
857 |
#endif COUPLED_UCLA |
858 |
RETURN |
859 |
END |
860 |
|
861 |
|
862 |
C************************************************************************ |
863 |
C************************************************************************ |
864 |
|
865 |
SUBROUTINE GET_FV( global, myThid ) |
866 |
C Get meridional surface wind stress, N/m^2 (>0 from North to South) |
867 |
IMPLICIT NONE |
868 |
#include "SIZE.h" |
869 |
#include "EEPARAMS.h" |
870 |
#include "EESUPPORT.h" |
871 |
C global - working array used to transfer 2-D fields |
872 |
C mythid - thread number for this instance of the routine. |
873 |
Real*8 global(Nx,Ny) |
874 |
INTEGER mythid |
875 |
|
876 |
#ifdef COUPLED_UCLA |
877 |
INTEGER i, j |
878 |
|
879 |
C-- Make everyone wait except for master thread in master process. |
880 |
_BARRIER |
881 |
_BEGIN_MASTER( myThid ) |
882 |
IF( mpiMyId .EQ. 0 ) THEN |
883 |
|
884 |
#ifndef COUPLED_DEBUG |
885 |
CALL wsyext (global) |
886 |
#endif COUPLED_DEBUG |
887 |
|
888 |
C-- Convert from dynes/cm^2 to N/m^2 |
889 |
DO j=1,Ny |
890 |
DO i=1,Nx |
891 |
global(i,j)=global(i,j)*0.1 |
892 |
ENDDO |
893 |
ENDDO |
894 |
|
895 |
ENDIF |
896 |
_END_MASTER( myThid ) |
897 |
_BARRIER |
898 |
#endif COUPLED_UCLA |
899 |
RETURN |
900 |
END |
901 |
|
902 |
|
903 |
C************************************************************************ |
904 |
C************************************************************************ |
905 |
|
906 |
SUBROUTINE GET_EMPMR( global, myThid ) |
907 |
C Get Evaporation - Precipitation - Runoff, m/s (>0 for ocean salting) |
908 |
IMPLICIT NONE |
909 |
#include "SIZE.h" |
910 |
#include "EEPARAMS.h" |
911 |
#include "EESUPPORT.h" |
912 |
C global - working array used to transfer 2-D fields |
913 |
C mythid - thread number for this instance of the routine. |
914 |
Real*8 global(Nx,Ny) |
915 |
INTEGER mythid |
916 |
|
917 |
#ifdef COUPLED_UCLA |
918 |
INTEGER i, j |
919 |
|
920 |
C-- Make everyone wait except for master thread in master process. |
921 |
_BARRIER |
922 |
_BEGIN_MASTER( myThid ) |
923 |
IF( mpiMyId .EQ. 0 ) THEN |
924 |
|
925 |
#ifndef COUPLED_DEBUG |
926 |
CALL pmeext (global) |
927 |
#endif COUPLED_DEBUG |
928 |
|
929 |
C-- Convert from mm/s, positive for ocean freshening |
930 |
C to m/s, positive for ocean salting |
931 |
DO j=1,Ny |
932 |
DO i=1,Nx |
933 |
global(i,j)=-global(i,j)*0.001 |
934 |
ENDDO |
935 |
ENDDO |
936 |
|
937 |
ENDIF |
938 |
_END_MASTER( myThid ) |
939 |
_BARRIER |
940 |
#endif COUPLED_UCLA |
941 |
RETURN |
942 |
END |
943 |
|
944 |
|
945 |
C************************************************************************ |
946 |
C************************************************************************ |
947 |
|
948 |
SUBROUTINE GET_QNET( global, myThid ) |
949 |
C Get surface heat flux, W/m^2 |
950 |
IMPLICIT NONE |
951 |
#include "SIZE.h" |
952 |
#include "EEPARAMS.h" |
953 |
#include "EESUPPORT.h" |
954 |
C global - working array used to transfer 2-D fields |
955 |
C mythid - thread number for this instance of the routine. |
956 |
Real*8 global(Nx,Ny) |
957 |
INTEGER mythid |
958 |
|
959 |
#ifdef COUPLED_UCLA |
960 |
INTEGER i, j |
961 |
|
962 |
C-- Make everyone wait except for master thread in master process. |
963 |
_BARRIER |
964 |
_BEGIN_MASTER( myThid ) |
965 |
IF( mpiMyId .EQ. 0 ) THEN |
966 |
|
967 |
#ifndef COUPLED_DEBUG |
968 |
CALL hfxext (global) |
969 |
#endif COUPLED_DEBUG |
970 |
|
971 |
C-- Convert to positive for ocean cooling |
972 |
DO j=1,Ny |
973 |
DO i=1,Nx |
974 |
global(i,j)=-global(i,j) |
975 |
ENDDO |
976 |
ENDDO |
977 |
|
978 |
ENDIF |
979 |
_END_MASTER( myThid ) |
980 |
_BARRIER |
981 |
#endif COUPLED_UCLA |
982 |
RETURN |
983 |
END |
984 |
|
985 |
|
986 |
C************************************************************************ |
987 |
C************************************************************************ |
988 |
|
989 |
SUBROUTINE GET_QSW( global, myThid ) |
990 |
C Get short-wave surface heat flux, W/m^2=kg/s^3 (>0 for ocean cooling) |
991 |
IMPLICIT NONE |
992 |
#include "SIZE.h" |
993 |
#include "EEPARAMS.h" |
994 |
#include "EESUPPORT.h" |
995 |
C global - working array used to transfer 2-D fields |
996 |
C mythid - thread number for this instance of the routine. |
997 |
Real*8 global(Nx,Ny) |
998 |
INTEGER mythid |
999 |
|
1000 |
#ifdef COUPLED_UCLA |
1001 |
INTEGER i, j |
1002 |
|
1003 |
C-- Make everyone wait except for master thread in master process. |
1004 |
_BARRIER |
1005 |
_BEGIN_MASTER( myThid ) |
1006 |
IF( mpiMyId .EQ. 0 ) THEN |
1007 |
|
1008 |
#ifndef COUPLED_DEBUG |
1009 |
CALL swrext (global) |
1010 |
#endif COUPLED_DEBUG |
1011 |
|
1012 |
C-- Convert to positive for ocean cooling |
1013 |
DO j=1,Ny |
1014 |
DO i=1,Nx |
1015 |
global(i,j)=-global(i,j) |
1016 |
ENDDO |
1017 |
ENDDO |
1018 |
|
1019 |
ENDIF |
1020 |
_END_MASTER( myThid ) |
1021 |
_BARRIER |
1022 |
#endif COUPLED_UCLA |
1023 |
RETURN |
1024 |
END |
1025 |
|
1026 |
|
1027 |
C************************************************************************ |
1028 |
C************************************************************************ |
1029 |
|
1030 |
SUBROUTINE UCLA_G2OEIU (terminate, myTime, mythid) |
1031 |
C Initialize UCLA coupler |
1032 |
IMPLICIT NONE |
1033 |
|
1034 |
#include "SIZE.h" |
1035 |
#include "EEPARAMS.h" |
1036 |
#include "EESUPPORT.h" |
1037 |
|
1038 |
LOGICAL terminate |
1039 |
_RL myTime |
1040 |
INTEGER mythid |
1041 |
|
1042 |
#ifdef COUPLED_UCLA |
1043 |
INTEGER irc |
1044 |
Real*8 tmp_irc |
1045 |
INTEGER year, imonth, dayomonth |
1046 |
Real*8 gmt, tbegin, time0, time_norm |
1047 |
common/time_var/ year, imonth, dayomonth, |
1048 |
* gmt, tbegin, time0, time_norm |
1049 |
|
1050 |
C-- Make everyone wait except for master thread in master process. |
1051 |
_BARRIER |
1052 |
_BEGIN_MASTER( myThid ) |
1053 |
IF (mpiMyId .EQ. 0) THEN |
1054 |
irc = 1 |
1055 |
#ifdef COUPLED_DEBUG |
1056 |
IF( myTime .EQ. 36000.0 ) irc = -1 |
1057 |
#else COUPLED_DEBUG |
1058 |
CALL g2oeiu (irc, time_norm + myTime/3600.0) |
1059 |
#endif COUPLED_DEBUG |
1060 |
tmp_irc = irc |
1061 |
ENDIF |
1062 |
_END_MASTER( myThid ) |
1063 |
_BARRIER |
1064 |
CALL BROADCAST_R8( tmp_irc, mythid ) |
1065 |
terminate = tmp_irc .lt. 0 |
1066 |
|
1067 |
#endif COUPLED_UCLA |
1068 |
RETURN |
1069 |
END |
1070 |
|
1071 |
|
1072 |
C************************************************************************ |
1073 |
C************************************************************************ |
1074 |
|
1075 |
SUBROUTINE UCLA_O2GEIU (myTime, myThid) |
1076 |
C Initialize UCLA coupler |
1077 |
IMPLICIT NONE |
1078 |
|
1079 |
#include "SIZE.h" |
1080 |
#include "EEPARAMS.h" |
1081 |
#include "EESUPPORT.h" |
1082 |
|
1083 |
_RL myTime |
1084 |
INTEGER mythid |
1085 |
|
1086 |
#ifdef COUPLED_UCLA |
1087 |
INTEGER irc |
1088 |
INTEGER year, imonth, dayomonth |
1089 |
Real*8 gmt, tbegin, time0, time_norm |
1090 |
common/time_var/ year, imonth, dayomonth, |
1091 |
* gmt, tbegin, time0, time_norm |
1092 |
|
1093 |
C-- Make everyone wait except for master thread in master process. |
1094 |
_BARRIER |
1095 |
_BEGIN_MASTER( myThid ) |
1096 |
IF (mpiMyId .EQ. 0) THEN |
1097 |
irc = 0 |
1098 |
#ifndef COUPLED_DEBUG |
1099 |
CALL o2geiu (irc, time_norm + myTime/3600.0 ) |
1100 |
#endif COUPLED_DEBUG |
1101 |
ENDIF |
1102 |
_END_MASTER( myThid ) |
1103 |
_BARRIER |
1104 |
|
1105 |
#endif COUPLED_UCLA |
1106 |
RETURN |
1107 |
END |