Changeset 945 for trunk/NEMO/TOP_SRC/prtctl_trc.F90
- Timestamp:
- 2008-05-14T18:14:53+02:00 (16 years ago)
- File:
-
- 1 edited
-
trunk/NEMO/TOP_SRC/prtctl_trc.F90 (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/TOP_SRC/prtctl_trc.F90
r719 r945 1 1 MODULE prtctl_trc 2 !!============================================================================== 3 !! *** MODULE prtctl *** 4 !! Ocean system : print all SUM trends for each processor domain 5 !!============================================================================== 6 #if defined key_passivetrc 7 8 USE par_trc_trp 2 !!====================================================================== 3 !! *** MODULE prtctl_trc *** 4 !! TOP : print all SUM trends for each processor domain 5 !!====================================================================== 6 !! History : - ! 2005-07 (C. Talandier) original code for OPA 7 !! 1.0 ! 2005-10 (C. Ethe ) adapted to passive tracer 8 !!---------------------------------------------------------------------- 9 #if defined key_top 10 !!---------------------------------------------------------------------- 11 !! 'key_top' TOP models 12 !!---------------------------------------------------------------------- 13 !! prt_ctl_trc : control print in mpp for passive tracers 14 !! prt_ctl_trc_info : ??? 15 !! prt_ctl_trc_init : ??? 16 !!---------------------------------------------------------------------- 17 USE par_trc ! TOP parameters 9 18 USE oce_trc ! ocean space and time domain variables 10 19 USE in_out_manager ! I/O manager … … 14 23 PRIVATE 15 24 16 !! * Module declaration 17 INTEGER, DIMENSION(:), ALLOCATABLE :: numid_trc ! logical unit 18 INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: & !: 19 nlditl , nldjtl , & !: first, last indoor index for each i-domain 20 nleitl , nlejtl , & !: first, last indoor index for each j-domain 21 nimpptl, njmpptl, & !: i-, j-indexes for each processor 22 nlcitl , nlcjtl , & !: dimensions of every subdomain 23 ibonitl, ibonjtl 24 25 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & !: 26 tra_ctl !: previous trend values 27 28 !! * Routine accessibility 25 INTEGER , DIMENSION(:), ALLOCATABLE :: numid_trc !: logical unit 26 INTEGER , DIMENSION(:), ALLOCATABLE :: nlditl , nldjtl !: first, last indoor index for each i-domain 27 INTEGER , DIMENSION(:), ALLOCATABLE :: nleitl , nlejtl !: first, last indoor index for each j-domain 28 INTEGER , DIMENSION(:), ALLOCATABLE :: nimpptl, njmpptl !: i-, j-indexes for each processor 29 INTEGER , DIMENSION(:), ALLOCATABLE :: nlcitl , nlcjtl !: dimensions of every subdomain 30 INTEGER , DIMENSION(:), ALLOCATABLE :: ibonitl, ibonjtl 31 32 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tra_ctl !: previous trend values 33 29 34 PUBLIC prt_ctl_trc ! called by all subroutines 30 35 PUBLIC prt_ctl_trc_info ! 31 36 PUBLIC prt_ctl_trc_init ! called by opa.F90 32 !!---------------------------------------------------------------------- 33 !! OPA 9.0 , LOCEAN-IPSL (2005)34 !! $Header$35 !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt36 !! ----------------------------------------------------------------------37 37 38 !!---------------------------------------------------------------------- 39 !! NEMO/TOP 1.0 , LOCEAN-IPSL (2005) 40 !! $Header:$ 41 !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 42 !!---------------------------------------------------------------------- 38 43 39 44 CONTAINS 40 45 41 SUBROUTINE prt_ctl_trc (tab4d, mask, clinfo, ovlap, kdim, clinfo2)46 SUBROUTINE prt_ctl_trc( tab4d, mask, clinfo, ovlap, kdim, clinfo2 ) 42 47 !!---------------------------------------------------------------------- 43 48 !! *** ROUTINE prt_ctl *** … … 61 66 !! name must be explicitly typed if used. For instance if the mask 62 67 !! array tmask(:,:,:) must be passed through the prt_ctl subroutine, 63 !! it must looks like: CALL prt_ctl(mask=tmask). 64 !! 65 !! tab4d : 4D array 66 !! mask : mask (3D) to apply to the tab4d array 67 !! clinfo : information about the tab3d array 68 !! ovlap : overlap value 69 !! kdim : k- direction for 4D arrays 70 !! 71 !! History : 72 !! 9.0 ! 05-07 (C. Talandier) original code 73 !! ! 05-10 (C. Ethe ) adapted to passive tracer 74 !!---------------------------------------------------------------------- 75 !! * Arguments 76 REAL(wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d 77 REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask 78 CHARACTER (len=*), DIMENSION(:), INTENT(in), OPTIONAL :: clinfo 79 CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2 80 INTEGER, INTENT(in), OPTIONAL :: ovlap 81 INTEGER, INTENT(in), OPTIONAL :: kdim 82 83 !! * Local declarations 84 INTEGER :: overlap, jn, js, sind, eind, kdir, j_id 85 REAL(wp) :: zsum, zvctl 86 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, ztab3d 87 CHARACTER (len=20), DIMENSION(jptra) :: cl 88 CHARACTER (len=10) :: cl2 89 !!---------------------------------------------------------------------- 90 91 ! Arrays, scalars initialization 68 !! it must looks like: CALL prt_ctl( mask=tmask ). 69 !!---------------------------------------------------------------------- 70 REAL(wp) , DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d ! 4D array 71 REAL(wp) , DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask ! 3D mask to apply to the tab4d array 72 CHARACTER (len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array 73 CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 ! ??? 74 INTEGER , INTENT(in), OPTIONAL :: ovlap ! overlap value 75 INTEGER , INTENT(in), OPTIONAL :: kdim ! k- direction for 4D arrays 76 !! 77 INTEGER :: overlap, jn, js, sind, eind, kdir, j_id 78 REAL(wp) :: zsum, zvctl 79 REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, ztab3d 80 CHARACTER (len=20), DIMENSION(jptra) :: cl 81 CHARACTER (len=10) :: cl2 82 !!---------------------------------------------------------------------- 83 84 ! ! Arrays, scalars initialization 92 85 overlap = 0 93 86 kdir = jpkm1 … … 99 92 zmask (:,:,:) = 1.e0 100 93 101 ! Control of optional arguments 102 103 IF( PRESENT(ovlap) ) overlap = ovlap 104 IF( PRESENT(kdim) ) kdir = kdim 105 IF( PRESENT(clinfo ) ) cl(:) = clinfo(:) 106 IF( PRESENT(clinfo2) ) cl2 = clinfo2 107 IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:) 108 109 IF( lk_mpp ) THEN 110 ! processor number 94 ! ! Control of optional arguments 95 IF( PRESENT(ovlap) ) overlap = ovlap 96 IF( PRESENT(kdim) ) kdir = kdim 97 IF( PRESENT(clinfo ) ) cl(:) = clinfo(:) 98 IF( PRESENT(clinfo2) ) cl2 = clinfo2 99 IF( PRESENT(mask) ) zmask (:,:,:) = mask(:,:,:) 100 101 IF( lk_mpp ) THEN ! processor number 111 102 sind = narea 112 103 eind = narea 113 ELSE 114 ! processors total number 104 ELSE ! processors total number 115 105 sind = 1 116 106 eind = ijsplt … … 119 109 ! Loop over each sub-domain, i.e. the total number of processors ijsplt 120 110 DO js = sind, eind 121 111 ! 122 112 ! Set logical unit 123 j_id = numid_trc( js - narea + 1)113 j_id = numid_trc( js - narea + 1 ) 124 114 ! Set indices for the SUM control 125 115 IF( .NOT. lsp_area ) THEN … … 130 120 njctle = nlejtl(js) + overlap * MIN( 1, nlcjtl(js) - nlejtl(js)) 131 121 ! Do not take into account the bound of the domain 132 IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX(2, nictls)133 IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN(nictle, nleitl(js) - 1)134 IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX(2, njctls)135 IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN(njctle, nlejtl(js) - 1)122 IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls ) 123 IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nleitl(js) - 1 ) 124 IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls ) 125 IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, nlejtl(js) - 1 ) 136 126 ELSE 137 127 nictls = MAX( 1, nimpptl(js) + nlditl(js) - 1 - overlap ) … … 140 130 njctle = njmpptl(js) + nlejtl(js) - 1 + overlap * MIN( 1, nlcjtl(js) - nlejtl(js) ) 141 131 ! Do not take into account the bound of the domain 142 IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX(2, nictls)143 IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX(2, njctls)144 IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN(nictle, nimpptl(js) + nleitl(js) - 2)145 IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN(njctle, njmpptl(js) + nlejtl(js) - 2)132 IF( ibonitl(js) == -1 .OR. ibonitl(js) == 2 ) nictls = MAX( 2, nictls ) 133 IF( ibonjtl(js) == -1 .OR. ibonjtl(js) == 2 ) njctls = MAX( 2, njctls ) 134 IF( ibonitl(js) == 1 .OR. ibonitl(js) == 2 ) nictle = MIN( nictle, nimpptl(js) + nleitl(js) - 2 ) 135 IF( ibonjtl(js) == 1 .OR. ibonjtl(js) == 2 ) njctle = MIN( njctle, njmpptl(js) + nlejtl(js) - 2 ) 146 136 ENDIF 147 137 ENDIF 148 138 ! 149 139 IF( PRESENT(clinfo2) ) THEN 150 140 DO jn = 1, jptra 151 141 zvctl = tra_ctl(jn,js) 152 142 ztab3d(:,:,:) = tab4d(:,:,:,jn) 153 zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &154 & *zmask(nictls:nictle,njctls:njctle,1:kdir) )143 zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) & 144 & * zmask(nictls:nictle,njctls:njctle,1:kdir) ) 155 145 WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum-zvctl 156 146 tra_ctl(jn,js) = zsum 157 END DO147 END DO 158 148 ELSE 159 149 DO jn = 1, jptra 160 150 ztab3d(:,:,:) = tab4d(:,:,:,jn) 161 zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) &162 & * zmask(nictls:nictle,njctls:njctle,1:kdir) )151 zsum = SUM( ztab3d(nictls:nictle,njctls:njctle,1:kdir) & 152 & * zmask(nictls:nictle,njctls:njctle,1:kdir) ) 163 153 WRITE(j_id,FMT="(3x,a,' : ',D23.16)") cl(jn), zsum 164 154 END DO 165 155 ENDIF 166 167 168 ENDDO 169 156 ! 157 END DO 158 ! 170 159 END SUBROUTINE prt_ctl_trc 171 160 172 SUBROUTINE prt_ctl_trc_info (clinfo) 161 162 SUBROUTINE prt_ctl_trc_info( clinfo ) 173 163 !!---------------------------------------------------------------------- 174 164 !! *** ROUTINE prt_ctl_trc_info *** 175 165 !! 176 166 !! ** Purpose : - print information without any computation 177 !! 178 !! ** Action : - input arguments 179 !! clinfo : information to print 180 !! 181 !! History : 182 !! 9.0 ! 05-07 (C. Talandier) original code 183 !!---------------------------------------------------------------------- 184 !! * Arguments 185 CHARACTER (len=*), INTENT(in) :: clinfo 186 187 !! * Local declarations 188 INTEGER :: js, sind, eind, j_id 189 !!---------------------------------------------------------------------- 190 191 IF( lk_mpp ) THEN 192 ! processor number 167 !!---------------------------------------------------------------------- 168 CHARACTER (len=*), INTENT(in) :: clinfo ! information to print 169 !! 170 INTEGER :: js, sind, eind, j_id 171 !!---------------------------------------------------------------------- 172 173 IF( lk_mpp ) THEN ! processor number 193 174 sind = narea 194 175 eind = narea 195 ELSE 196 ! total number of processors 176 ELSE ! total number of processors 197 177 sind = 1 198 178 eind = ijsplt … … 202 182 DO js = sind, eind 203 183 j_id = numid_trc(js - narea + 1) 204 WRITE(j_id,*)clinfo 205 ENDDO 206 207 184 WRITE(j_id,*) clinfo 185 END DO 186 ! 208 187 END SUBROUTINE prt_ctl_trc_info 209 188 189 210 190 SUBROUTINE prt_ctl_trc_init 211 191 !!---------------------------------------------------------------------- … … 213 193 !! 214 194 !! ** Purpose : open ASCII files & compute indices 215 !! 216 !! History : 217 !! 9.0 ! 05-07 (C. Talandier) original code 218 !! ! 05-10 (C. Ethe ) adapted to passive tracer 219 !!---------------------------------------------------------------------- 220 !! * Local declarations 221 INTEGER :: js, sind, eind, j_id 195 !!---------------------------------------------------------------------- 196 INTEGER :: js, sind, eind, j_id 222 197 CHARACTER (len=31) :: clfile_out 223 198 CHARACTER (len=27) :: clb_name … … 225 200 !!---------------------------------------------------------------------- 226 201 227 ! Allocate arrays 228 ALLOCATE(nlditl (ijsplt)) 229 ALLOCATE(nldjtl (ijsplt)) 230 ALLOCATE(nleitl (ijsplt)) 231 ALLOCATE(nlejtl (ijsplt)) 232 ALLOCATE(nimpptl(ijsplt)) 233 ALLOCATE(njmpptl(ijsplt)) 234 ALLOCATE(nlcitl (ijsplt)) 235 ALLOCATE(nlcjtl (ijsplt)) 236 ALLOCATE(tra_ctl(jptra,ijsplt)) 237 ALLOCATE(ibonitl(ijsplt)) 238 ALLOCATE(ibonjtl(ijsplt)) 239 240 ! Initialization 241 tra_ctl (:,:)=0.e0 202 ! ! Allocate arrays 203 ALLOCATE( nlditl (ijsplt) ) 204 ALLOCATE( nldjtl (ijsplt) ) 205 ALLOCATE( nleitl (ijsplt) ) 206 ALLOCATE( nlejtl (ijsplt) ) 207 ALLOCATE( nimpptl(ijsplt) ) 208 ALLOCATE( njmpptl(ijsplt) ) 209 ALLOCATE( nlcitl (ijsplt) ) 210 ALLOCATE( nlcjtl (ijsplt) ) 211 ALLOCATE( tra_ctl(jptra,ijsplt) ) 212 ALLOCATE( ibonitl(ijsplt) ) 213 ALLOCATE( ibonjtl(ijsplt) ) 214 215 tra_ctl(:,:) = 0.e0 ! Initialization to zero 242 216 243 217 IF( lk_mpp ) THEN … … 264 238 eind = ijsplt 265 239 clb_name = "('mono.top.output_',I3.3)" 266 cl_run = 'MONO processor run '240 cl_run = 'MONO processor run ' 267 241 ! compute indices for each area as done in mpp_init subroutine 268 242 CALL sub_dom 269 243 ENDIF 270 244 271 ALLOCATE( numid_trc(eind-sind+1))245 ALLOCATE( numid_trc(eind-sind+1) ) 272 246 273 247 DO js = sind, eind … … 278 252 WRITE(j_id,*) 279 253 WRITE(j_id,*) ' L O D Y C - I P S L' 280 WRITE(j_id,*) ' O P A model'254 WRITE(j_id,*) ' N E M 0 ' 281 255 WRITE(j_id,*) ' Ocean General Circulation Model' 282 WRITE(j_id,*) ' version OPA 9.0 (2005) '256 WRITE(j_id,*) ' version TOP 1.0 (2005) ' 283 257 WRITE(j_id,*) 284 258 WRITE(j_id,*) ' PROC number: ', js 285 259 WRITE(j_id,*) 286 WRITE(j_id,FMT="(19x,a20)") cl_run260 WRITE(j_id,FMT="(19x,a20)") cl_run 287 261 288 262 ! Print the SUM control indices … … 324 298 9003 FORMAT(a20,i4.4,a17,i4.4) 325 299 9004 FORMAT(a11,i4.4,a26,i4.4,a14) 326 END DO327 300 END DO 301 ! 328 302 END SUBROUTINE prt_ctl_trc_init 329 303 … … 358 332 !! nbondil : mark for "east-west local boundary" 359 333 !! nbondjl : mark for "north-south local boundary" 360 !! 361 !! History : 362 !! ! 94-11 (M. Guyon) Original code 363 !! ! 95-04 (J. Escobar, M. Imbard) 364 !! ! 98-02 (M. Guyon) FETI method 365 !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions 366 !! 8.5 ! 02-08 (G. Madec) F90 : free form 367 !!---------------------------------------------------------------------- 368 !! * Local variables 334 !!---------------------------------------------------------------------- 369 335 INTEGER :: ji, jj, js ! dummy loop indices 370 INTEGER :: & 371 ii, ij, & ! temporary integers 372 irestil, irestjl, & ! " " 373 ijpi , ijpj, nlcil, & ! temporary logical unit 374 nlcjl , nbondil, nbondjl, & 375 nrecil, nrecjl, nldil, nleil, nldjl, nlejl 376 377 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 378 iimpptl, ijmpptl, ilcitl, ilcjtl ! temporary workspace 336 INTEGER :: ii, ij ! temporary integers 337 INTEGER :: irestil, irestjl ! " " 338 INTEGER :: ijpi , ijpj, nlcil ! temporary logical unit 339 INTEGER :: nlcjl , nbondil, nbondjl 340 INTEGER :: nrecil, nrecjl, nldil, nleil, nldjl, nlejl 379 341 REAL(wp) :: zidom, zjdom ! temporary scalars 380 !!---------------------------------------------------------------------- 381 382 ! 1. Dimension arrays for subdomains 383 ! ----------------------------------- 342 INTEGER, DIMENSION(:,:), ALLOCATABLE :: iimpptl, ijmpptl, ilcitl, ilcjtl ! temporary workspace 343 !!---------------------------------------------------------------------- 344 345 ! Dimension arrays for subdomains 346 ! ------------------------------- 384 347 ! Computation of local domain sizes ilcitl() ilcjtl() 385 348 ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo … … 391 354 ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj 392 355 393 ALLOCATE( ilcitl (isplt,jsplt))394 ALLOCATE( ilcjtl (isplt,jsplt))356 ALLOCATE( ilcitl (isplt,jsplt) ) 357 ALLOCATE( ilcjtl (isplt,jsplt) ) 395 358 396 359 nrecil = 2 * jpreci … … 429 392 END DO 430 393 431 ! 2.Index arrays for subdomains432 ! --------------------------- ----433 434 ALLOCATE( iimpptl(isplt,jsplt))435 ALLOCATE( ijmpptl(isplt,jsplt))394 ! Index arrays for subdomains 395 ! --------------------------- 396 397 ALLOCATE( iimpptl(isplt,jsplt) ) 398 ALLOCATE( ijmpptl(isplt,jsplt) ) 436 399 437 400 iimpptl(:,:) = 1 … … 454 417 ENDIF 455 418 456 ! 3.Subdomain description457 ! --------------------- ---419 ! Subdomain description 420 ! --------------------- 458 421 459 422 DO js = 1, ijsplt … … 492 455 END DO 493 456 494 DEALLOCATE( iimpptl)495 DEALLOCATE( ijmpptl)496 DEALLOCATE( ilcitl)497 DEALLOCATE( ilcjtl)498 457 DEALLOCATE( iimpptl ) 458 DEALLOCATE( ijmpptl ) 459 DEALLOCATE( ilcitl ) 460 DEALLOCATE( ilcjtl ) 461 ! 499 462 END SUBROUTINE sub_dom 500 463 501 464 #else 502 465 !!---------------------------------------------------------------------- 503 !! Dummy module : NO passive tracer466 !! Dummy module : NO passive tracer 504 467 !!---------------------------------------------------------------------- 505 468 #endif 506 469 507 470 !!====================================================================== 508 509 471 END MODULE prtctl_trc
Note: See TracChangeset
for help on using the changeset viewer.
