Changeset 8280 for branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC
- Timestamp:
- 2017-07-05T10:28:51+02:00 (7 years ago)
- Location:
- branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 18 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90
r6486 r8280 124 124 125 125 CASE DEFAULT 126 IF(lwp) WRITE(numout,*) ' E R R O R : bad cd_type in dia_wri_dimg ' 127 STOP 'dia_wri_dimg' 126 127 WRITE(numout,*) 'dia_wri_dimg : E R R O R : bad cd_type in dia_wri_dimg' 128 CALL ctl_stop( 'STOP', 'dia_wri_dimg :bad cd_type in dia_wri_dimg ' ) 128 129 129 130 END SELECT -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r7651 r8280 1116 1116 ENDIF 1117 1117 #endif 1118 1119 IF (cdfile_name == "output.abort") THEN 1120 CALL ctl_stop('MPPSTOP', 'NEMO abort from dia_wri_state') 1121 END IF 1118 1122 1119 1123 ! IF( nn_timing == 1 ) CALL timing_stop('dia_wri_state') ! not sure this works for routines not called in first timestep -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DIA/diawri_dimg.h90
r6486 r8280 112 112 IF( inbsel > jpk ) THEN 113 113 IF(lwp) WRITE(numout,*) ' STOP inbsel =',inbsel,' is larger than jpk=',jpk 114 STOP114 CALL ctl_stop('STOP', 'NEMO aborted from dia_wri') 115 115 ENDIF 116 116 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r6491 r8280 550 550 IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition' 551 551 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ using Schchepetkin and O Brian scheme' 552 IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' )552 IF( lk_mpp ) CALL ctl_stop('STOP', ' mpp version is not yet implemented' ) 553 553 554 554 ! mask for second order calculation of vorticity … … 572 572 WRITE(numout,*) ' symetric boundary conditions need special' 573 573 WRITE(numout,*) ' treatment not implemented. we stop.' 574 STOP574 CALL ctl_stop('STOP', 'NEMO abort from dom_msk_nsa') 575 575 ENDIF 576 576 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90
r6486 r8280 465 465 END DO 466 466 ELSE 467 IF(lwp)WRITE(numout,*) ' ldfguv: kahm= 1 or 2, here =', kahm 468 IF(lwp)WRITE(numout,*) ' We stop' 469 STOP 'ldfguv' 467 468 WRITE(numout,*) ' ldfguv: kahm= 1 or 2, here =', kahm 469 WRITE(numout,*) ' We stop' 470 CALL ctl_stop('STOP', 'ldfguv: Unexpected kahm value') 471 470 472 ENDIF 471 473 ! ! =============== -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90
r6486 r8280 38 38 USE wrk_nemo ! Memory Allocation 39 39 USE timing ! Timing 40 USE lib_fortran 40 41 41 42 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r7993 r8280 2049 2049 2050 2050 SUBROUTINE mppstop 2051 2052 #if defined key_oasis3 2053 USE mod_oasis ! coupling routines 2054 #endif 2055 2051 2056 !!---------------------------------------------------------------------- 2052 2057 !! *** routine mppstop *** … … 2058 2063 !!---------------------------------------------------------------------- 2059 2064 ! 2065 2066 #if defined key_oasis3 2067 ! If we're trying to shut down cleanly then we need to consider the fact 2068 ! that this could be part of an MPMD configuration - we don't want to 2069 ! leave other components deadlocked. 2070 2071 CALL oasis_abort(nproc,"mppstop","NEMO initiated abort") 2072 2073 2074 #else 2075 2060 2076 CALL mppsync 2061 2077 CALL mpi_finalize( info ) 2078 #endif 2079 2062 2080 ! 2063 2081 END SUBROUTINE mppstop … … 3884 3902 IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice) 3885 3903 ! 3904 IF( cd1 == 'MPPSTOP' ) THEN 3905 IF(lwp) WRITE(numout,*) 'E R R O R: Calling mppstop' 3906 CALL mppstop() 3907 ENDIF 3886 3908 IF( cd1 == 'STOP' ) THEN 3887 3909 IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop' … … 3988 4010 WRITE(kout,*) 3989 4011 ENDIF 3990 STOP 'ctl_opn bad opening'4012 CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening') 3991 4013 ENDIF 3992 4014 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90
r6486 r8280 31 31 USE in_out_manager ! I/O manager 32 32 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 33 33 34 34 IMPLICIT NONE 35 35 PRIVATE … … 41 41 PUBLIC cpl_freq 42 42 PUBLIC cpl_finalize 43 #if defined key_mpp_mpi 44 INCLUDE 'mpif.h' 45 #endif 46 47 INTEGER, PARAMETER :: localRoot = 0 48 LOGICAL :: commRank ! true for ranks doing OASIS communication 49 #if defined key_cpl_rootexchg 50 LOGICAL :: rootexchg =.true. ! logical switch 51 #else 52 LOGICAL :: rootexchg =.false. ! logical switch 53 #endif 43 54 44 55 INTEGER, PUBLIC :: OASIS_Rcv = 1 !: return code if received field … … 82 93 83 94 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld ! Temporary buffer for receiving 84 95 INTEGER, PUBLIC :: localComm 96 85 97 !!---------------------------------------------------------------------- 86 98 !! NEMO/OPA 3.3 , NEMO Consortium (2010) … … 120 132 IF ( nerror /= OASIS_Ok ) & 121 133 CALL oasis_abort (ncomp_id, 'cpl_init','Failure in oasis_get_localcomm' ) 134 localComm = kl_comm 122 135 ! 123 136 END SUBROUTINE cpl_init … … 177 190 IF( nerror > 0 ) THEN 178 191 CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN 179 ENDIF 192 ENDIF 180 193 ! 181 194 ! ----------------------------------------------------------------- 182 195 ! ... Define the partition 183 196 ! ----------------------------------------------------------------- 184 197 185 198 paral(1) = 2 ! box partitioning 186 199 paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1) ! NEMO lower left corner global offset … … 196 209 ENDIF 197 210 198 CALL oasis_def_partition ( id_part, paral, nerror 211 CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo) 199 212 ! 200 213 ! ... Announce send variables. … … 241 254 END DO 242 255 ENDIF 243 END DO 256 END DO 244 257 ! 245 258 ! ... Announce received variables. … … 373 386 IF( srcv(kid)%nid(jc,jm) /= -1 ) THEN 374 387 375 CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo ) 388 CALL oasis_get ( srcv(kid)%nid(jc,jm), kstep, exfld, kinfo ) 376 389 377 390 llaction = kinfo == OASIS_Recvd .OR. kinfo == OASIS_FromRest .OR. & … … 384 397 kinfo = OASIS_Rcv 385 398 IF( llfisrt ) THEN 386 pdata(nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 399 pdata(nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) 387 400 llfisrt = .FALSE. 388 401 ELSE … … 463 476 CALL oasis_get_freqs(id, mop, 1, itmp, info) 464 477 #else 478 #if defined key_oasis3 479 itmp(1) = namflddti( id ) 480 #else 465 481 CALL oasis_get_freqs(id, 1, itmp, info) 482 #endif 466 483 #endif 467 484 cpl_freq = itmp(1) … … 514 531 END SUBROUTINE oasis_get_localcomm 515 532 516 SUBROUTINE oasis_def_partition(k1,k2,k3 )533 SUBROUTINE oasis_def_partition(k1,k2,k3,K4) 517 534 INTEGER , INTENT( out) :: k1,k3 518 535 INTEGER , INTENT(in ) :: k2(5) 536 INTEGER , OPTIONAL, INTENT(in ) :: k4 519 537 k1 = k2(1) ; k3 = k2(5) 520 538 WRITE(numout,*) 'oasis_def_partition: Error you sould not be there...' -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/geo2ocean.F90
r6486 r8280 51 51 52 52 SUBROUTINE repcmo ( pxu1, pyu1, pxv1, pyv1, & 53 px2 , py2 )53 px2 , py2 , kchoix ) 54 54 !!---------------------------------------------------------------------- 55 55 !! *** ROUTINE repcmo *** … … 68 68 REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: py2 ! j-componante (defined at v-point) 69 69 !!---------------------------------------------------------------------- 70 71 ! Change from geographic to stretched coordinate 72 ! ---------------------------------------------- 73 CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 ) 74 CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 ) 75 70 INTEGER, INTENT( IN ) :: & 71 kchoix ! type of transformation 72 ! = 1 change from geographic to model grid. 73 ! =-1 change from model to geographic grid 74 !!---------------------------------------------------------------------- 75 76 SELECT CASE (kchoix) 77 CASE ( 1) 78 ! Change from geographic to stretched coordinate 79 ! ---------------------------------------------- 80 81 CALL rot_rep( pxu1, pyu1, 'U', 'en->i',px2 ) 82 CALL rot_rep( pxv1, pyv1, 'V', 'en->j',py2 ) 83 CASE (-1) 84 ! Change from stretched to geographic coordinate 85 ! ---------------------------------------------- 86 87 CALL rot_rep( pxu1, pyu1, 'U', 'ij->e',px2 ) 88 CALL rot_rep( pxv1, pyv1, 'V', 'ij->n',py2 ) 89 END SELECT 90 76 91 END SUBROUTINE repcmo 77 92 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r8046 r8280 34 34 USE geo2ocean ! 35 35 USE oce , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev, & 36 CO2Flux_out_cpl, DMS_out_cpl, PCO2a_in_cpl, Dust_in_cpl, & 36 CO2Flux_out_cpl, DMS_out_cpl, chloro_out_cpl, & 37 PCO2a_in_cpl, Dust_in_cpl, & 37 38 ln_medusa 38 39 USE albedo ! … … 145 146 INTEGER, PARAMETER :: jps_sstfrz = 32 ! sea-surface freezing temperature 146 147 INTEGER, PARAMETER :: jps_fice1 = 33 ! first-order ice concentration (for time-travelling ice coupling) 147 INTEGER, PARAMETER :: jps_bio_co2 = 34 ! MEDUSA air-sea CO2 flux in 148 INTEGER, PARAMETER :: jps_bio_dms = 35 ! MEDUSA DMS surface concentration in 149 INTEGER, PARAMETER :: jpsnd = 35 ! total number of fields sent 148 INTEGER, PARAMETER :: jps_bio_co2 = 34 ! MEDUSA air-sea CO2 flux 149 INTEGER, PARAMETER :: jps_bio_dms = 35 ! MEDUSA DMS surface concentration 150 INTEGER, PARAMETER :: jps_bio_chloro = 36 ! MEDUSA chlorophyll surface concentration 151 INTEGER, PARAMETER :: jpsnd = 36 ! total number of fields sent 150 152 151 153 REAL(wp), PARAMETER :: dms_unit_conv = 1.0e+6 ! Coversion factor to get outgong DMS in standard units for coupling … … 162 164 ! Send to the atmosphere ! 163 165 TYPE(FLD_C) :: sn_snd_temp, sn_snd_alb, sn_snd_thick, sn_snd_crt, sn_snd_co2, sn_snd_cond, sn_snd_mpnd, sn_snd_sstfrz, sn_snd_thick1 164 TYPE(FLD_C) :: sn_snd_bio_co2, sn_snd_bio_dms 166 TYPE(FLD_C) :: sn_snd_bio_co2, sn_snd_bio_dms, sn_snd_bio_chloro 165 167 166 168 ! Received from the atmosphere ! … … 207 209 ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) 208 210 #endif 209 ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 211 !ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) 212 ! Hardwire only two models as nn_cplmodel has not been read in 213 ! from the namelist yet. 214 ALLOCATE( xcplmask(jpi,jpj,0:2) , STAT=ierr(3) ) 210 215 ! 211 216 sbc_cpl_alloc = MAXVAL( ierr ) … … 246 251 247 252 ! Add MEDUSA related fields to namelist 248 NAMELIST/namsbc_cpl/ sn_snd_bio_co2, sn_snd_bio_dms, 253 NAMELIST/namsbc_cpl/ sn_snd_bio_co2, sn_snd_bio_dms, sn_snd_bio_chloro, & 249 254 & sn_rcv_atm_pco2, sn_rcv_atm_dust 250 255 … … 304 309 WRITE(numout,*)' bio co2 flux = ', TRIM(sn_snd_bio_co2%cldes), ' (', TRIM(sn_snd_bio_co2%clcat), ')' 305 310 WRITE(numout,*)' bio dms flux = ', TRIM(sn_snd_bio_dms%cldes), ' (', TRIM(sn_snd_bio_dms%clcat), ')' 311 WRITE(numout,*)' bio dms chlorophyll = ', TRIM(sn_snd_bio_chloro%cldes), ' (', TRIM(sn_snd_bio_chloro%clcat), ')' 306 312 WRITE(numout,*)' oce co2 flux = ', TRIM(sn_snd_co2%cldes ), ' (', TRIM(sn_snd_co2%clcat ), ')' 307 313 WRITE(numout,*)' ice effective conductivity = ', TRIM(sn_snd_cond%cldes ), ' (', TRIM(sn_snd_cond%clcat ), ')' … … 321 327 322 328 ! ! allocate sbccpl arrays 323 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )329 !IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 324 330 325 331 ! ================================ ! … … 384 390 srcv(jpr_otx2:jpr_otz2)%clgrid = 'V' ! and V-point 385 391 srcv(jpr_itx1:jpr_itz1)%clgrid = 'F' ! ice components given at F-point 386 srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 392 !srcv(jpr_otx1:jpr_otz2)%laction = .TRUE. ! receive oce components on grid 1 & 2 393 ! Currently needed for HadGEM3 - but shouldn't affect anyone else for the moment 394 srcv(jpr_otx1)%laction = .TRUE. 395 srcv(jpr_oty1)%laction = .TRUE. 396 ! 387 397 srcv(jpr_itx1:jpr_itz1)%laction = .TRUE. ! receive ice components on grid 1 only 388 398 CASE( 'T,I' ) … … 826 836 IF( TRIM(sn_snd_bio_co2%cldes) == 'medusa' ) ssnd(jps_bio_co2 )%laction = .TRUE. 827 837 838 ! Surface chlorophyll from Medusa 839 ssnd(jps_bio_chloro)%clname = 'OBioChlo' 840 IF( TRIM(sn_snd_bio_chloro%cldes) == 'medusa' ) ssnd(jps_bio_chloro )%laction = .TRUE. 841 828 842 ! ! ------------------------- ! 829 843 ! ! Sea surface freezing temp ! … … 1035 1049 INTEGER :: ji, jj, jl, jn ! dummy loop indices 1036 1050 INTEGER :: isec ! number of seconds since nit000 (assuming rdttra did not change since nit000) 1051 INTEGER :: ikchoix 1037 1052 REAL(wp) :: zcumulneg, zcumulpos ! temporary scalars 1038 1053 REAL(wp) :: zgreenland_icesheet_mass_in, zantarctica_icesheet_mass_in … … 1043 1058 REAL(wp) :: zcdrag = 1.5e-3 ! drag coefficient 1044 1059 REAL(wp) :: zzx, zzy ! temporary variables 1045 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty, zmsk, zemp, zqns, zqsr 1060 REAL(wp), POINTER, DIMENSION(:,:) :: ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 1046 1061 !!---------------------------------------------------------------------- 1047 1062 1048 ! RSRH temporary arrays for testing, just to recieve incoming MEDUSA related fields1049 ! until we know where they need to go.1050 REAL(wp), ALLOCATABLE :: atm_pco2(:,:)1051 REAL(wp), ALLOCATABLE :: atm_dust(:,:)1052 1053 1063 ! 1054 1064 IF( nn_timing == 1 ) CALL timing_start('sbc_cpl_rcv') 1055 1065 ! 1056 CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr )1066 CALL wrk_alloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 ) 1057 1067 ! 1058 1068 IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) … … 1092 1102 IF( TRIM( sn_rcv_tau%clvor ) == 'eastward-northward' ) THEN ! 2 components oriented along the local grid 1093 1103 ! ! (geographical to local grid -> rotate the components) 1094 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 1095 IF( srcv(jpr_otx2)%laction ) THEN 1096 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) 1097 ELSE 1098 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 1104 IF( srcv(jpr_otx1)%clgrid == 'U' .AND. (.NOT. srcv(jpr_otx2)%laction) ) THEN 1105 ! Temporary code for HadGEM3 - will be removed eventually. 1106 ! Only applies when we have only taux on U grid and tauy on V grid 1107 DO jj=2,jpjm1 1108 DO ji=2,jpim1 1109 ztx(ji,jj)=0.25*vmask(ji,jj,1) & 1110 *(frcv(jpr_otx1)%z3(ji,jj,1)+frcv(jpr_otx1)%z3(ji-1,jj,1) & 1111 +frcv(jpr_otx1)%z3(ji,jj+1,1)+frcv(jpr_otx1)%z3(ji-1,jj+1,1)) 1112 zty(ji,jj)=0.25*umask(ji,jj,1) & 1113 *(frcv(jpr_oty1)%z3(ji,jj,1)+frcv(jpr_oty1)%z3(ji+1,jj,1) & 1114 +frcv(jpr_oty1)%z3(ji,jj-1,1)+frcv(jpr_oty1)%z3(ji+1,jj-1,1)) 1115 ENDDO 1116 ENDDO 1117 1118 ikchoix = 1 1119 CALL repcmo (frcv(jpr_otx1)%z3(:,:,1),zty,ztx,frcv(jpr_oty1)%z3(:,:,1),ztx2,zty2,ikchoix) 1120 CALL lbc_lnk (ztx2,'U', -1. ) 1121 CALL lbc_lnk (zty2,'V', -1. ) 1122 frcv(jpr_otx1)%z3(:,:,1)=ztx2(:,:) 1123 frcv(jpr_oty1)%z3(:,:,1)=zty2(:,:) 1124 ELSE 1125 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->i', ztx ) 1126 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid 1127 IF( srcv(jpr_otx2)%laction ) THEN 1128 CALL rot_rep( frcv(jpr_otx2)%z3(:,:,1), frcv(jpr_oty2)%z3(:,:,1), srcv(jpr_otx2)%clgrid, 'en->j', zty ) 1129 ELSE 1130 CALL rot_rep( frcv(jpr_otx1)%z3(:,:,1), frcv(jpr_oty1)%z3(:,:,1), srcv(jpr_otx1)%clgrid, 'en->j', zty ) 1131 ENDIF 1132 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid 1099 1133 ENDIF 1100 frcv(jpr_otx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid1101 frcv(jpr_oty1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 2nd grid1102 1134 ENDIF 1103 1135 ! … … 1419 1451 1420 1452 ! 1421 CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr )1453 CALL wrk_dealloc( jpi,jpj, ztx, zty, zmsk, zemp, zqns, zqsr, ztx2, zty2 ) 1422 1454 ! 1423 1455 IF( nn_timing == 1 ) CALL timing_stop('sbc_cpl_rcv') … … 2101 2133 ! 2102 2134 INTEGER :: ji, jj, jl ! dummy loop indices 2135 INTEGER :: ikchoix 2103 2136 INTEGER :: isec, info ! local integer 2104 2137 REAL(wp) :: zumax, zvmax … … 2347 2380 2348 2381 IF (ln_medusa) THEN 2349 ! ! --------------------------------- !2350 ! ! CO2 flux and DMSfrom MEDUSA !2351 ! ! --------------------------------- !2382 ! ! ---------------------------------------------- ! 2383 ! ! CO2 flux, DMS and chlorophyll from MEDUSA ! 2384 ! ! ---------------------------------------------- ! 2352 2385 IF ( ssnd(jps_bio_co2)%laction ) THEN 2353 2386 CALL cpl_snd( jps_bio_co2, isec, RESHAPE( CO2Flux_out_cpl, (/jpi,jpj,1/) ), info ) … … 2356 2389 IF ( ssnd(jps_bio_dms)%laction ) THEN 2357 2390 CALL cpl_snd( jps_bio_dms, isec, RESHAPE( DMS_out_cpl, (/jpi,jpj,1/) ), info ) 2391 ENDIF 2392 2393 IF ( ssnd(jps_bio_chloro)%laction ) THEN 2394 CALL cpl_snd( jps_bio_chloro, isec, RESHAPE( chloro_out_cpl, (/jpi,jpj,1/) ), info ) 2358 2395 ENDIF 2359 2396 ENDIF … … 2365 2402 ! j+1 j -----V---F 2366 2403 ! surface velocity always sent from T point ! | 2367 ! 2404 ! [except for HadGEM3] j | T U 2368 2405 ! | | 2369 2406 ! j j-1 -I-------| … … 2377 2414 SELECT CASE( TRIM( sn_snd_crt%cldes ) ) 2378 2415 CASE( 'oce only' ) ! C-grid ==> T 2379 DO jj = 2, jpjm1 2380 DO ji = fs_2, fs_jpim1 ! vector opt. 2381 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 2382 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) 2416 IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 2417 DO jj = 2, jpjm1 2418 DO ji = fs_2, fs_jpim1 ! vector opt. 2419 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) 2420 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) 2421 END DO 2383 2422 END DO 2384 END DO 2423 ELSE 2424 ! Temporarily Changed for UKV 2425 DO jj = 2, jpjm1 2426 DO ji = 2, jpim1 2427 zotx1(ji,jj) = un(ji,jj,1) 2428 zoty1(ji,jj) = vn(ji,jj,1) 2429 END DO 2430 END DO 2431 ENDIF 2385 2432 CASE( 'weighted oce and ice' ) 2386 2433 SELECT CASE ( cp_ice_msh ) … … 2441 2488 END DO 2442 2489 CASE( 'F' ) ! Ocean on C grid, Ice on F-point (B-grid) ==> T 2443 DO jj = 2, jpjm1 2444 DO ji = 2, jpim1 ! NO vector opt. 2445 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) * zfr_l(ji,jj) & 2446 & + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) & 2447 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 2448 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) * zfr_l(ji,jj) & 2449 & + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) & 2450 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 2490 IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 2491 DO jj = 2, jpjm1 2492 DO ji = 2, jpim1 ! NO vector opt. 2493 zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj,1) ) * zfr_l(ji,jj) & 2494 & + 0.25 * ( u_ice(ji-1,jj-1) + u_ice(ji,jj-1) & 2495 & + u_ice(ji-1,jj ) + u_ice(ji,jj ) ) * fr_i(ji,jj) 2496 zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji,jj-1,1) ) * zfr_l(ji,jj) & 2497 & + 0.25 * ( v_ice(ji-1,jj-1) + v_ice(ji,jj-1) & 2498 & + v_ice(ji-1,jj ) + v_ice(ji,jj ) ) * fr_i(ji,jj) 2499 END DO 2451 2500 END DO 2452 END DO 2501 #if defined key_cice 2502 ELSE 2503 ! Temporarily Changed for HadGEM3 2504 DO jj = 2, jpjm1 2505 DO ji = 2, jpim1 ! NO vector opt. 2506 zotx1(ji,jj) = (1.0-fr_iu(ji,jj)) * un(ji,jj,1) & 2507 & + fr_iu(ji,jj) * 0.5 * ( u_ice(ji,jj-1) + u_ice(ji,jj) ) 2508 zoty1(ji,jj) = (1.0-fr_iv(ji,jj)) * vn(ji,jj,1) & 2509 & + fr_iv(ji,jj) * 0.5 * ( v_ice(ji-1,jj) + v_ice(ji,jj) ) 2510 END DO 2511 END DO 2512 #endif 2513 ENDIF 2453 2514 END SELECT 2454 2515 END SELECT … … 2460 2521 IF( TRIM( sn_snd_crt%clvor ) == 'eastward-northward' ) THEN ! Rotation of the components 2461 2522 ! ! Ocean component 2462 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2463 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2464 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2465 zoty1(:,:) = ztmp2(:,:) 2466 IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component 2467 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2468 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2469 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2470 zity1(:,:) = ztmp2(:,:) 2471 ENDIF 2523 IF ( TRIM( sn_snd_crt%clvgrd ) == 'T' ) THEN 2524 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2525 CALL rot_rep( zotx1, zoty1, ssnd(jps_ocx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2526 zotx1(:,:) = ztmp1(:,:) ! overwrite the components 2527 zoty1(:,:) = ztmp2(:,:) 2528 IF( ssnd(jps_ivx1)%laction ) THEN ! Ice component 2529 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->e', ztmp1 ) ! 1st component 2530 CALL rot_rep( zitx1, zity1, ssnd(jps_ivx1)%clgrid, 'ij->n', ztmp2 ) ! 2nd component 2531 zitx1(:,:) = ztmp1(:,:) ! overwrite the components 2532 zity1(:,:) = ztmp2(:,:) 2533 ENDIF 2534 ELSE 2535 ! Temporary code for HadGEM3 - will be removed eventually. 2536 ! Only applies when we want uvel on U grid and vvel on V grid 2537 ! Rotate U and V onto geographic grid before sending. 2538 2539 DO jj=2,jpjm1 2540 DO ji=2,jpim1 2541 ztmp1(ji,jj)=0.25*vmask(ji,jj,1) & 2542 *(zotx1(ji,jj)+zotx1(ji-1,jj) & 2543 +zotx1(ji,jj+1)+zotx1(ji-1,jj+1)) 2544 ztmp2(ji,jj)=0.25*umask(ji,jj,1) & 2545 *(zoty1(ji,jj)+zoty1(ji+1,jj) & 2546 +zoty1(ji,jj-1)+zoty1(ji+1,jj-1)) 2547 ENDDO 2548 ENDDO 2549 2550 ! Ensure any N fold and wrap columns are updated 2551 CALL lbc_lnk(ztmp1, 'V', -1.0) 2552 CALL lbc_lnk(ztmp2, 'U', -1.0) 2553 2554 ikchoix = -1 2555 CALL repcmo (zotx1,ztmp2,ztmp1,zoty1,zotx1,zoty1,ikchoix) 2556 ENDIF 2472 2557 ENDIF 2473 2558 ! -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_cice.F90
r6500 r8280 302 302 CALL wrk_dealloc( jpi,jpj, ztmp1, ztmp2 ) 303 303 ! 304 ! In coupled mode get extra fields from CICE for passing back to atmosphere 305 306 IF ( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(nit000) 307 ! 304 308 IF( nn_timing == 1 ) CALL timing_stop('cice_sbc_init') 305 309 ! … … 736 740 IF( nn_timing == 1 ) CALL timing_start('cice_sbc_hadgam') 737 741 ! 738 IF( kt == nit000 ) THEN739 IF(lwp) WRITE(numout,*)'cice_sbc_hadgam'740 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' )741 ENDIF742 743 742 ! ! =========================== ! 744 743 ! ! Prepare Coupling fields ! -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90
r7993 r8280 266 266 ENDIF 267 267 ! 268 IF( lk_oasis ) CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before: (1) first time step 269 ! ! (2) the use of nn_fsbc 268 IF( lk_oasis ) THEN 269 IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) 270 CALL sbc_cpl_init (nn_ice) ! OASIS initialisation. must be done before: (1) first time step 271 ! (2) the use of nn_fsbc 272 ENDIF 270 273 271 274 ! nn_fsbc initialization if OPA-SAS coupling via OASIS -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90
r7179 r8280 327 327 END DO 328 328 ELSE 329 IF(lwp)WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht330 IF(lwp)WRITE(numout,*) ' We stop'331 STOP 'ldfght'329 WRITE(numout,*) ' ldfght: kaht= 1 or 2, here =', kaht 330 WRITE(numout,*) ' We stop' 331 CALL ctl_stop( 'STOP', 'ldfght : unexpected kaht value') 332 332 ENDIF 333 333 ! ! =============== -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/TRD/trdtrc.F90
r6486 r8280 1 #if ! defined key_top 1 2 MODULE trdtrc 2 3 !!====================================================================== … … 22 23 !!====================================================================== 23 24 END MODULE trdtrc 25 #endif -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r7563 r8280 68 68 USE icbini ! handle bergs, initialisation 69 69 USE icbstp ! handle bergs, calving, themodynamics and transport 70 USE sbccpl 70 71 USE cpl_oasis3 ! OASIS3 coupling 71 72 USE c1d ! 1D configuration … … 74 75 #if defined key_top 75 76 USE trcini ! passive tracer initialisation 77 USE trc, ONLY: numstr ! tracer stats unit number 76 78 #endif 77 79 USE lib_mpp ! distributed memory computing … … 169 171 CALL stp ! AGRIF: time stepping 170 172 #else 171 CALL stp( istp ) ! standard time stepping 173 IF (lk_oasis) CALL sbc_cpl_snd( istp ) ! Coupling to atmos 174 CALL stp( istp ) 175 ! We don't couple on the final timestep because 176 ! our restart file has already been written 177 ! and contains all the necessary data for a 178 ! restart. sbc_cpl_snd could be called here 179 ! but it would require 180 ! a) A test to ensure it was not performed 181 ! on the very last time-step 182 ! b) the presence of another call to 183 ! sbc_cpl_snd call prior to the main DO loop 184 ! This solution produces identical results 185 ! with fewer lines of code. 172 186 #endif 173 187 istp = istp + 1 … … 283 297 IF( Agrif_Root() ) THEN 284 298 IF( lk_oasis ) THEN 285 CALL cpl_init( " oceanx", ilocal_comm ) ! nemo local communicator given by oasis299 CALL cpl_init( "toyoce", ilocal_comm ) ! nemo local communicator given by oasis 286 300 CALL xios_initialize( "not used",local_comm=ilocal_comm ) ! send nemo communicator to xios 287 301 ELSE … … 294 308 IF( lk_oasis ) THEN 295 309 IF( Agrif_Root() ) THEN 296 CALL cpl_init( " oceanx", ilocal_comm ) ! nemo local communicator given by oasis310 CALL cpl_init( "toyoce", ilocal_comm ) ! nemo local communicator given by oasis 297 311 ENDIF 298 312 ! Nodes selection (control print return in cltxt) … … 474 488 IF( lk_asminc ) CALL asm_inc_init ! Initialize assimilation increments 475 489 IF(lwp) WRITE(numout,*) 'Euler time step switch is ', neuler 490 491 IF (nstop > 0) THEN 492 CALL CTL_STOP('STOP','Critical errors in NEMO initialisation') 493 END IF 494 476 495 ! 477 496 END SUBROUTINE nemo_init … … 609 628 IF( numdct_heat /= -1 ) CLOSE( numdct_heat ) ! heat transports 610 629 IF( numdct_salt /= -1 ) CLOSE( numdct_salt ) ! salt transports 611 630 #if defined key_top 631 IF( numstr /= -1 ) CLOSE( numstr ) ! tracer statistics 632 #endif 612 633 ! 613 634 numout = 6 ! redefine numout in case it is used after this point... -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/oce.F90
r7770 r8280 77 77 REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: CO2Flux_out_cpl(:,:) ! Output coupling CO2 flux 78 78 REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: DMS_out_cpl(:,:) ! Output coupling DMS 79 REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: chloro_out_cpl(:,:) ! Output coupling chlorophyll 80 ! (expected in Kg/M3) 79 81 80 82 REAL(wp), PUBLIC, ALLOCATABLE, SAVE :: PCO2a_in_cpl(:,:) ! Input coupling CO2 partial pressure … … 138 140 ! are enabled 139 141 ALLOCATE( CO2Flux_out_cpl(jpi,jpj), DMS_out_cpl(jpi,jpj), & 142 chloro_out_cpl(jpi,jpj), & 140 143 PCO2a_in_cpl(jpi,jpj), Dust_in_cpl(jpi,jpj), STAT=ierr(5) ) 141 144 -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/step.F90
r7962 r8280 380 380 ! Coupled mode 381 381 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 382 IF( lk_oasis ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges382 !IF( lk_oasis ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges 383 383 ! 384 384 #if defined key_iomput -
branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90
r6486 r8280 453 453 SUBROUTINE wrk_allocbase( kidim , kjdim , kkdim , kldim , kisrt , kjsrt , kksrt , klsrt , & 454 454 & kwrk1d, kwrk2d, kwrk3d, kwrk4d, pwrk1d, pwrk2d, pwrk3d, pwrk4d ) 455 USE in_out_manager, ONLY: numout 455 456 INTEGER , INTENT(in ) :: kidim, kjdim, kkdim, kldim 456 457 INTEGER , INTENT(in ) :: kisrt, kjsrt, kksrt, klsrt … … 483 484 & .AND. SUM( tree(ii)%ishape ) /= 0 ) 484 485 ii = ii + 1 485 IF (ii > jparray) STOP ! increase the value of jparray (should not be needed as already very big!) 486 IF (ii > jparray) THEN 487 WRITE(numout,*) "E R R O R: NEMO aborted wrk_allocbase" 488 FLUSH(numout) 489 STOP 'Increase the value of jparray' 490 ! increase the value of jparray (should not be needed as already very big!) 491 END IF 486 492 END DO 487 493
Note: See TracChangeset
for help on using the changeset viewer.