parray_l.F90 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718
  1. !
  2. ! PArray routines with logical arguments.
  3. !
  4. module PArray_l
  5. implicit none
  6. ! --- in/out -------------------------
  7. private
  8. public :: pa_Init, pa_Done, pa_SetShape, pa_SetCopy
  9. ! --- interfaces ---------------------------
  10. interface pa_Init
  11. module procedure pa_Init_l_1d
  12. module procedure pa_Init_l_2d
  13. module procedure pa_Init_l_3d
  14. module procedure pa_Init_l_4d
  15. module procedure pa_Init_l_5d
  16. module procedure pa_Init_l_6d
  17. module procedure pa_Init_l_7d
  18. end interface
  19. interface pa_Done
  20. module procedure pa_Done_l_1d
  21. module procedure pa_Done_l_2d
  22. module procedure pa_Done_l_3d
  23. module procedure pa_Done_l_4d
  24. module procedure pa_Done_l_5d
  25. module procedure pa_Done_l_6d
  26. module procedure pa_Done_l_7d
  27. end interface
  28. interface pa_SetShape
  29. module procedure pa_SetShape_l_1d_shp
  30. module procedure pa_SetShape_l_1d_n
  31. module procedure pa_SetShape_l_2d_shp
  32. module procedure pa_SetShape_l_2d_n
  33. module procedure pa_SetShape_l_3d_shp
  34. module procedure pa_SetShape_l_3d_n
  35. module procedure pa_SetShape_l_4d_shp
  36. module procedure pa_SetShape_l_4d_n
  37. module procedure pa_SetShape_l_5d_shp
  38. module procedure pa_SetShape_l_5d_n
  39. module procedure pa_SetShape_l_6d_shp
  40. module procedure pa_SetShape_l_6d_n
  41. module procedure pa_SetShape_l_7d_shp
  42. module procedure pa_SetShape_l_7d_n
  43. end interface
  44. interface pa_SetCopy
  45. module procedure pa_SetCopy_l_1d
  46. module procedure pa_SetCopy_l_2d
  47. module procedure pa_SetCopy_l_3d
  48. module procedure pa_SetCopy_l_4d
  49. module procedure pa_SetCopy_l_5d
  50. module procedure pa_SetCopy_l_6d
  51. module procedure pa_SetCopy_l_7d
  52. end interface
  53. contains
  54. ! =========================================================
  55. ! ===
  56. ! === logical
  57. ! ===
  58. ! =========================================================
  59. ! *******************************************
  60. ! ***
  61. ! *** logical 1D
  62. ! ***
  63. ! *******************************************
  64. subroutine pa_Init_l_1d( x )
  65. ! --- in/out ---------------------------
  66. logical, pointer :: x(:)
  67. ! --- begin ---------------------------
  68. nullify( x )
  69. end subroutine pa_Init_l_1d
  70. ! ***
  71. subroutine pa_Done_l_1d( x )
  72. ! --- in/out ---------------------------
  73. logical, pointer :: x(:)
  74. ! --- begin ---------------------------
  75. if ( associated(x) ) deallocate( x )
  76. end subroutine pa_Done_l_1d
  77. ! ***
  78. subroutine pa_SetShape_l_1d_shp( x, n )
  79. ! --- in/out ---------------------------
  80. logical, pointer :: x(:)
  81. integer, intent(in) :: n(1)
  82. ! --- begin ---------------------------
  83. if ( associated(x) ) then
  84. if ( any( shape(x) /= n ) ) deallocate( x )
  85. end if
  86. if ( .not. associated(x) ) allocate( x(n(1)) )
  87. end subroutine pa_SetShape_l_1d_shp
  88. ! ***
  89. subroutine pa_SetShape_l_1d_n( x, n1 )
  90. ! --- in/out ---------------------------
  91. logical, pointer :: x(:)
  92. integer, intent(in) :: n1
  93. ! --- begin ---------------------------
  94. if ( associated(x) ) then
  95. if ( size(x) /= n1 ) deallocate( x )
  96. end if
  97. if ( .not. associated(x) ) allocate( x(n1) )
  98. end subroutine pa_SetShape_l_1d_n
  99. ! ***
  100. subroutine pa_SetCopy_l_1d( x, y )
  101. ! --- in/out ---------------------------
  102. logical, pointer :: x(:)
  103. logical, intent(in) :: y(:)
  104. ! --- begin ---------------------------
  105. call pa_SetShape( x, shape(y) )
  106. x = y
  107. end subroutine pa_SetCopy_l_1d
  108. ! *******************************************
  109. ! ***
  110. ! *** logical 2D
  111. ! ***
  112. ! *******************************************
  113. subroutine pa_Init_l_2d( x )
  114. ! --- in/out ---------------------------
  115. logical, pointer :: x(:,:)
  116. ! --- begin ---------------------------
  117. nullify( x )
  118. end subroutine pa_Init_l_2d
  119. ! ***
  120. subroutine pa_Done_l_2d( x )
  121. ! --- in/out ---------------------------
  122. logical, pointer :: x(:,:)
  123. ! --- begin ---------------------------
  124. if ( associated(x) ) deallocate( x )
  125. end subroutine pa_Done_l_2d
  126. ! ***
  127. subroutine pa_SetShape_l_2d_shp( x, n )
  128. ! --- in/out ---------------------------
  129. logical, pointer :: x(:,:)
  130. integer, intent(in) :: n(2)
  131. ! --- begin ---------------------------
  132. if ( associated(x) ) then
  133. if ( any( shape(x) /= n ) ) deallocate( x )
  134. end if
  135. if ( .not. associated(x) ) allocate( x(n(1),n(2)) )
  136. end subroutine pa_SetShape_l_2d_shp
  137. ! ***
  138. subroutine pa_SetShape_l_2d_n( x, n1, n2 )
  139. ! --- in/out ---------------------------
  140. logical, pointer :: x(:,:)
  141. integer, intent(in) :: n1, n2
  142. ! --- begin ---------------------------
  143. call pa_SetShape( x, (/n1,n2/) )
  144. end subroutine pa_SetShape_l_2d_n
  145. ! ***
  146. subroutine pa_SetCopy_l_2d( x, y )
  147. ! --- in/out ---------------------------
  148. logical, pointer :: x(:,:)
  149. logical, intent(in) :: y(:,:)
  150. ! --- begin ---------------------------
  151. call pa_SetShape( x, shape(y) )
  152. x = y
  153. end subroutine pa_SetCopy_l_2d
  154. ! *******************************************
  155. ! ***
  156. ! *** logical 3D
  157. ! ***
  158. ! *******************************************
  159. subroutine pa_Init_l_3d( x )
  160. ! --- in/out ---------------------------
  161. logical, pointer :: x(:,:,:)
  162. ! --- begin ---------------------------
  163. nullify( x )
  164. end subroutine pa_Init_l_3d
  165. ! ***
  166. subroutine pa_Done_l_3d( x )
  167. ! --- in/out ---------------------------
  168. logical, pointer :: x(:,:,:)
  169. ! --- begin ---------------------------
  170. if ( associated(x) ) deallocate( x )
  171. end subroutine pa_Done_l_3d
  172. ! ***
  173. subroutine pa_SetShape_l_3d_shp( x, n )
  174. ! --- in/out ---------------------------
  175. logical, pointer :: x(:,:,:)
  176. integer, intent(in) :: n(3)
  177. ! --- begin ---------------------------
  178. if ( associated(x) ) then
  179. if ( any( shape(x) /= n ) ) deallocate( x )
  180. end if
  181. if ( .not. associated(x) ) allocate( x(n(1),n(2),n(3)) )
  182. end subroutine pa_SetShape_l_3d_shp
  183. ! ***
  184. subroutine pa_SetShape_l_3d_n( x, n1, n2, n3 )
  185. ! --- in/out ---------------------------
  186. logical, pointer :: x(:,:,:)
  187. integer, intent(in) :: n1, n2, n3
  188. ! --- begin ---------------------------
  189. call pa_SetShape( x, (/n1,n2,n3/) )
  190. end subroutine pa_SetShape_l_3d_n
  191. ! ***
  192. subroutine pa_SetCopy_l_3d( x, y )
  193. ! --- in/out ---------------------------
  194. logical, pointer :: x(:,:,:)
  195. logical, intent(in) :: y(:,:,:)
  196. ! --- begin ---------------------------
  197. call pa_SetShape( x, shape(y) )
  198. x = y
  199. end subroutine pa_SetCopy_l_3d
  200. ! *******************************************
  201. ! ***
  202. ! *** logical 4D
  203. ! ***
  204. ! *******************************************
  205. subroutine pa_Init_l_4d( x )
  206. ! --- in/out ---------------------------
  207. logical, pointer :: x(:,:,:,:)
  208. ! --- begin ---------------------------
  209. nullify( x )
  210. end subroutine pa_Init_l_4d
  211. ! ***
  212. subroutine pa_Done_l_4d( x )
  213. ! --- in/out ---------------------------
  214. logical, pointer :: x(:,:,:,:)
  215. ! --- begin ---------------------------
  216. if ( associated(x) ) deallocate( x )
  217. end subroutine pa_Done_l_4d
  218. ! ***
  219. subroutine pa_SetShape_l_4d_shp( x, n )
  220. ! --- in/out ---------------------------
  221. logical, pointer :: x(:,:,:,:)
  222. integer, intent(in) :: n(4)
  223. ! --- begin ---------------------------
  224. if ( associated(x) ) then
  225. if ( any( shape(x) /= n ) ) deallocate( x )
  226. end if
  227. if ( .not. associated(x) ) allocate( x(n(1),n(2),n(3),n(4)) )
  228. end subroutine pa_SetShape_l_4d_shp
  229. ! ***
  230. subroutine pa_SetShape_l_4d_n( x, n1, n2, n3, n4 )
  231. ! --- in/out ---------------------------
  232. logical, pointer :: x(:,:,:,:)
  233. integer, intent(in) :: n1, n2, n3, n4
  234. ! --- begin ---------------------------
  235. call pa_SetShape( x, (/n1,n2,n3,n4/) )
  236. end subroutine pa_SetShape_l_4d_n
  237. ! ***
  238. subroutine pa_SetCopy_l_4d( x, y )
  239. ! --- in/out ---------------------------
  240. logical, pointer :: x(:,:,:,:)
  241. logical, intent(in) :: y(:,:,:,:)
  242. ! --- begin ---------------------------
  243. call pa_SetShape( x, shape(y) )
  244. x = y
  245. end subroutine pa_SetCopy_l_4d
  246. ! *******************************************
  247. ! ***
  248. ! *** logical 5D
  249. ! ***
  250. ! *******************************************
  251. subroutine pa_Init_l_5d( x )
  252. ! --- in/out ---------------------------
  253. logical, pointer :: x(:,:,:,:,:)
  254. ! --- begin ---------------------------
  255. nullify( x )
  256. end subroutine pa_Init_l_5d
  257. ! ***
  258. subroutine pa_Done_l_5d( x )
  259. ! --- in/out ---------------------------
  260. logical, pointer :: x(:,:,:,:,:)
  261. ! --- begin ---------------------------
  262. if ( associated(x) ) deallocate( x )
  263. end subroutine pa_Done_l_5d
  264. ! ***
  265. subroutine pa_SetShape_l_5d_shp( x, n )
  266. ! --- in/out ---------------------------
  267. logical, pointer :: x(:,:,:,:,:)
  268. integer, intent(in) :: n(5)
  269. ! --- begin ---------------------------
  270. if ( associated(x) ) then
  271. if ( any( shape(x) /= n ) ) deallocate( x )
  272. end if
  273. if ( .not. associated(x) ) allocate( x(n(1),n(2),n(3),n(4),n(5)) )
  274. end subroutine pa_SetShape_l_5d_shp
  275. ! ***
  276. subroutine pa_SetShape_l_5d_n( x, n1, n2, n3, n4, n5 )
  277. ! --- in/out ---------------------------
  278. logical, pointer :: x(:,:,:,:,:)
  279. integer, intent(in) :: n1, n2, n3, n4, n5
  280. ! --- begin ---------------------------
  281. call pa_SetShape( x, (/n1,n2,n3,n4,n5/) )
  282. end subroutine pa_SetShape_l_5d_n
  283. ! ***
  284. subroutine pa_SetCopy_l_5d( x, y )
  285. ! --- in/out ---------------------------
  286. logical, pointer :: x(:,:,:,:,:)
  287. logical, intent(in) :: y(:,:,:,:,:)
  288. ! --- begin ---------------------------
  289. call pa_SetShape( x, shape(y) )
  290. x = y
  291. end subroutine pa_SetCopy_l_5d
  292. ! *******************************************
  293. ! ***
  294. ! *** logical 6D
  295. ! ***
  296. ! *******************************************
  297. subroutine pa_Init_l_6d( x )
  298. ! --- in/out ---------------------------
  299. logical, pointer :: x(:,:,:,:,:,:)
  300. ! --- begin ---------------------------
  301. nullify( x )
  302. end subroutine pa_Init_l_6d
  303. ! ***
  304. subroutine pa_Done_l_6d( x )
  305. ! --- in/out ---------------------------
  306. logical, pointer :: x(:,:,:,:,:,:)
  307. ! --- begin ---------------------------
  308. if ( associated(x) ) deallocate( x )
  309. end subroutine pa_Done_l_6d
  310. ! ***
  311. subroutine pa_SetShape_l_6d_shp( x, n )
  312. ! --- in/out ---------------------------
  313. logical, pointer :: x(:,:,:,:,:,:)
  314. integer, intent(in) :: n(6)
  315. ! --- begin ---------------------------
  316. if ( associated(x) ) then
  317. if ( any( shape(x) /= n ) ) deallocate( x )
  318. end if
  319. if ( .not. associated(x) ) allocate( x(n(1),n(2),n(3),n(4),n(5),n(6)) )
  320. end subroutine pa_SetShape_l_6d_shp
  321. ! ***
  322. subroutine pa_SetShape_l_6d_n( x, n1, n2, n3, n4, n5, n6 )
  323. ! --- in/out ---------------------------
  324. logical, pointer :: x(:,:,:,:,:,:)
  325. integer, intent(in) :: n1, n2, n3, n4, n5, n6
  326. ! --- begin ---------------------------
  327. call pa_SetShape( x, (/n1,n2,n3,n4,n5,n6/) )
  328. end subroutine pa_SetShape_l_6d_n
  329. ! ***
  330. subroutine pa_SetCopy_l_6d( x, y )
  331. ! --- in/out ---------------------------
  332. logical, pointer :: x(:,:,:,:,:,:)
  333. logical, intent(in) :: y(:,:,:,:,:,:)
  334. ! --- begin ---------------------------
  335. call pa_SetShape( x, shape(y) )
  336. x = y
  337. end subroutine pa_SetCopy_l_6d
  338. ! *******************************************
  339. ! ***
  340. ! *** logical 7D
  341. ! ***
  342. ! *******************************************
  343. subroutine pa_Init_l_7d( x )
  344. ! --- in/out ---------------------------
  345. logical, pointer :: x(:,:,:,:,:,:,:)
  346. ! --- begin ---------------------------
  347. nullify( x )
  348. end subroutine pa_Init_l_7d
  349. ! ***
  350. subroutine pa_Done_l_7d( x )
  351. ! --- in/out ---------------------------
  352. logical, pointer :: x(:,:,:,:,:,:,:)
  353. ! --- begin ---------------------------
  354. if ( associated(x) ) deallocate( x )
  355. end subroutine pa_Done_l_7d
  356. ! ***
  357. subroutine pa_SetShape_l_7d_shp( x, n )
  358. ! --- in/out ---------------------------
  359. logical, pointer :: x(:,:,:,:,:,:,:)
  360. integer, intent(in) :: n(7)
  361. ! --- begin ---------------------------
  362. if ( associated(x) ) then
  363. if ( any( shape(x) /= n ) ) deallocate( x )
  364. end if
  365. if ( .not. associated(x) ) allocate( x(n(1),n(2),n(3),n(4),n(5),n(6),n(7)) )
  366. end subroutine pa_SetShape_l_7d_shp
  367. ! ***
  368. subroutine pa_SetShape_l_7d_n( x, n1, n2, n3, n4, n5, n6, n7 )
  369. ! --- in/out ---------------------------
  370. logical, pointer :: x(:,:,:,:,:,:,:)
  371. integer, intent(in) :: n1, n2, n3, n4, n5, n6, n7
  372. ! --- begin ---------------------------
  373. call pa_SetShape( x, (/n1,n2,n3,n4,n5,n6,n7/) )
  374. end subroutine pa_SetShape_l_7d_n
  375. ! ***
  376. subroutine pa_SetCopy_l_7d( x, y )
  377. ! --- in/out ---------------------------
  378. logical, pointer :: x(:,:,:,:,:,:,:)
  379. logical, intent(in) :: y(:,:,:,:,:,:,:)
  380. ! --- begin ---------------------------
  381. call pa_SetShape( x, shape(y) )
  382. x = y
  383. end subroutine pa_SetCopy_l_7d
  384. end module PArray_l