prtctl.F90 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586
  1. MODULE prtctl
  2. !!======================================================================
  3. !! *** MODULE prtctl ***
  4. !! Ocean system : print all SUM trends for each processor domain
  5. !!======================================================================
  6. !! History : 9.0 ! 05-07 (C. Talandier) original code
  7. !! 3.4 ! 11-11 (C. Harris) decomposition changes for running with CICE
  8. !!----------------------------------------------------------------------
  9. USE dom_oce ! ocean space and time domain variables
  10. #if defined key_nemocice_decomp
  11. USE ice_domain_size, only: nx_global, ny_global
  12. #endif
  13. USE in_out_manager ! I/O manager
  14. USE lib_mpp ! distributed memory computing
  15. USE wrk_nemo ! work arrays
  16. IMPLICIT NONE
  17. PRIVATE
  18. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid
  19. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain
  20. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain
  21. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor
  22. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain
  23. INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl !
  24. REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values
  25. REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values
  26. INTEGER :: ktime ! time step
  27. PUBLIC prt_ctl ! called by all subroutines
  28. PUBLIC prt_ctl_info ! called by all subroutines
  29. PUBLIC prt_ctl_init ! called by opa.F90
  30. PUBLIC sub_dom ! called by opa.F90
  31. !!----------------------------------------------------------------------
  32. !! NEMO/OPA 3.3 , NEMO Consortium (2010)
  33. !! $Id: prtctl.F90 4520 2014-02-28 11:44:02Z acc $
  34. !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
  35. !!----------------------------------------------------------------------
  36. CONTAINS
  37. SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, &
  38. & mask2, clinfo2, ovlap, kdim, clinfo3 )
  39. !!----------------------------------------------------------------------
  40. !! *** ROUTINE prt_ctl ***
  41. !!
  42. !! ** Purpose : - print sum control of 2D or 3D arrays over the same area
  43. !! in mono and mpp case. This way can be usefull when
  44. !! debugging a new parametrization in mono or mpp.
  45. !!
  46. !! ** Method : 2 possibilities exist when setting the ln_ctl parameter to
  47. !! .true. in the ocean namelist:
  48. !! - to debug a MPI run .vs. a mono-processor one;
  49. !! the control print will be done over each sub-domain.
  50. !! The nictl[se] and njctl[se] parameters in the namelist must
  51. !! be set to zero and [ij]splt to the corresponding splitted
  52. !! domain in MPI along respectively i-, j- directions.
  53. !! - to debug a mono-processor run over the whole domain/a specific area;
  54. !! in the first case the nictl[se] and njctl[se] parameters must be set
  55. !! to zero else to the indices of the area to be controled. In both cases
  56. !! isplt and jsplt must be set to 1.
  57. !! - All arguments of the above calling sequence are optional so their
  58. !! name must be explicitly typed if used. For instance if the 3D
  59. !! array tn(:,:,:) must be passed through the prt_ctl subroutine,
  60. !! it must looks like: CALL prt_ctl(tab3d_1=tn).
  61. !!
  62. !! tab2d_1 : first 2D array
  63. !! tab3d_1 : first 3D array
  64. !! mask1 : mask (3D) to apply to the tab[23]d_1 array
  65. !! clinfo1 : information about the tab[23]d_1 array
  66. !! tab2d_2 : second 2D array
  67. !! tab3d_2 : second 3D array
  68. !! mask2 : mask (3D) to apply to the tab[23]d_2 array
  69. !! clinfo2 : information about the tab[23]d_2 array
  70. !! ovlap : overlap value
  71. !! kdim : k- direction for 3D arrays
  72. !! clinfo3 : additional information
  73. !!----------------------------------------------------------------------
  74. REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
  75. REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1
  76. REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1
  77. CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1
  78. REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
  79. REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2
  80. REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2
  81. CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2
  82. INTEGER , INTENT(in), OPTIONAL :: ovlap
  83. INTEGER , INTENT(in), OPTIONAL :: kdim
  84. CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3
  85. !
  86. CHARACTER (len=15) :: cl2
  87. INTEGER :: overlap, jn, sind, eind, kdir,j_id
  88. REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2
  89. REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d_1, ztab2d_2
  90. REAL(wp), POINTER, DIMENSION(:,:,:) :: zmask1, zmask2, ztab3d_1, ztab3d_2
  91. !!----------------------------------------------------------------------
  92. CALL wrk_alloc( jpi,jpj, ztab2d_1, ztab2d_2 )
  93. CALL wrk_alloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
  94. ! Arrays, scalars initialization
  95. overlap = 0
  96. kdir = jpkm1
  97. cl2 = ''
  98. zsum1 = 0.e0
  99. zsum2 = 0.e0
  100. zvctl1 = 0.e0
  101. zvctl2 = 0.e0
  102. ztab2d_1(:,:) = 0.e0
  103. ztab2d_2(:,:) = 0.e0
  104. ztab3d_1(:,:,:) = 0.e0
  105. ztab3d_2(:,:,:) = 0.e0
  106. zmask1 (:,:,:) = 1.e0
  107. zmask2 (:,:,:) = 1.e0
  108. ! Control of optional arguments
  109. IF( PRESENT(clinfo2) ) cl2 = clinfo2
  110. IF( PRESENT(ovlap) ) overlap = ovlap
  111. IF( PRESENT(kdim) ) kdir = kdim
  112. IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:)
  113. IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:)
  114. IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir)
  115. IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir)
  116. IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:)
  117. IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:)
  118. IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
  119. sind = narea
  120. eind = narea
  121. ELSE ! processors total number
  122. sind = 1
  123. eind = ijsplt
  124. ENDIF
  125. ! Loop over each sub-domain, i.e. the total number of processors ijsplt
  126. DO jn = sind, eind
  127. ! Set logical unit
  128. j_id = numid(jn - narea + 1)
  129. ! Set indices for the SUM control
  130. IF( .NOT. lsp_area ) THEN
  131. IF (lk_mpp .AND. jpnij > 1) THEN
  132. nictls = MAX( 1, nlditl(jn) - overlap )
  133. nictle = nleitl(jn) + overlap * MIN( 1, nlcitl(jn) - nleitl(jn))
  134. njctls = MAX( 1, nldjtl(jn) - overlap )
  135. njctle = nlejtl(jn) + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn))
  136. ! Do not take into account the bound of the domain
  137. IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
  138. IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
  139. IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1)
  140. IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1)
  141. ELSE
  142. nictls = MAX( 1, nimpptl(jn) + nlditl(jn) - 1 - overlap )
  143. nictle = nimpptl(jn) + nleitl(jn) - 1 + overlap * MIN( 1, nlcitl(jn) - nleitl(jn) )
  144. njctls = MAX( 1, njmpptl(jn) + nldjtl(jn) - 1 - overlap )
  145. njctle = njmpptl(jn) + nlejtl(jn) - 1 + overlap * MIN( 1, nlcjtl(jn) - nlejtl(jn) )
  146. ! Do not take into account the bound of the domain
  147. IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls)
  148. IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls)
  149. IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2)
  150. IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2)
  151. ENDIF
  152. ENDIF
  153. IF( PRESENT(clinfo3)) THEN
  154. IF ( clinfo3 == 'tra' ) THEN
  155. zvctl1 = t_ctll(jn)
  156. zvctl2 = s_ctll(jn)
  157. ELSEIF ( clinfo3 == 'dyn' ) THEN
  158. zvctl1 = u_ctll(jn)
  159. zvctl2 = v_ctll(jn)
  160. ENDIF
  161. ENDIF
  162. ! Compute the sum control
  163. ! 2D arrays
  164. IF( PRESENT(tab2d_1) ) THEN
  165. zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) )
  166. zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) )
  167. ENDIF
  168. ! 3D arrays
  169. IF( PRESENT(tab3d_1) ) THEN
  170. zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) )
  171. zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) )
  172. ENDIF
  173. ! Print the result
  174. IF( PRESENT(clinfo3) ) THEN
  175. WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2
  176. SELECT CASE( clinfo3 )
  177. CASE ( 'tra-ta' )
  178. t_ctll(jn) = zsum1
  179. CASE ( 'tra' )
  180. t_ctll(jn) = zsum1
  181. s_ctll(jn) = zsum2
  182. CASE ( 'dyn' )
  183. u_ctll(jn) = zsum1
  184. v_ctll(jn) = zsum2
  185. END SELECT
  186. ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN
  187. WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2
  188. ELSE
  189. WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1
  190. ENDIF
  191. ENDDO
  192. CALL wrk_dealloc( jpi,jpj, ztab2d_1, ztab2d_2 )
  193. CALL wrk_dealloc( jpi,jpj,jpk, zmask1, zmask2, ztab3d_1, ztab3d_2 )
  194. !
  195. END SUBROUTINE prt_ctl
  196. SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime)
  197. !!----------------------------------------------------------------------
  198. !! *** ROUTINE prt_ctl_info ***
  199. !!
  200. !! ** Purpose : - print information without any computation
  201. !!
  202. !! ** Action : - input arguments
  203. !! clinfo1 : information about the ivar1
  204. !! ivar1 : value to print
  205. !! clinfo2 : information about the ivar2
  206. !! ivar2 : value to print
  207. !!----------------------------------------------------------------------
  208. CHARACTER (len=*), INTENT(in) :: clinfo1
  209. INTEGER , INTENT(in), OPTIONAL :: ivar1
  210. CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2
  211. INTEGER , INTENT(in), OPTIONAL :: ivar2
  212. INTEGER , INTENT(in), OPTIONAL :: itime
  213. !
  214. INTEGER :: jn, sind, eind, iltime, j_id
  215. !!----------------------------------------------------------------------
  216. IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number
  217. sind = narea
  218. eind = narea
  219. ELSE ! total number of processors
  220. sind = 1
  221. eind = ijsplt
  222. ENDIF
  223. ! Set to zero arrays at each new time step
  224. IF( PRESENT(itime) ) THEN
  225. iltime = itime
  226. IF( iltime > ktime ) THEN
  227. t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0
  228. u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0
  229. ktime = iltime
  230. ENDIF
  231. ENDIF
  232. ! Loop over each sub-domain, i.e. number of processors ijsplt
  233. DO jn = sind, eind
  234. !
  235. j_id = numid(jn - narea + 1) ! Set logical unit
  236. !
  237. IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
  238. WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2
  239. ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
  240. WRITE(j_id,*)clinfo1, ivar1, clinfo2
  241. ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN
  242. WRITE(j_id,*)clinfo1, ivar1, ivar2
  243. ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN
  244. WRITE(j_id,*)clinfo1, ivar1
  245. ELSE
  246. WRITE(j_id,*)clinfo1
  247. ENDIF
  248. !
  249. END DO
  250. !
  251. END SUBROUTINE prt_ctl_info
  252. SUBROUTINE prt_ctl_init
  253. !!----------------------------------------------------------------------
  254. !! *** ROUTINE prt_ctl_init ***
  255. !!
  256. !! ** Purpose : open ASCII files & compute indices
  257. !!----------------------------------------------------------------------
  258. INTEGER :: jn, sind, eind, j_id
  259. CHARACTER (len=28) :: clfile_out
  260. CHARACTER (len=23) :: clb_name
  261. CHARACTER (len=19) :: cl_run
  262. !!----------------------------------------------------------------------
  263. ! Allocate arrays
  264. ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , &
  265. & nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , &
  266. & nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , &
  267. & nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) )
  268. ! Initialization
  269. t_ctll(:) = 0.e0
  270. s_ctll(:) = 0.e0
  271. u_ctll(:) = 0.e0
  272. v_ctll(:) = 0.e0
  273. ktime = 1
  274. IF( lk_mpp .AND. jpnij > 1 ) THEN
  275. sind = narea
  276. eind = narea
  277. clb_name = "('mpp.output_',I4.4)"
  278. cl_run = 'MULTI processor run'
  279. ! use indices for each area computed by mpp_init subroutine
  280. nlditl(1:jpnij) = nldit(:)
  281. nleitl(1:jpnij) = nleit(:)
  282. nldjtl(1:jpnij) = nldjt(:)
  283. nlejtl(1:jpnij) = nlejt(:)
  284. !
  285. nimpptl(1:jpnij) = nimppt(:)
  286. njmpptl(1:jpnij) = njmppt(:)
  287. !
  288. nlcitl(1:jpnij) = nlcit(:)
  289. nlcjtl(1:jpnij) = nlcjt(:)
  290. !
  291. ibonitl(1:jpnij) = ibonit(:)
  292. ibonjtl(1:jpnij) = ibonjt(:)
  293. ELSE
  294. sind = 1
  295. eind = ijsplt
  296. clb_name = "('mono.output_',I4.4)"
  297. cl_run = 'MONO processor run '
  298. ! compute indices for each area as done in mpp_init subroutine
  299. CALL sub_dom
  300. ENDIF
  301. ALLOCATE( numid(eind-sind+1) )
  302. DO jn = sind, eind
  303. WRITE(clfile_out,FMT=clb_name) jn-1
  304. CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. )
  305. j_id = numid(jn -narea + 1)
  306. WRITE(j_id,*)
  307. WRITE(j_id,*) ' L O D Y C - I P S L'
  308. WRITE(j_id,*) ' O P A model'
  309. WRITE(j_id,*) ' Ocean General Circulation Model'
  310. WRITE(j_id,*) ' version OPA 9.0 (2005) '
  311. WRITE(j_id,*)
  312. WRITE(j_id,*) ' PROC number: ', jn
  313. WRITE(j_id,*)
  314. WRITE(j_id,FMT="(19x,a20)")cl_run
  315. ! Print the SUM control indices
  316. IF( .NOT. lsp_area ) THEN
  317. nictls = nimpptl(jn) + nlditl(jn) - 1
  318. nictle = nimpptl(jn) + nleitl(jn) - 1
  319. njctls = njmpptl(jn) + nldjtl(jn) - 1
  320. njctle = njmpptl(jn) + nlejtl(jn) - 1
  321. ENDIF
  322. WRITE(j_id,*)
  323. WRITE(j_id,*) 'prt_ctl : Sum control indices'
  324. WRITE(j_id,*) '~~~~~~~'
  325. WRITE(j_id,*)
  326. WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' '
  327. WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------'
  328. WRITE(j_id,9001)' | |'
  329. WRITE(j_id,9001)' | |'
  330. WRITE(j_id,9001)' | |'
  331. WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle
  332. WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn)
  333. WRITE(j_id,9001)' | |'
  334. WRITE(j_id,9001)' | |'
  335. WRITE(j_id,9001)' | |'
  336. WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------'
  337. WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' '
  338. WRITE(j_id,*)
  339. WRITE(j_id,*)
  340. 9000 FORMAT(a41,i4.4,a14)
  341. 9001 FORMAT(a59)
  342. 9002 FORMAT(a20,i4.4,a36,i3.3)
  343. 9003 FORMAT(a20,i4.4,a17,i4.4)
  344. 9004 FORMAT(a11,i4.4,a26,i4.4,a14)
  345. END DO
  346. !
  347. END SUBROUTINE prt_ctl_init
  348. SUBROUTINE sub_dom
  349. !!----------------------------------------------------------------------
  350. !! *** ROUTINE sub_dom ***
  351. !!
  352. !! ** Purpose : Lay out the global domain over processors.
  353. !! CAUTION:
  354. !! This part has been extracted from the mpp_init
  355. !! subroutine and names of variables/arrays have been
  356. !! slightly changed to avoid confusion but the computation
  357. !! is exactly the same. Any modification about indices of
  358. !! each sub-domain in the mppini.F90 module should be reported
  359. !! here.
  360. !!
  361. !! ** Method : Global domain is distributed in smaller local domains.
  362. !! Periodic condition is a function of the local domain position
  363. !! (global boundary or neighbouring domain) and of the global
  364. !! periodic
  365. !! Type : jperio global periodic condition
  366. !! nperio local periodic condition
  367. !!
  368. !! ** Action : - set domain parameters
  369. !! nimpp : longitudinal index
  370. !! njmpp : latitudinal index
  371. !! nperio : lateral condition type
  372. !! narea : number for local area
  373. !! nlcil : first dimension
  374. !! nlcjl : second dimension
  375. !! nbondil : mark for "east-west local boundary"
  376. !! nbondjl : mark for "north-south local boundary"
  377. !!
  378. !! History :
  379. !! ! 94-11 (M. Guyon) Original code
  380. !! ! 95-04 (J. Escobar, M. Imbard)
  381. !! ! 98-02 (M. Guyon) FETI method
  382. !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions
  383. !! 8.5 ! 02-08 (G. Madec) F90 : free form
  384. !!----------------------------------------------------------------------
  385. INTEGER :: ji, jj, jn ! dummy loop indices
  386. INTEGER :: &
  387. ii, ij, & ! temporary integers
  388. irestil, irestjl, & ! " "
  389. ijpi , ijpj, nlcil, & ! temporary logical unit
  390. nlcjl , nbondil, nbondjl, &
  391. nrecil, nrecjl, nldil, nleil, nldjl, nlejl
  392. INTEGER, POINTER, DIMENSION(:,:) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace
  393. REAL(wp) :: zidom, zjdom ! temporary scalars
  394. !!----------------------------------------------------------------------
  395. !
  396. CALL wrk_alloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
  397. !
  398. ! 1. Dimension arrays for subdomains
  399. ! -----------------------------------
  400. ! Computation of local domain sizes ilcitl() ilcjtl()
  401. ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo
  402. ! The subdomains are squares leeser than or equal to the global
  403. ! dimensions divided by the number of processors minus the overlap
  404. ! array (cf. par_oce.F90).
  405. #if defined key_nemocice_decomp
  406. ijpi = ( nx_global+2-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
  407. ijpj = ( ny_global+2-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
  408. #else
  409. ijpi = ( jpiglo-2*jpreci + (isplt-1) ) / isplt + 2*jpreci
  410. ijpj = ( jpjglo-2*jprecj + (jsplt-1) ) / jsplt + 2*jprecj
  411. #endif
  412. nrecil = 2 * jpreci
  413. nrecjl = 2 * jprecj
  414. irestil = MOD( jpiglo - nrecil , isplt )
  415. irestjl = MOD( jpjglo - nrecjl , jsplt )
  416. IF( irestil == 0 ) irestil = isplt
  417. #if defined key_nemocice_decomp
  418. ! In order to match CICE the size of domains in NEMO has to be changed
  419. ! The last line of blocks (west) will have fewer points
  420. DO jj = 1, jsplt
  421. DO ji=1, isplt-1
  422. ilcitl(ji,jj) = ijpi
  423. END DO
  424. ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil)
  425. END DO
  426. #else
  427. DO jj = 1, jsplt
  428. DO ji = 1, irestil
  429. ilcitl(ji,jj) = ijpi
  430. END DO
  431. DO ji = irestil+1, isplt
  432. ilcitl(ji,jj) = ijpi -1
  433. END DO
  434. END DO
  435. #endif
  436. IF( irestjl == 0 ) irestjl = jsplt
  437. #if defined key_nemocice_decomp
  438. ! Same change to domains in North-South direction as in East-West.
  439. DO ji = 1, isplt
  440. DO jj=1, jsplt-1
  441. ilcjtl(ji,jj) = ijpj
  442. END DO
  443. ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl)
  444. END DO
  445. #else
  446. DO ji = 1, isplt
  447. DO jj = 1, irestjl
  448. ilcjtl(ji,jj) = ijpj
  449. END DO
  450. DO jj = irestjl+1, jsplt
  451. ilcjtl(ji,jj) = ijpj -1
  452. END DO
  453. END DO
  454. #endif
  455. zidom = nrecil
  456. DO ji = 1, isplt
  457. zidom = zidom + ilcitl(ji,1) - nrecil
  458. END DO
  459. IF(lwp) WRITE(numout,*)
  460. IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo
  461. zjdom = nrecjl
  462. DO jj = 1, jsplt
  463. zjdom = zjdom + ilcjtl(1,jj) - nrecjl
  464. END DO
  465. IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo
  466. IF(lwp) WRITE(numout,*)
  467. ! 2. Index arrays for subdomains
  468. ! -------------------------------
  469. iimpptl(:,:) = 1
  470. ijmpptl(:,:) = 1
  471. IF( isplt > 1 ) THEN
  472. DO jj = 1, jsplt
  473. DO ji = 2, isplt
  474. iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil
  475. END DO
  476. END DO
  477. ENDIF
  478. IF( jsplt > 1 ) THEN
  479. DO jj = 2, jsplt
  480. DO ji = 1, isplt
  481. ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl
  482. END DO
  483. END DO
  484. ENDIF
  485. ! 3. Subdomain description
  486. ! ------------------------
  487. DO jn = 1, ijsplt
  488. ii = 1 + MOD( jn-1, isplt )
  489. ij = 1 + (jn-1) / isplt
  490. nimpptl(jn) = iimpptl(ii,ij)
  491. njmpptl(jn) = ijmpptl(ii,ij)
  492. nlcitl (jn) = ilcitl (ii,ij)
  493. nlcil = nlcitl (jn)
  494. nlcjtl (jn) = ilcjtl (ii,ij)
  495. nlcjl = nlcjtl (jn)
  496. nbondjl = -1 ! general case
  497. IF( jn > isplt ) nbondjl = 0 ! first row of processor
  498. IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor
  499. IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction
  500. ibonjtl(jn) = nbondjl
  501. nbondil = 0 !
  502. IF( MOD( jn, isplt ) == 1 ) nbondil = -1 !
  503. IF( MOD( jn, isplt ) == 0 ) nbondil = 1 !
  504. IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction
  505. ibonitl(jn) = nbondil
  506. nldil = 1 + jpreci
  507. nleil = nlcil - jpreci
  508. IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1
  509. IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil
  510. nldjl = 1 + jprecj
  511. nlejl = nlcjl - jprecj
  512. IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1
  513. IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl
  514. nlditl(jn) = nldil
  515. nleitl(jn) = nleil
  516. nldjtl(jn) = nldjl
  517. nlejtl(jn) = nlejl
  518. END DO
  519. !
  520. !
  521. CALL wrk_dealloc( isplt, jsplt, ilcitl, ilcjtl, iimpptl, ijmpptl )
  522. !
  523. !
  524. END SUBROUTINE sub_dom
  525. !!======================================================================
  526. END MODULE prtctl