PageRenderTime 52ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/wrfv2_fire/external/RSL_LITE/tfp_tester.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 649 lines | 424 code | 78 blank | 147 comment | 1 complexity | 9501901768ec385dc203fc91e292eaf1 MD5 | raw file
Possible License(s): AGPL-1.0
  1. ! to compile this
  2. !
  3. ! g95
  4. ! gcc -c -DF2CSTYLE task_for_point.c ; g95 -ffree-form -ffree-line-length-huge tfp_tester.F task_for_point.o
  5. ! ifort
  6. ! icc -c task_for_point.c ; ifort -FR tfp_tester.F task_for_point.o
  7. ! ibm
  8. ! cc -c -DNOUNDERSCORE task_for_point.c ; xlf -qfree=f90 tfp_tester.F task_for_point.o
  9. MODULE module_driver_constants
  10. ! 0. The following tells the rest of the model what data ordering we are
  11. ! using
  12. INTEGER , PARAMETER :: DATA_ORDER_XYZ = 1
  13. INTEGER , PARAMETER :: DATA_ORDER_YXZ = 2
  14. INTEGER , PARAMETER :: DATA_ORDER_ZXY = 3
  15. INTEGER , PARAMETER :: DATA_ORDER_ZYX = 4
  16. INTEGER , PARAMETER :: DATA_ORDER_XZY = 5
  17. INTEGER , PARAMETER :: DATA_ORDER_YZX = 6
  18. INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ
  19. INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ
  20. !#include <model_data_order.inc>
  21. ! 1. Following are constants for use in defining maximal values for array
  22. ! definitions.
  23. !
  24. ! The maximum number of levels in the model is how deeply the domains may
  25. ! be nested.
  26. INTEGER , PARAMETER :: max_levels = 20
  27. ! The maximum number of nests that can depend on a single parent and other way round
  28. INTEGER , PARAMETER :: max_nests = 20
  29. ! The maximum number of parents that a nest can have (simplified assumption -> one only)
  30. INTEGER , PARAMETER :: max_parents = 1
  31. ! The maximum number of domains is how many grids the model will be running.
  32. #define MAX_DOMAINS_F 10
  33. INTEGER , PARAMETER :: max_domains = ( MAX_DOMAINS_F - 1 ) / 2 + 1
  34. ! The maximum number of nest move specifications allowed in a namelist
  35. INTEGER , PARAMETER :: max_moves = 50
  36. ! The maximum number of eta levels
  37. INTEGER , PARAMETER :: max_eta = 501
  38. ! The maximum number of outer iterations (for DA minimisation)
  39. INTEGER , PARAMETER :: max_outer_iterations = 10
  40. ! The maximum number of instruments (for radiance DA)
  41. INTEGER , PARAMETER :: max_instruments = 30
  42. ! 2. Following related to driver leve data structures for DM_PARALLEL communications
  43. #ifdef DM_PARALLEL
  44. INTEGER , PARAMETER :: max_comms = 1024
  45. #else
  46. INTEGER , PARAMETER :: max_comms = 1
  47. #endif
  48. ! 3. Following is information related to the file I/O.
  49. ! These are the bounds of the available FORTRAN logical unit numbers for the file I/O.
  50. ! Only logical unti numbers within these bounds will be chosen for I/O unit numbers.
  51. INTEGER , PARAMETER :: min_file_unit = 10
  52. INTEGER , PARAMETER :: max_file_unit = 99
  53. ! 4. Unfortunately, the following definition is needed here (rather
  54. ! than the more logical place in share/module_model_constants.F)
  55. ! for the namelist reads in frame/module_configure.F, and for some
  56. ! conversions in share/set_timekeeping.F
  57. ! Actually, using it here will mean that we don't need to set it
  58. ! in share/module_model_constants.F, since this file will be
  59. ! included (USEd) in:
  60. ! frame/module_configure.F
  61. ! which will be USEd in:
  62. ! share/module_bc.F
  63. ! which will be USEd in:
  64. ! phys/module_radiation_driver.F
  65. ! which is the other important place for it to be, and where
  66. ! it is passed as a subroutine parameter to any physics subroutine.
  67. !
  68. ! P2SI is the number of SI seconds in an planetary solar day
  69. ! divided by the number of SI seconds in an earth solar day
  70. #if defined MARS
  71. ! For Mars, P2SI = 88775.2/86400.
  72. REAL , PARAMETER :: P2SI = 1.0274907
  73. #elif defined TITAN
  74. ! For Titan, P2SI = 1378080.0/86400.
  75. REAL , PARAMETER :: P2SI = 15.95
  76. #else
  77. ! Default for Earth
  78. REAL , PARAMETER :: P2SI = 1.0
  79. #endif
  80. CONTAINS
  81. SUBROUTINE init_module_driver_constants
  82. END SUBROUTINE init_module_driver_constants
  83. END MODULE module_driver_constants
  84. MODULE module_machine
  85. USE module_driver_constants
  86. ! Machine characteristics and utilities here.
  87. ! Tile strategy defined constants
  88. INTEGER, PARAMETER :: TILE_X = 1, TILE_Y = 2, TILE_XY = 3
  89. TYPE machine_type
  90. INTEGER :: tile_strategy
  91. END TYPE machine_type
  92. TYPE (machine_type) machine_info
  93. CONTAINS
  94. RECURSIVE SUBROUTINE rlocproc(p,maxi,nproc,ml,mr,ret)
  95. IMPLICIT NONE
  96. INTEGER, INTENT(IN) :: p, maxi, nproc, ml, mr
  97. INTEGER, INTENT(OUT) :: ret
  98. INTEGER :: width, rem, ret2, bl, br, mid, adjust, &
  99. p_r, maxi_r, nproc_r, zero
  100. adjust = 0
  101. rem = mod( maxi, nproc )
  102. width = maxi / nproc
  103. mid = maxi / 2
  104. IF ( rem>0 .AND. (((mod(rem,2).EQ.0).OR.(rem.GT.2)).OR.(p.LE.mid))) THEN
  105. width = width + 1
  106. END IF
  107. IF ( p.LE.mid .AND. mod(rem,2).NE.0 ) THEN
  108. adjust = adjust + 1
  109. END IF
  110. bl = max(width,ml) ;
  111. br = max(width,mr) ;
  112. IF (p<bl) THEN
  113. ret = 0
  114. ELSE IF (p>maxi-br-1) THEN
  115. ret = nproc-1
  116. ELSE
  117. p_r = p - bl
  118. maxi_r = maxi-bl-br+adjust
  119. nproc_r = max(nproc-2,1)
  120. zero = 0
  121. CALL rlocproc( p_r, maxi_r, nproc_r, zero, zero, ret2 ) ! Recursive
  122. ret = ret2 + 1
  123. END IF
  124. RETURN
  125. END SUBROUTINE rlocproc
  126. INTEGER FUNCTION locproc( i, m, numpart )
  127. implicit none
  128. integer, intent(in) :: i, m, numpart
  129. integer :: retval, ii, im, inumpart, zero
  130. ii = i
  131. im = m
  132. inumpart = numpart
  133. zero = 0
  134. CALL rlocproc( ii, im, inumpart, zero, zero, retval )
  135. locproc = retval
  136. RETURN
  137. END FUNCTION locproc
  138. SUBROUTINE patchmap( res, y, x, py, px )
  139. implicit none
  140. INTEGER, INTENT(IN) :: y, x, py, px
  141. INTEGER, DIMENSION(x,y), INTENT(OUT) :: res
  142. INTEGER :: i, j, p_min, p_maj
  143. DO j = 0,y-1
  144. p_maj = locproc( j, y, py )
  145. DO i = 0,x-1
  146. p_min = locproc( i, x, px )
  147. res(i+1,j+1) = p_min + px*p_maj
  148. END DO
  149. END DO
  150. RETURN
  151. END SUBROUTINE patchmap
  152. SUBROUTINE region_bounds( region_start, region_end, &
  153. num_p, p, &
  154. patch_start, patch_end )
  155. ! 1-D decomposition routine: Given starting and ending indices of a
  156. ! vector, the number of patches dividing the vector, and the number of
  157. ! the patch, give the start and ending indices of the patch within the
  158. ! vector. This will work with tiles too. Implementation note. This is
  159. ! implemented somewhat inefficiently, now, with a loop, so we can use the
  160. ! locproc function above, which returns processor number for a given
  161. ! index, whereas what we want is index for a given processor number.
  162. ! With a little thought and a lot of debugging, we can come up with a
  163. ! direct expression for what we want. For time being, we loop...
  164. ! Remember that processor numbering starts with zero.
  165. IMPLICIT NONE
  166. INTEGER, INTENT(IN) :: region_start, region_end, num_p, p
  167. INTEGER, INTENT(OUT) :: patch_start, patch_end
  168. INTEGER :: offset, i
  169. patch_end = -999999999
  170. patch_start = 999999999
  171. offset = region_start
  172. do i = 0, region_end - offset
  173. if ( locproc( i, region_end-region_start+1, num_p ) == p ) then
  174. patch_end = max(patch_end,i)
  175. patch_start = min(patch_start,i)
  176. endif
  177. enddo
  178. patch_start = patch_start + offset
  179. patch_end = patch_end + offset
  180. RETURN
  181. END SUBROUTINE region_bounds
  182. SUBROUTINE least_aspect( nparts, minparts_y, minparts_x, nparts_y, nparts_x )
  183. IMPLICIT NONE
  184. ! Input data.
  185. INTEGER, INTENT(IN) :: nparts, &
  186. minparts_y, minparts_x
  187. ! Output data.
  188. INTEGER, INTENT(OUT) :: nparts_y, nparts_x
  189. ! Local data.
  190. INTEGER :: x, y, mini
  191. mini = 2*nparts
  192. nparts_y = 1
  193. nparts_x = nparts
  194. DO y = 1, nparts
  195. IF ( mod( nparts, y ) .eq. 0 ) THEN
  196. x = nparts / y
  197. IF ( abs( y-x ) .LT. mini &
  198. .AND. y .GE. minparts_y &
  199. .AND. x .GE. minparts_x ) THEN
  200. mini = abs( y-x )
  201. nparts_y = y
  202. nparts_x = x
  203. END IF
  204. END IF
  205. END DO
  206. END SUBROUTINE least_aspect
  207. SUBROUTINE init_module_machine
  208. machine_info%tile_strategy = TILE_Y
  209. END SUBROUTINE init_module_machine
  210. END MODULE module_machine
  211. SUBROUTINE compute_memory_dims_rsl_lite ( &
  212. id , maxhalowidth , &
  213. shw , bdx, bdy , &
  214. ntasks_x, ntasks_y, &
  215. mytask_x, mytask_y, &
  216. ids, ide, jds, jde, kds, kde, &
  217. ims, ime, jms, jme, kms, kme, &
  218. imsx, imex, jmsx, jmex, kmsx, kmex, &
  219. imsy, imey, jmsy, jmey, kmsy, kmey, &
  220. ips, ipe, jps, jpe, kps, kpe, &
  221. ipsx, ipex, jpsx, jpex, kpsx, kpex, &
  222. ipsy, ipey, jpsy, jpey, kpsy, kpey )
  223. USE module_machine
  224. IMPLICIT NONE
  225. INTEGER, INTENT(IN) :: id , maxhalowidth
  226. INTEGER, INTENT(IN) :: shw, bdx, bdy
  227. INTEGER, INTENT(IN) :: ntasks_x, ntasks_y
  228. INTEGER, INTENT(IN) :: mytask_x, mytask_y
  229. INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
  230. INTEGER, INTENT(OUT) :: ims, ime, jms, jme, kms, kme
  231. INTEGER, INTENT(OUT) :: imsx, imex, jmsx, jmex, kmsx, kmex
  232. INTEGER, INTENT(OUT) :: imsy, imey, jmsy, jmey, kmsy, kmey
  233. INTEGER, INTENT(OUT) :: ips, ipe, jps, jpe, kps, kpe
  234. INTEGER, INTENT(OUT) :: ipsx, ipex, jpsx, jpex, kpsx, kpex
  235. INTEGER, INTENT(OUT) :: ipsy, ipey, jpsy, jpey, kpsy, kpey
  236. INTEGER Px, Py, P, i, j, k, ierr
  237. #if ( ! NMM_CORE == 1 )
  238. ! xy decomposition
  239. ips = -1
  240. j = jds
  241. ierr = 0
  242. DO i = ids, ide
  243. CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
  244. maxhalowidth, maxhalowidth, ierr )
  245. IF ( Px .EQ. mytask_x ) THEN
  246. ipe = i
  247. IF ( ips .EQ. -1 ) THEN
  248. ips = i
  249. ENDIF
  250. ENDIF
  251. ENDDO
  252. IF ( ierr .NE. 0 ) THEN
  253. CALL tfp_message(__FILE__,__LINE__)
  254. ENDIF
  255. ! handle setting the memory dimensions where there are no X elements assigned to this proc
  256. IF (ips .EQ. -1 ) THEN
  257. ipe = -1
  258. ips = 0
  259. ENDIF
  260. jps = -1
  261. i = ids
  262. ierr = 0
  263. DO j = jds, jde
  264. CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
  265. maxhalowidth, maxhalowidth, ierr )
  266. IF ( Py .EQ. mytask_y ) THEN
  267. jpe = j
  268. IF ( jps .EQ. -1 ) jps = j
  269. ENDIF
  270. ENDDO
  271. IF ( ierr .NE. 0 ) THEN
  272. CALL tfp_message(__FILE__,__LINE__)
  273. ENDIF
  274. ! handle setting the memory dimensions where there are no Y elements assigned to this proc
  275. IF (jps .EQ. -1 ) THEN
  276. jpe = -1
  277. jps = 0
  278. ENDIF
  279. !begin: wig; 12-Mar-2008
  280. ! This appears redundant with the conditionals above, but we get cases with only
  281. ! one of the directions being set to "missing" when turning off extra processors.
  282. ! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
  283. IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN
  284. ipe = -1
  285. ips = 0
  286. jpe = -1
  287. jps = 0
  288. ENDIF
  289. !end: wig; 12-Mar-2008
  290. !
  291. ! description of transpose decomposition strategy for RSL LITE. 20061231jm
  292. !
  293. ! Here is the tranpose scheme that is implemented for RSL_LITE. Upper-case
  294. ! XY corresponds to the dimension of the processor mesh, lower-case xyz
  295. ! corresponds to grid dimension.
  296. !
  297. ! xy zy zx
  298. !
  299. ! XxYy <--> XzYy <--> XzYx <- note x decomposed over Y procs
  300. ! ^ ^
  301. ! | |
  302. ! +------------------+ <- this edge is costly; see below
  303. !
  304. ! The aim is to avoid all-to-all communication over whole
  305. ! communicator. Instead, when possible, use a transpose scheme that requires
  306. ! all-to-all within dimensional communicators; that is, communicators
  307. ! defined for the processes in a rank or column of the processor mesh. Note,
  308. ! however, it is not possible to create a ring of transposes between
  309. ! xy-yz-xz decompositions without at least one of the edges in the ring
  310. ! being fully all-to-all (in other words, one of the tranpose edges must
  311. ! rotate and not just transpose a plane of the model grid within the
  312. ! processor mesh). The issue is then, where should we put this costly edge
  313. ! in the tranpose scheme we chose? To avoid being completely arbitrary,
  314. ! we chose a scheme most natural for models that use parallel spectral
  315. ! transforms, where the costly edge is the one that goes from the xz to
  316. ! the xy decomposition. (May be implemented as just a two step transpose
  317. ! back through yz).
  318. !
  319. ! Additional notational convention, below. The 'x' or 'y' appended to the
  320. ! dimension start or end variable refers to which grid dimension is all
  321. ! on-processor in the given decomposition. That is ipsx and ipex are the
  322. ! start and end for the i-dimension in the zy decomposition where x is
  323. ! on-processor. ('z' is assumed for xy decomposition and not appended to
  324. ! the ips, ipe, etc. variable names).
  325. !
  326. ! XzYy decomposition
  327. kpsx = -1
  328. j = jds ;
  329. ierr = 0
  330. DO k = kds, kde
  331. CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
  332. 1, maxhalowidth, ierr )
  333. IF ( Px .EQ. mytask_x ) THEN
  334. kpex = k
  335. IF ( kpsx .EQ. -1 ) kpsx = k
  336. ENDIF
  337. ENDDO
  338. IF ( ierr .NE. 0 ) THEN
  339. CALL tfp_message(__FILE__,__LINE__)
  340. ENDIF
  341. ! handle case where no levels are assigned to this process
  342. ! no iterations. Do same for I and J. Need to handle memory alloc below.
  343. IF (kpsx .EQ. -1 ) THEN
  344. kpex = -1
  345. kpsx = 0
  346. ENDIF
  347. jpsx = -1
  348. k = kds ;
  349. ierr = 0
  350. DO j = jds, jde
  351. CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
  352. 1, maxhalowidth, ierr )
  353. IF ( Py .EQ. mytask_y ) THEN
  354. jpex = j
  355. IF ( jpsx .EQ. -1 ) jpsx = j
  356. ENDIF
  357. ENDDO
  358. IF ( ierr .NE. 0 ) THEN
  359. CALL tfp_message(__FILE__,__LINE__)
  360. ENDIF
  361. IF (jpsx .EQ. -1 ) THEN
  362. jpex = -1
  363. jpsx = 0
  364. ENDIF
  365. !begin: wig; 12-Mar-2008
  366. ! This appears redundant with the conditionals above, but we get cases with only
  367. ! one of the directions being set to "missing" when turning off extra processors.
  368. ! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
  369. IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN
  370. ipex = -1
  371. ipsx = 0
  372. jpex = -1
  373. jpsx = 0
  374. ENDIF
  375. !end: wig; 12-Mar-2008
  376. ! XzYx decomposition (note, x grid dim is decomposed over Y processor dim)
  377. kpsy = kpsx ! same as above
  378. kpey = kpex ! same as above
  379. ipsy = -1
  380. k = kds ;
  381. ierr = 0
  382. DO i = ids, ide
  383. CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
  384. maxhalowidth, 1, ierr ) ! x and y for proc mesh reversed
  385. IF ( Py .EQ. mytask_y ) THEN
  386. ipey = i
  387. IF ( ipsy .EQ. -1 ) ipsy = i
  388. ENDIF
  389. ENDDO
  390. IF ( ierr .NE. 0 ) THEN
  391. CALL tfp_message(__FILE__,__LINE__)
  392. ENDIF
  393. IF (ipsy .EQ. -1 ) THEN
  394. ipey = -1
  395. ipsy = 0
  396. ENDIF
  397. #else
  398. ! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
  399. ! adjust decomposition to reflect. 20051020 JM
  400. ips = -1
  401. j = jds
  402. ierr = 0
  403. DO i = ids, ide-1
  404. CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
  405. maxhalowidth, maxhalowidth , ierr )
  406. IF ( Px .EQ. mytask_x ) THEN
  407. ipe = i
  408. IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1
  409. IF ( ips .EQ. -1 ) ips = i
  410. ENDIF
  411. ENDDO
  412. IF ( ierr .NE. 0 ) THEN
  413. CALL tfp_message(__FILE__,__LINE__)
  414. ENDIF
  415. jps = -1
  416. i = ids ;
  417. ierr = 0
  418. DO j = jds, jde-1
  419. CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
  420. maxhalowidth , maxhalowidth , ierr )
  421. IF ( Py .EQ. mytask_y ) THEN
  422. jpe = j
  423. IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1
  424. IF ( jps .EQ. -1 ) jps = j
  425. ENDIF
  426. ENDDO
  427. IF ( ierr .NE. 0 ) THEN
  428. CALL tfp_message(__FILE__,__LINE__)
  429. ENDIF
  430. #endif
  431. ! extend the patch dimensions out shw along edges of domain
  432. IF ( ips < ipe .and. jps < jpe ) THEN !wig; 11-Mar-2008
  433. IF ( mytask_x .EQ. 0 ) THEN
  434. ips = ips - shw
  435. ipsy = ipsy - shw
  436. ENDIF
  437. IF ( mytask_x .EQ. ntasks_x-1 ) THEN
  438. ipe = ipe + shw
  439. ipey = ipey + shw
  440. ENDIF
  441. IF ( mytask_y .EQ. 0 ) THEN
  442. jps = jps - shw
  443. jpsx = jpsx - shw
  444. ENDIF
  445. IF ( mytask_y .EQ. ntasks_y-1 ) THEN
  446. jpe = jpe + shw
  447. jpex = jpex + shw
  448. ENDIF
  449. ENDIF !wig; 11-Mar-2008
  450. kps = 1
  451. kpe = kde-kds+1
  452. kms = 1
  453. kme = kpe
  454. kmsx = kpsx
  455. kmex = kpex
  456. kmsy = kpsy
  457. kmey = kpey
  458. ! handle setting the memory dimensions where there are no levels assigned to this proc
  459. IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN
  460. kmsx = 0
  461. kmex = 0
  462. ENDIF
  463. IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN
  464. kmsy = 0
  465. kmey = 0
  466. ENDIF
  467. IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
  468. ims = 0
  469. ime = 0
  470. ELSE
  471. ims = max( ips - max(shw,maxhalowidth), ids - bdx ) - 1
  472. ime = min( ipe + max(shw,maxhalowidth), ide + bdx ) + 1
  473. ENDIF
  474. imsx = ids
  475. imex = ide
  476. ipsx = imsx
  477. ipex = imex
  478. ! handle setting the memory dimensions where there are no Y elements assigned to this proc
  479. IF ( ipsy .EQ. 0 .AND. ipey .EQ. -1 ) THEN
  480. imsy = 0
  481. imey = 0
  482. ELSE
  483. imsy = ipsy
  484. imey = ipey
  485. ENDIF
  486. IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
  487. jms = 0
  488. jme = 0
  489. ELSE
  490. jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1
  491. jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1
  492. ENDIF
  493. jmsx = jpsx
  494. jmex = jpex
  495. jmsy = jds
  496. jmey = jde
  497. ! handle setting the memory dimensions where there are no X elements assigned to this proc
  498. IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN
  499. jmsx = 0
  500. jmex = 0
  501. ELSE
  502. jpsy = jmsy
  503. jpey = jmey
  504. ENDIF
  505. END SUBROUTINE compute_memory_dims_rsl_lite
  506. SUBROUTINE tfp_message( fname, lno )
  507. CHARACTER*(*) fname
  508. INTEGER lno
  509. CHARACTER*1024 mess
  510. #ifndef STUBMPI
  511. WRITE(mess,*)'tfp_message: ',trim(fname),lno
  512. CALL wrf_message(mess)
  513. # ifdef ALLOW_OVERDECOMP
  514. CALL task_for_point_message ! defined in RSL_LITE/task_for_point.c
  515. # else
  516. CALL wrf_error_fatal(mess)
  517. # endif
  518. #endif
  519. END SUBROUTINE tfp_message
  520. SUBROUTINE wrf_message( mess )
  521. CHARACTER*(*) mess
  522. PRINT*,'info: ',TRIM(mess)
  523. END SUBROUTINE wrf_message
  524. SUBROUTINE wrf_error_fatal( mess )
  525. CHARACTER*(*) mess
  526. PRINT*,'fatal: ',TRIM(mess)
  527. STOP
  528. END SUBROUTINE wrf_error_fatal
  529. PROGRAM tfp_tester
  530. INTEGER id , maxhalowidth , &
  531. shw , bdx, bdy , &
  532. ntasks_x, ntasks_y, &
  533. mytask_x, mytask_y, &
  534. ids, ide, jds, jde, kds, kde, &
  535. ims, ime, jms, jme, kms, kme, &
  536. imsx, imex, jmsx, jmex, kmsx, kmex, &
  537. imsy, imey, jmsy, jmey, kmsy, kmey, &
  538. ips, ipe, jps, jpe, kps, kpe, &
  539. ipsx, ipex, jpsx, jpex, kpsx, kpex, &
  540. ipsy, ipey, jpsy, jpey, kpsy, kpey
  541. INTEGER i, j
  542. PRINT*,'id,maxhalowidth,shw,bdx,bdy ? '
  543. READ(*,*)id,maxhalowidth,shw,bdx,bdy
  544. PRINT*,'ids,ide,jds,jde,kds,kde '
  545. READ(*,*)ids, ide, jds, jde, kds, kde
  546. PRINT*,'ntasks_x,ntasks_y'
  547. READ(*,*)ntasks_x,ntasks_y
  548. DO mytask_y = 0, ntasks_y-1
  549. DO mytask_x = 0, ntasks_x-1
  550. CALL compute_memory_dims_rsl_lite ( &
  551. id , maxhalowidth , &
  552. shw , bdx, bdy , &
  553. ntasks_x, ntasks_y, &
  554. mytask_x, mytask_y, &
  555. ids, ide, jds, jde, kds, kde, &
  556. ims, ime, jms, jme, kms, kme, &
  557. imsx, imex, jmsx, jmex, kmsx, kmex, &
  558. imsy, imey, jmsy, jmey, kmsy, kmey, &
  559. ips, ipe, jps, jpe, kps, kpe, &
  560. ipsx, ipex, jpsx, jpex, kpsx, kpex, &
  561. ipsy, ipey, jpsy, jpey, kpsy, kpey )
  562. PRINT*,' mytask_x, mytask_y ',mytask_x, mytask_y
  563. PRINT*,' ips, ipe, jps, jpe, kps, kpe ',ips, ipe, jps, jpe, kps, kpe
  564. PRINT*,' ims, ime, jms, jme, kms, kme ',ims, ime, jms, jme, kms, kme
  565. PRINT*,' ipsx, ipex, jpsx, jpex, kpsx, kpex ',ipsx, ipex, jpsx, jpex, kpsx, kpex
  566. PRINT*,' imsx, imex, jmsx, jmex, kmsx, kmex ',imsx, imex, jmsx, jmex, kmsx, kmex
  567. PRINT*,' ipsy, ipey, jpsy, jpey, kpsy, kpey ',ipsy, ipey, jpsy, jpey, kpsy, kpey
  568. PRINT*,' imsy, imey, jmsy, jmey, kmsy, kmey ',imsy, imey, jmsy, jmey, kmsy, kmey
  569. ENDDO
  570. ENDDO
  571. END PROGRAM tfp_tester