*IF DEF,CONTROL,AND,DEF,ATMOS,AND,DEF,OCEAN,AND,-DEF,MPP GRR0F402.54
C ******************************COPYRIGHT****************************** GTS2F400.9919
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.9920
C GTS2F400.9921
C Use, duplication or disclosure of this code is subject to the GTS2F400.9922
C restrictions as set forth in the contract. GTS2F400.9923
C GTS2F400.9924
C Meteorological Office GTS2F400.9925
C London Road GTS2F400.9926
C BRACKNELL GTS2F400.9927
C Berkshire UK GTS2F400.9928
C RG12 2SZ GTS2F400.9929
C GTS2F400.9930
C If no contract has been raised with this copy of the code, the use, GTS2F400.9931
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.9932
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.9933
C Modelling at the above address. GTS2F400.9934
C ******************************COPYRIGHT****************************** GTS2F400.9935
C GTS2F400.9936
CLL Routine: SWAP_O2A ------------------------------------------------- SWAPO2A1.3
CLL SWAPO2A1.4
CLL Purpose: 2nd level control routine to control the interchange of SWAPO2A1.5
CLL data when swapping from ocean to atmosphere in a coupled SWAPO2A1.6
CLL model. Fields required from the completed ocean SWAPO2A1.7
CLL phase are copied to workspace from D1 addresses worked SWAPO2A1.8
CLL out by INIT_A2O; ocean data is written from D1 to disk; SWAPO2A1.9
CLL atmosphere data read from disk to overlay D1; and finally SWAPO2A1.10
CLL routine TRANSO2A is called to perform the data processing SWAPO2A1.11
CLL required to complete the coupling. SWAPO2A1.12
CLL SWAPO2A1.13
CLL Tested under compiler: cft77 SWAPO2A1.14
CLL Tested under OS version: UNICOS 5.1 SWAPO2A1.15
CLL SWAPO2A1.16
CLL Author: T.C.Johns SWAPO2A1.17
CLL SWAPO2A1.18
CLL Model Modification history from model version 3.0: SWAPO2A1.19
CLL version date SWAPO2A1.20
CLL 3.2 18/06/93 Changes for dynamic allocation (TCJ). @DYALLOC.3531
CLL 3.4 03/08/94 Safer treatment of RMDI in dump. (JFT) CJT0F304.6
CLL 4.2 22/11/96 Allow uncompressed ocean dumps. S Ineson GSI0F402.30
CLL 4.2 11/10/96 : Enable atmos-ocean coupling for MPP. GRR0F402.55
CLL (1): Coupled fields. Disable this deck for MPP GRR0F402.56
CLL running (a separate deck SWAPO2A2 introduced for GRR0F402.57
CLL MPP). Add global size arguments for consistency GRR0F402.58
CLL with SWAPO2A2. R. Rawlins GRR0F402.59
CLL 4.2 11/10/96 : Enable atmos-ocean coupling for MPP. GRR1F402.312
CLL (2): Swap D1 memory. New argument in TRANSIN, GRR1F402.313
CLL TRANSOUT routines. R. Rawlins GRR1F402.314
CLL 4.5 1/07/98 Include code to pass ocean CO2 flux. C.D.Jones CCN1F405.373
CLL SWAPO2A1.21
CLL Programming standard: UM Doc Paper 3, version 2 (7/9/90) SWAPO2A1.22
CLL SWAPO2A1.23
CLL Logical components covered: C12 SWAPO2A1.24
CLL SWAPO2A1.25
CLL Project task: C0 SWAPO2A1.26
CLL SWAPO2A1.27
CLL External documentation: SWAPO2A1.28
CLL Unified Model Doc Paper C2 - Atmosphere-Ocean coupling: overview CCN1F405.374
CLL SWAPO2A1.30
CLL ------------------------------------------------------------------- SWAPO2A1.31
C*L Interface and arguments: ------------------------------------------ SWAPO2A1.32
C SWAPO2A1.33
SUBROUTINE SWAP_O2A (G_P_FIELD,G_IMTJMT,CO2_DIMA,CO2_DIMO, 2,49CCN1F405.375
& CO2_DIMO2, CCN1F405.376
*CALL ARGSIZE 
@DYALLOC.3533
*CALL ARGD1 @DYALLOC.3534
*CALL ARGDUMO @DYALLOC.3535
*CALL ARGPTRA @DYALLOC.3536
*CALL ARGPTRO @DYALLOC.3537
*CALL ARGCONO CJG6F401.5
*CALL ARGAOCPL @DYALLOC.3538
* ICODE,CMESSAGE ) @DYALLOC.3539
C SWAPO2A1.35
IMPLICIT NONE SWAPO2A1.36
C SWAPO2A1.37
*CALL TYPSIZE @DYALLOC.3540
*CALL TYPD1 @DYALLOC.3541
*CALL TYPDUMO @DYALLOC.3542
*CALL TYPPTRA @DYALLOC.3543
*CALL TYPPTRO @DYALLOC.3544
*CALL TYPCONO CJG6F401.6
*CALL TYPAOCPL @DYALLOC.3545
C @DYALLOC.3546
INTEGER G_P_FIELD, ! IN Not used: required for GRR0F402.61
& G_IMTJMT ! IN consistency with MPP GRR0F402.62
& ,CO2_DIMA ! IN : dimension of atmos CO2 array CCN1F405.377
& ,CO2_DIMO ! IN : dimension of ocean CO2 array CCN1F405.378
& ,CO2_DIMO2 ! IN : dimension of ocean CO2 diagnostic CCN1F405.379
& ,CO2_ICOLS,CO2_JROWS ! OUT: CO2 array dimensions CCN1F405.380
& ,CO2_IMT, CO2_JMT CCN1F405.381
INTEGER SWAPO2A1.38
& ICODE ! OUT - Error return code SWAPO2A1.40
CHARACTER*(*) CMESSAGE ! OUT - Error return message SWAPO2A1.41
C*---------------------------------------------------------------------- SWAPO2A1.42
C Common blocks SWAPO2A1.43
C SWAPO2A1.44
*CALL CMAXSIZE GDR3F305.3
*CALL CSUBMODL GDR3F305.4
*CALL CTIME SWAPO2A1.47
*CALL CAOPTR SWAPO2A1.48
*CALL C_0_DG_C SWAPO2A1.49
*CALL C_MDI SWAPO2A1.50
*CALL TYPOCDPT CJG6F401.7
*CALL CNTLATM CCN1F405.382
*CALL CNTLOCN GSI0F402.31
C @DYALLOC.3547
C Subroutines called SWAPO2A1.53
C SWAPO2A1.54
EXTERNAL TRANSOUT,TRANSIN,TRANSO2A,UNPACK SWAPO2A1.55
C SWAPO2A1.56
C Local variables SWAPO2A1.57
C SWAPO2A1.58
INTEGER SWAPO2A1.59
& NFTASWAP,NFTOSWAP, ! FT units for swap files SWAPO2A1.60
& I, J ! Loop indeces CCN1F405.383
REAL SWAPO2A1.62
& AMDI, ! Missing data indicator SWAPO2A1.63
& SST(IMT*JMT), ! SST from ocean model @DYALLOC.3548
& UCURR(IMT*JMT),VCURR(IMT*JMT) ! Surface currents in ocean @DYALLOC.3549
& ,CO2FLUX(CO2_DIMO2) ! diagnostic co2 flux CCN1F405.384
& ,O_CO2FLUX(CO2_DIMO) ! co2 flux on ocean grid CCN1F405.385
*IF DEF,SEAICE SWAPO2A1.66
&, AICE(IMT*JMT), ! Seaice fraction @DYALLOC.3550
& ICEDEPTH(IMT*JMT), ! Ice depth @DYALLOC.3551
& SNOWDEPTH(IMT*JMT) ! Snowdepth @DYALLOC.3552
*ENDIF SWAPO2A1.70
CL---------------------------------------------------------------------- SWAPO2A1.71
CL 1. Copy coupling fields from ocean D1 addresses to workspace SWAPO2A1.72
CL NB: SST and currents (handled first) need decompression SWAPO2A1.73
CL ** Currents return JMT rows until ocean changes grid ** SWAPO2A1.74
CL SWAPO2A1.77
C SWAPO2A1.83
IF (L_OCOMP) THEN GSI0F402.32
GSI0F402.33
CALL UNPACK(1,JMT, 1,1,JMT,KM, IMT,JMT,1, SWAPO2A1.84
& O_CFI1,O_CFI2,joc_no_segs,O_CFI3,joc_no_seapts, SWAPO2A1.85
& D1(joc_tracer(1,2)),SST, RMDI,CYCLIC_OCEAN) CJT0F304.7
CALL UNPACK(1,JMT, 1,1,JMT,KM, IMT,JMT,1, SWAPO2A1.87
& O_CFI1,O_CFI2,joc_no_segs,O_CFI3,joc_no_seapts, SWAPO2A1.88
& D1(joc_u(2)),UCURR, RMDI,CYCLIC_OCEAN) CJT0F304.8
CALL UNPACK(1,JMT, 1,1,JMT,KM, IMT,JMT,1, SWAPO2A1.90
& O_CFI1,O_CFI2,joc_no_segs,O_CFI3,joc_no_seapts, SWAPO2A1.91
& D1(joc_v(2)),VCURR, RMDI,CYCLIC_OCEAN) CJT0F304.9
GSI0F402.34
ELSE GSI0F402.35
GSI0F402.36
DO I=1,IMT*JMT GSI0F402.37
SST(I)=D1(JO_TSTAR+I-1) GSI0F402.38
ENDDO GSI0F402.39
DO I=1,IMT*JMTM1 GSI0F402.40
UCURR(I)=D1(JO_UCURR+I-1) GSI0F402.41
VCURR(I)=D1(JO_VCURR+I-1) GSI0F402.42
ENDDO GSI0F402.43
GSI0F402.44
ENDIF GSI0F402.45
GSI0F402.46
*IF DEF,SEAICE SWAPO2A1.93
DO I=1,IMT*JMT @DYALLOC.3553
AICE(I)=D1(JO_AICE+I-1) SWAPO2A1.95
ICEDEPTH(I)=D1(JO_ICEDEPTH+I-1) SWAPO2A1.96
SNOWDEPTH(I)=D1(JO_SNOWDEPTH+I-1) SWAPO2A1.97
ENDDO SWAPO2A1.98
*ENDIF SWAPO2A1.99
! read data from D1 to CO2FLUX, without cyclic points CCN1F405.386
IF (L_CO2_INTERACTIVE) THEN CCN1F405.387
DO I=1,CO2_DIMO2 CCN1F405.388
CO2FLUX(I)=D1(JO_CO2FLUX+I-1) CCN1F405.389
ENDDO CCN1F405.390
! copy data to O_CO2FLUX on full grid CCN1F405.391
DO J=1,JMT CCN1F405.392
DO I=1,IMT-2 CCN1F405.393
O_CO2FLUX(I+(J-1)*IMT) = CO2FLUX(I+(J-1)*(IMT-2)) CCN1F405.394
ENDDO ! I CCN1F405.395
ENDDO ! J CCN1F405.396
! copy data into cyclic points CCN1F405.397
CALL CYCLICBC(O_CO2FLUX,IMT,JMT) CCN1F405.398
ENDIF ! L_CO2_INTERACTIVE CCN1F405.399
SWAPO2A1.100
CL---------------------------------------------------------------------- SWAPO2A1.101
CL 2. Perform IO to swap data in D1 from ocean to atmosphere SWAPO2A1.102
CL SWAPO2A1.103
NFTASWAP=18 SWAPO2A1.104
NFTOSWAP=19 SWAPO2A1.105
C SWAPO2A1.106
CALL TRANSOUT( @DYALLOC.3554
*CALL ARGD1 @DYALLOC.3555
& O_LEN_DATA+O_LEN_DUALDATA, GSI0F402.47
& NFTOSWAP,ocean_sm,ICODE,CMESSAGE) GRR1F402.315
IF (ICODE.GT.0) GOTO 999 SWAPO2A1.109
C SWAPO2A1.110
CALL TRANSIN ( @DYALLOC.3557
*CALL ARGD1 @DYALLOC.3558
& A_LEN_DATA+(P_LEVELS+1+2*Q_LEVELS)*P_FIELD, @DYALLOC.3559
& NFTASWAP,atmos_sm,ICODE,CMESSAGE) GRR1F402.316
IF (ICODE.GT.0) GOTO 999 SWAPO2A1.113
SWAPO2A1.114
CL---------------------------------------------------------------------- SWAPO2A1.115
CL 3. Perform the coupling calculations SWAPO2A1.116
CL SWAPO2A1.117
IF (L_CO2_INTERACTIVE) THEN CCN1F405.400
CO2_ICOLS = ROW_LENGTH CCN1F405.401
CO2_JROWS = P_ROWS CCN1F405.402
CO2_IMT = IMT CCN1F405.403
CO2_JMT = JMT CCN1F405.404
ELSE CCN1F405.405
O_CO2FLUX(1) = 0.0 CCN1F405.406
CO2_ICOLS = 1 CCN1F405.407
CO2_JROWS = 1 CCN1F405.408
CO2_IMT = 1 CCN1F405.409
CO2_JMT = 1 CCN1F405.410
ENDIF CCN1F405.411
CALL TRANSO2A ( SWAPO2A1.118
& SST,D1(JA_TSTAR),UCURR,D1(JA_UCURR),VCURR,D1(JA_VCURR), SWAPO2A1.119
*IF DEF,SEAICE SWAPO2A1.120
& AICE,D1(JA_AICE),ICEDEPTH,D1(JA_ICEDEPTH), SWAPO2A1.121
& SNOWDEPTH,D1(JA_SNOWDEPTH), SWAPO2A1.122
*ENDIF SWAPO2A1.123
& O_CO2FLUX,D1(JA_CO2FLUX),CO2_ICOLS,CO2_JROWS,CO2_IMT,CO2_JMT, CCN1F405.412
*IF DEF,TRANGRID SWAPO2A1.124
& XUO,XTO,YUO,YTO,XTA,XUA,YTA,YUA,LD1(JLAND), SWAPO2A1.125
*ENDIF SWAPO2A1.126
+ IMT,JMT,JMTM1,ROW_LENGTH,P_ROWS,U_ROWS, SWAPO2A1.127
C *** Note that current arrays actually have JMT rows for the moment, SWAPO2A1.128
C *** but TRANSO2A will simply ignore the extra row SWAPO2A1.129
+ (IMT+ROW_LENGTH)*(JMT+P_ROWS), SWAPO2A1.130
& O_FLDDEPC,O_SPCON(jocp_fkmq), CJG6F401.8
+ INVERT_OCEAN,CYCLIC_OCEAN,GLOBAL_OCEAN SWAPO2A1.131
&,ZERODEGC,TFS,ICODE,CMESSAGE) CJT0F304.10
C SWAPO2A1.133
999 CONTINUE SWAPO2A1.134
RETURN SWAPO2A1.135
CL---------------------------------------------------------------------- SWAPO2A1.136
END SWAPO2A1.137
*ENDIF SWAPO2A1.138