Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
- Timestamp:
- 2011-03-30T17:58:35+02:00 (13 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90
r2571 r2715 50 50 INTEGER , PUBLIC :: nn_fwri = 15 !: frequency of ptr outputs [time step] 51 51 52 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.)53 REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE:: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.)52 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.) 53 REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.) 54 54 55 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: btmsk ! T-point basin interior masks 56 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 #if defined key_diaeiv 61 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 62 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 63 #endif 55 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks 56 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S) 57 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx) 58 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function 59 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse 60 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv') 61 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv') 62 64 63 65 64 INTEGER :: niter ! … … 71 70 REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp) 72 71 REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg 72 73 REAL(wp), TARGET, DIMENSION(:), ALLOCATABLE, SAVE :: p_fval1d 74 REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d 75 76 !! Integer, 1D workspace arrays. Not common enough to be implemented in 77 !! wrk_nemo module. 78 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 79 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 80 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 73 81 74 82 !! * Substitutions … … 82 90 CONTAINS 83 91 92 FUNCTION dia_ptr_alloc() 93 !!---------------------------------------------------------------------- 94 !! *** ROUTINE dia_ptr_alloc *** 95 !!---------------------------------------------------------------------- 96 INTEGER :: dia_ptr_alloc ! return value 97 INTEGER, DIMENSION(5) :: ierr 98 !!---------------------------------------------------------------------- 99 ierr(:) = 0 100 ! 101 ALLOCATE( btmsk(jpi,jpj,nptr) , & 102 & htr_adv(jpj) , str_adv(jpj) , & 103 & htr_ldf(jpj) , str_ldf(jpj) , & 104 & htr_ove(jpj) , str_ove(jpj), & 105 & htr(jpj,nptr) , str(jpj,nptr) , & 106 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 107 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) ) 108 ! 109 #if defined key_diaeiv 110 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 111 & v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 112 #endif 113 ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3)) 114 ! 115 ALLOCATE(ndex(jpj*jpk), ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 116 & ndex_ind(jpj*jpk), ndex_ipc(jpj*jpk), & 117 & ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 118 119 ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk), & 120 & ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 121 & ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) ) 122 ! 123 dia_ptr_alloc = MAXVAL( ierr ) 124 IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc ) 125 ! 126 END FUNCTION dia_ptr_alloc 127 128 84 129 FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval ) 85 130 !!---------------------------------------------------------------------- … … 97 142 INTEGER :: ji, jj, jk ! dummy loop arguments 98 143 INTEGER :: ijpj ! ??? 99 REAL(wp), DIMENSION(jpj) :: p_fval! function value144 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 100 145 !!-------------------------------------------------------------------- 101 146 ! 147 p_fval => p_fval1d 148 102 149 ijpj = jpj 103 150 p_fval(:) = 0._wp … … 109 156 END DO 110 157 END DO 111 ! 112 #if defined key_mpp_mpi 113 CALL mpp_sum( p_fval, ijpj, ncomm_znl) 158 #if defined key_mpp_mpi 159 IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl) 114 160 #endif 115 161 ! … … 128 174 !! ** Action : - p_fval: i-k-mean poleward flux of pva 129 175 !!---------------------------------------------------------------------- 176 IMPLICIT none 130 177 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point 131 178 !! 132 INTEGER :: ji,jj ! dummy loop arguments133 INTEGER :: ijpj ! ???134 REAL(wp), DIMENSION(jpj) :: p_fval! function value179 INTEGER :: ji,jj ! dummy loop arguments 180 INTEGER :: ijpj ! ??? 181 REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value 135 182 !!-------------------------------------------------------------------- 136 183 ! 184 p_fval => p_fval1d 185 137 186 ijpj = jpj 138 187 p_fval(:) = 0._wp … … 142 191 END DO 143 192 END DO 144 !145 193 #if defined key_mpp_mpi 146 194 CALL mpp_sum( p_fval, ijpj, ncomm_znl ) … … 161 209 !! ** Action : - p_fval: i-mean poleward flux of pva 162 210 !!---------------------------------------------------------------------- 211 #if defined key_mpp_mpi 212 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 213 USE wrk_nemo, ONLY: zwork => wrk_1d_1 214 #endif 215 !! 216 IMPLICIT none 163 217 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point 164 218 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask 165 219 !! 166 INTEGER :: ji, jj, jk! dummy loop arguments167 REAL(wp), DIMENSION(jpj,jpk) :: p_fval! return function value220 INTEGER :: ji, jj, jk ! dummy loop arguments 221 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 168 222 #if defined key_mpp_mpi 169 223 INTEGER, DIMENSION(1) :: ish 170 224 INTEGER, DIMENSION(2) :: ish2 171 REAL(wp), DIMENSION(jpj*jpk) :: zwork ! 1D workspace225 INTEGER :: ijpjjpk 172 226 #endif 173 227 !!-------------------------------------------------------------------- 174 228 ! 229 #if defined key_mpp_mpi 230 IF( wrk_in_use(1, 1) ) THEN 231 CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') ; RETURN 232 END IF 233 #endif 234 235 p_fval => p_fval2d 236 175 237 p_fval(:,:) = 0._wp 176 238 ! … … 195 257 ! 196 258 #if defined key_mpp_mpi 197 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 198 zwork(:) = RESHAPE( p_fval, ish ) 199 CALL mpp_sum( zwork, jpj*jpk, ncomm_znl ) 259 ijpjjpk = jpj*jpk 260 ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk 261 zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) 262 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 200 263 p_fval(:,:) = RESHAPE( zwork, ish2 ) 201 264 #endif 202 265 ! 266 #if defined key_mpp_mpi 267 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 268 #endif 269 ! 203 270 END FUNCTION ptr_vjk 204 271 … … 214 281 !! ** Action : - p_fval: i-sum of e1t*e3t*pta 215 282 !!---------------------------------------------------------------------- 283 #if defined key_mpp_mpi 284 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 285 USE wrk_nemo, ONLY: zwork => wrk_1d_1 286 #endif 287 !! 216 288 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point 217 289 REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask 218 290 !! 219 INTEGER ::ji, jj, jk ! dummy loop arguments220 REAL(wp), DIMENSION(jpj,jpk) ::p_fval ! return function value291 INTEGER :: ji, jj, jk ! dummy loop arguments 292 REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value 221 293 #if defined key_mpp_mpi 222 294 INTEGER, DIMENSION(1) :: ish 223 295 INTEGER, DIMENSION(2) :: ish2 224 REAL(wp),DIMENSION(jpj*jpk) :: zwork ! 1D workspace296 INTEGER :: ijpjjpk 225 297 #endif 226 298 !!-------------------------------------------------------------------- 227 299 ! 300 #if defined key_mpp_mpi 301 IF( wrk_in_use(1, 1) ) THEN 302 CALL ctl_stop('ptr_tjk: requested workspace array unavailable') ; RETURN 303 ENDIF 304 #endif 305 306 p_fval => p_fval2d 307 228 308 p_fval(:,:) = 0._wp 229 309 DO jk = 1, jpkm1 … … 235 315 END DO 236 316 #if defined key_mpp_mpi 317 ijpjjpk = jpj*jpk 237 318 ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk 238 zwork( :)= RESHAPE( p_fval, ish )239 CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )319 zwork(1:ijpjjpk)= RESHAPE( p_fval, ish ) 320 CALL mpp_sum( zwork, ijpjjpk, ncomm_znl ) 240 321 p_fval(:,:)= RESHAPE( zwork, ish2 ) 241 322 #endif 242 323 ! 324 #if defined key_mpp_mpi 325 IF( wrk_not_released(1, 1) ) CALL ctl_stop('ptr_tjk: failed to release workspace array') 326 #endif 327 ! 243 328 END FUNCTION ptr_tjk 244 329 … … 250 335 USE oce, vt => ua ! use ua as workspace 251 336 USE oce, vs => ua ! use ua as workspace 337 IMPLICIT none 252 338 !! 253 339 INTEGER, INTENT(in) :: kt ! ocean time step index … … 364 450 !!---------------------------------------------------------------------- 365 451 452 ! ! allocate dia_ptr arrays 453 IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate arrays' ) 454 366 455 REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters 367 456 READ ( numnam, namptr ) … … 388 477 IF( .NOT. ln_diaptr ) THEN ! diaptr not used 389 478 RETURN 390 ELSE ! Allocate the diaptr arrays391 ALLOCATE( btmsk(jpi,jpj,nptr) , &392 & htr_adv(jpj) , str_adv(jpj) , htr_ldf(jpj) , str_ldf(jpj) , htr_ove(jpj) , str_ove(jpj), &393 & htr(jpj,nptr) , str(jpj,nptr) , &394 & tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &395 & sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr )396 !397 IF( ierr > 0 ) THEN398 CALL ctl_stop( 'dia_ptr_init : unable to allocate standard arrays' ) ; RETURN399 ENDIF400 #if defined key_diaeiv401 !! IF( lk_diaeiv ) & ! eddy induced velocity arrays402 ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , v_msf_eiv(jpj,jpk,nptr) , STAT=ierr )403 !404 IF( ierr > 0 ) THEN405 CALL ctl_stop( 'dia_ptr_init : unable to allocate eiv arrays' ) ; RETURN406 ENDIF407 #endif408 479 ENDIF 409 480 410 IF( lk_mpp ) CALL mpp_ini_znl ! Define MPI communicator for zonal sum481 IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum 411 482 412 483 IF( ln_subbas ) THEN ! load sub-basin mask … … 460 531 !! ** Method : NetCDF file 461 532 !!---------------------------------------------------------------------- 533 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 534 USE wrk_nemo, ONLY: zphi => wrk_1d_1, zfoo => wrk_1d_2 ! 1D workspace 535 USE wrk_nemo, ONLY: z_1 => wrk_2d_1 ! 2D - 536 !! 462 537 INTEGER, INTENT(in) :: kt ! ocean time-step index 463 538 !! 464 539 INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw 465 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 466 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 467 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 468 INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc 469 INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30 470 INTEGER, SAVE, DIMENSION (jpj) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 471 !! 472 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 473 INTEGER :: iline, it, itmod, ji, jj, jk ! 540 INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc 541 INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30 542 INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 543 !! 544 CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names 545 INTEGER :: iline, it, itmod, ji, jj, jk ! 474 546 #if defined key_iomput 475 INTEGER :: inum ! temporary logical unit 476 #endif 477 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 478 REAL(wp), DIMENSION(jpj) :: zphi, zfoo 479 REAL(wp), DIMENSION(jpj,jpk) :: z_1 480 !!---------------------------------------------------------------------- 547 INTEGER :: inum ! temporary logical unit 548 #endif 549 REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars 550 !!---------------------------------------------------------------------- 551 552 IF( wrk_in_use(1, 1,2) .OR. wrk_in_use(2, 1) ) THEN 553 CALL ctl_stop('dia_ptr_wri: requested workspace arrays unavailable') ; RETURN 554 ENDIF 481 555 482 556 ! define time axis … … 507 581 IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole 508 582 IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole 509 zphi( :) = 0._wp583 zphi(1:jpj) = 0._wp 510 584 DO ji = mi0(iline), mi1(iline) 511 zphi( :) = gphiv(ji,:) ! if iline is in the local domain585 zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain 512 586 ! Correct highest latitude for some configurations - will work if domain is parallelized in J ? 513 587 IF( jp_cfg == 05 ) THEN … … 533 607 ELSE ! OTHER configurations 534 608 ! ! ======================= 535 zphi( :) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line609 zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line 536 610 ! 537 611 ENDIF … … 555 629 556 630 zout = nn_fwri * zdt 557 zfoo(:) = 0._wp 558 559 ! Compute julian date from starting date of the run 560 561 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) 562 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 631 zfoo(1:jpj) = 0._wp 632 633 CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run 634 zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment 563 635 564 636 #if defined key_iomput … … 583 655 CALL histvert( numptr, "depthw", "Vertical W levels", & 584 656 & "m", jpk, gdepw_0, ndepidzw, "down" ) 585 586 657 ! 587 658 CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth … … 617 688 cl_comment = ' ' 618 689 #endif 619 ! Zonal mean T and S 620 621 IF( ln_diaznl ) THEN 690 IF( ln_diaznl ) THEN ! Zonal mean T and S 622 691 CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , & 623 692 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) … … 627 696 CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , & 628 697 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 629 698 ! 630 699 IF (ln_subbas) THEN 631 700 CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , & … … 657 726 1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 658 727 ENDIF 659 660 728 ENDIF 661 729 ! 662 730 ! Meridional Stream-Function (Eulerian and Bolus) 663 664 731 CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , & 665 732 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) … … 674 741 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 675 742 ENDIF 676 743 ! 677 744 ! Heat transport 678 679 745 CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , & 680 746 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 695 761 "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 696 762 ENDIF 697 698 763 ! 699 764 ! Salt transport 700 701 765 CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , & 702 766 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) … … 726 790 "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 727 791 ENDIF 728 792 ! 729 793 CALL histend( numptr ) 730 794 ! 731 795 END IF 732 796 #if defined key_mpp_mpi … … 802 866 ENDIF 803 867 ! 804 END SUBROUTINE dia_ptr_wri 868 IF( wrk_not_released(1, 1,2) .OR. & 869 wrk_not_released(2, 1) ) CALL ctl_stop('dia_ptr_wri: failed to release workspace arrays') 870 ! 871 END SUBROUTINE dia_ptr_wri 805 872 806 873 !!======================================================================
Note: See TracChangeset
for help on using the changeset viewer.
