file_hdf_iwp.F90.in 81 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531
  1. !
  2. ! Template for file_hdf routines with integer arguments.
  3. !
  4. ! To generate kind specific versions, use:
  5. !
  6. ! /bin/sed -e 's/<wp>/1/g' file_hdf_iwp.F90.in > file_hdf_i1.F90
  7. ! /bin/sed -e 's/<wp>/2/g' file_hdf_iwp.F90.in > file_hdf_i2.F90
  8. ! /bin/sed -e 's/<wp>/4/g' file_hdf_iwp.F90.in > file_hdf_i4.F90
  9. ! /bin/sed -e 's/<wp>/8/g' file_hdf_iwp.F90.in > file_hdf_i8.F90
  10. !
  11. module file_hdf_i<wp>
  12. implicit none
  13. ! --- in/out --------------------------
  14. private
  15. public :: ReadData
  16. public :: WriteData
  17. public :: SetScale, SetDim
  18. public :: ReadAttribute, CheckAttribute
  19. public :: WriteAttribute
  20. ! --- const ----------------------------
  21. include "hdf.f90"
  22. character(len=*), parameter :: mname = 'file_hdf_i<wp>'
  23. ! --- interfaces ------------------------
  24. interface ReadData
  25. module procedure sds_ReadData_i<wp>_1d
  26. module procedure sds_ReadData_i<wp>_2d
  27. module procedure sds_ReadData_i<wp>_3d
  28. module procedure sds_ReadData_i<wp>_4d
  29. module procedure sds_ReadData_i<wp>_5d
  30. module procedure sds_ReadData_i<wp>_6d
  31. module procedure sds_ReadData_i<wp>_7d
  32. end interface
  33. interface WriteData
  34. module procedure sds_WriteData_i<wp>_1d
  35. module procedure sds_WriteData_i<wp>_2d
  36. module procedure sds_WriteData_i<wp>_3d
  37. module procedure sds_WriteData_i<wp>_4d
  38. module procedure sds_WriteData_i<wp>_5d
  39. module procedure sds_WriteData_i<wp>_6d
  40. module procedure sds_WriteData_i<wp>_7d
  41. end interface
  42. interface SetScale
  43. module procedure dim_SetScale_i<wp>
  44. end interface
  45. interface SetDim
  46. module procedure sds_SetDim_i<wp>
  47. end interface
  48. interface ReadAttribute
  49. module procedure obj_ReadAttribute_i<wp>_0d
  50. module procedure obj_ReadAttribute_i<wp>_1d
  51. !
  52. module procedure sds_ReadAttribute_i<wp>_0d
  53. module procedure sds_ReadAttribute_i<wp>_1d
  54. !
  55. module procedure dim_ReadAttribute_i<wp>_0d
  56. module procedure dim_ReadAttribute_i<wp>_1d
  57. !
  58. module procedure hdf_ReadAttribute_i<wp>_0d
  59. module procedure hdf_ReadAttribute_i<wp>_1d
  60. end interface
  61. interface CheckAttribute
  62. module procedure obj_CheckAttribute_i<wp>_0d
  63. module procedure obj_CheckAttribute_i<wp>_1d
  64. !
  65. module procedure sds_CheckAttribute_i<wp>_0d
  66. module procedure sds_CheckAttribute_i<wp>_1d
  67. !
  68. module procedure dim_CheckAttribute_i<wp>_0d
  69. module procedure dim_CheckAttribute_i<wp>_1d
  70. !
  71. module procedure hdf_CheckAttribute_i<wp>_0d
  72. module procedure hdf_CheckAttribute_i<wp>_1d
  73. end interface
  74. interface WriteAttribute
  75. module procedure obj_WriteAttribute_i<wp>_0d
  76. module procedure obj_WriteAttribute_i<wp>_1d
  77. !
  78. module procedure sds_WriteAttribute_i<wp>_0d
  79. module procedure sds_WriteAttribute_i<wp>_1d
  80. !
  81. module procedure dim_WriteAttribute_i<wp>_0d
  82. module procedure dim_WriteAttribute_i<wp>_1d
  83. !
  84. module procedure hdf_WriteAttribute_i<wp>_0d
  85. module procedure hdf_WriteAttribute_i<wp>_1d
  86. end interface
  87. contains
  88. ! ############################################################
  89. ! ###
  90. ! ### objects
  91. ! ###
  92. ! ############################################################
  93. ! ================================================================
  94. ! ===
  95. ! === read attributes
  96. ! ===
  97. ! ================================================================
  98. subroutine obj_ReadAttribute_i<wp>_0d( obj_id, name, i, status )
  99. use file_hdf_base, only : wpi
  100. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  101. use file_hdf_base, only : FindAttribute, CheckAttributeInfo, GetAttributeInfo
  102. ! --- in/out -------------------------
  103. integer(wpi), intent(in) :: obj_id
  104. character(len=*), intent(in) :: name
  105. integer(<wp>), intent(out) :: i
  106. integer, intent(out) :: status
  107. ! --- const --------------------------
  108. character(len=*), parameter :: rname = mname//'/obj_ReadAttribute_i<wp>_0d'
  109. ! --- local -------------------------------
  110. integer :: attr_index, data_type
  111. integer(wp_int8 ) :: int8
  112. integer(wp_int16) :: int16
  113. integer(wp_int32) :: int32
  114. integer(wp_int64) :: int64
  115. ! --- external ----------------------------
  116. integer(wpi), external :: sfRNAtt
  117. ! --- begin -------------------------------
  118. call FindAttribute( obj_id, name, attr_index, status )
  119. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  120. call CheckAttributeInfo( obj_id, attr_index, status, n_values=1 )
  121. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  122. ! extract value:
  123. call GetAttributeInfo( obj_id, attr_index, status, data_type=data_type )
  124. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  125. select case ( data_type )
  126. case ( DFNT_INT8 )
  127. status = sfRNAtt( obj_id, attr_index, int8 ); i = int(int8 ,kind=<wp>)
  128. case ( DFNT_INT16 )
  129. status = sfRNAtt( obj_id, attr_index, int16 ); i = int(int16,kind=<wp>)
  130. case ( DFNT_INT32 )
  131. status = sfRNAtt( obj_id, attr_index, int32 ); i = int(int32,kind=<wp>)
  132. case ( DFNT_INT64 )
  133. status = sfRNAtt( obj_id, attr_index, int64 ); i = int(int64,kind=<wp>)
  134. case default
  135. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  136. write (*,'("ERROR in ",a)') rname; status=1; return
  137. end select
  138. if ( status /= SUCCEED ) then
  139. write (*,'("ERROR - reading attribute : ",a)') trim(name)
  140. write (*,'("ERROR in ",a)') rname; status=1; return
  141. end if
  142. ! ok
  143. status = 0
  144. end subroutine obj_ReadAttribute_i<wp>_0d
  145. ! ***
  146. subroutine obj_ReadAttribute_i<wp>_1d( obj_id, name, i, status )
  147. use file_hdf_base, only : wpi
  148. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  149. use file_hdf_base, only : FindAttribute, CheckAttributeInfo, GetAttributeInfo
  150. ! --- in/out -------------------------
  151. integer(wpi), intent(in) :: obj_id
  152. character(len=*), intent(in) :: name
  153. integer(<wp>), intent(out) :: i(:)
  154. integer, intent(out) :: status
  155. ! --- const --------------------------
  156. character(len=*), parameter :: rname = mname//'/obj_ReadAttribute_i<wp>_1d'
  157. ! --- local -------------------------------
  158. integer :: attr_index, data_type
  159. integer :: n
  160. integer(wp_int8 ), allocatable :: int8 (:)
  161. integer(wp_int16), allocatable :: int16(:)
  162. integer(wp_int32), allocatable :: int32(:)
  163. integer(wp_int64), allocatable :: int64(:)
  164. ! --- external ----------------------------
  165. integer(wpi), external :: sfRNAtt
  166. ! --- begin -------------------------------
  167. n = size(i)
  168. call FindAttribute( obj_id, name, attr_index, status )
  169. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  170. call CheckAttributeInfo( obj_id, attr_index, status, n_values=n )
  171. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  172. ! extract value:
  173. call GetAttributeInfo( obj_id, attr_index, status, data_type=data_type )
  174. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  175. select case ( data_type )
  176. case ( DFNT_INT8 )
  177. allocate( int8 (n) )
  178. status = sfRNAtt( obj_id, attr_index, int8 )
  179. i = int(int8 ,kind=<wp>)
  180. deallocate( int8 )
  181. case ( DFNT_INT16 )
  182. allocate( int16(n) )
  183. status = sfRNAtt( obj_id, attr_index, int16 )
  184. i = int(int16,kind=<wp>)
  185. deallocate( int16 )
  186. case ( DFNT_INT32 )
  187. allocate( int32(n) )
  188. status = sfRNAtt( obj_id, attr_index, int32 )
  189. i = int(int32,kind=<wp>)
  190. deallocate( int32 )
  191. case ( DFNT_INT64 )
  192. allocate( int64(n) )
  193. status = sfRNAtt( obj_id, attr_index, int64 )
  194. i = int(int64,kind=<wp>)
  195. deallocate( int64 )
  196. case default
  197. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  198. write (*,'("ERROR in ",a)') rname; status=1; return
  199. end select
  200. if ( status /= SUCCEED ) then
  201. write (*,'("ERROR - reading attribute : ",a)') trim(name)
  202. write (*,'("ERROR in ",a)') rname; status=1; return
  203. end if
  204. ! ok
  205. status = 0
  206. end subroutine obj_ReadAttribute_i<wp>_1d
  207. ! ================================================================
  208. ! ===
  209. ! === check attributes
  210. ! ===
  211. ! ================================================================
  212. subroutine obj_CheckAttribute_i<wp>_0d( obj_id, name, i, status )
  213. use file_hdf_base, only : wpi
  214. ! --- in/out -------------------------
  215. integer(wpi), intent(in) :: obj_id
  216. character(len=*), intent(in) :: name
  217. integer(<wp>), intent(in) :: i
  218. integer, intent(inout) :: status
  219. ! --- const --------------------------
  220. character(len=*), parameter :: rname = mname//'/obj_CheckAttribute_i<wp>_0d'
  221. ! --- local -------------------------------
  222. logical :: verbose
  223. integer(<wp>) :: attr_i
  224. ! --- begin -------------------------------
  225. ! write error messages ?
  226. verbose = status == 0
  227. call ReadAttribute( obj_id, name, attr_i, status )
  228. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  229. ! check:
  230. if ( attr_i /= i ) then
  231. if (verbose) then
  232. write (*,'("ERROR - foud different attribute values:")')
  233. write (*,'("ERROR - attr name : ",a)') trim(name)
  234. write (*,'("ERROR - requested : ",i6)') i
  235. write (*,'("ERROR - found : ",i6)') attr_i
  236. write (*,'("ERROR in ",a)') rname
  237. end if
  238. status=-1; return
  239. end if
  240. ! ok
  241. status = 0
  242. end subroutine obj_CheckAttribute_i<wp>_0d
  243. ! ***
  244. subroutine obj_CheckAttribute_i<wp>_1d( obj_id, name, i, status )
  245. use file_hdf_base, only : wpi
  246. ! --- in/out -------------------------
  247. integer(wpi), intent(in) :: obj_id
  248. character(len=*), intent(in) :: name
  249. integer(<wp>), intent(in) :: i(:)
  250. integer, intent(inout) :: status
  251. ! --- const --------------------------
  252. character(len=*), parameter :: rname = mname//'/obj_CheckAttribute_i<wp>_1d'
  253. ! --- local -------------------------------
  254. logical :: verbose
  255. integer :: n
  256. integer(<wp>), allocatable :: attr_i(:)
  257. logical :: failed
  258. ! --- begin -------------------------------
  259. ! write error messages ?
  260. verbose = status == 0
  261. n = size(i)
  262. allocate( attr_i(n) )
  263. call ReadAttribute( obj_id, name, attr_i, status )
  264. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  265. ! check:
  266. failed = any( attr_i /= i )
  267. ! clear
  268. deallocate( attr_i )
  269. ! not ok ?
  270. if ( failed ) then
  271. if (verbose) then
  272. write (*,'("ERROR - foud different attribute values:")')
  273. write (*,'("ERROR - attr name : ",a)') trim(name)
  274. write (*,'("ERROR - requested : ",i6)') i
  275. write (*,'("ERROR - found : ",i6)') attr_i
  276. write (*,'("ERROR in ",a)') rname
  277. end if
  278. status=-1; return
  279. end if
  280. ! ok
  281. status = 0
  282. end subroutine obj_CheckAttribute_i<wp>_1d
  283. ! ================================================================
  284. ! ===
  285. ! === write attributes
  286. ! ===
  287. ! ================================================================
  288. subroutine obj_WriteAttribute_i<wp>_0d( obj_id, name, i, status, knd )
  289. use file_hdf_base, only : wpi
  290. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  291. ! --- in/out -------------------------
  292. integer(wpi), intent(in) :: obj_id
  293. character(len=*), intent(in) :: name
  294. integer(<wp>), intent(in) :: i
  295. integer, intent(inout) :: status
  296. integer, intent(in), optional :: knd
  297. ! --- const --------------------------
  298. character(len=*), parameter :: rname = mname//'/obj_WriteAttribute_i<wp>_0d'
  299. ! --- local -------------------------------
  300. integer :: ikind
  301. ! --- external ----------------------------
  302. integer(wpi), external :: sfSNAtt
  303. ! --- begin -------------------------------
  304. ikind = kind(i)
  305. if ( present(knd) ) ikind = knd
  306. select case ( ikind )
  307. case ( 1 )
  308. status = sfSNAtt( obj_id, name, DFNT_INT8 , 1, int(i,kind=wp_int8 ) )
  309. case ( 2 )
  310. status = sfSNAtt( obj_id, name, DFNT_INT16, 1, int(i,kind=wp_int16) )
  311. case ( 4 )
  312. status = sfSNAtt( obj_id, name, DFNT_INT32, 1, int(i,kind=wp_int32) )
  313. case ( 8 )
  314. status = sfSNAtt( obj_id, name, DFNT_INT64, 1, int(i,kind=wp_int64) )
  315. case default
  316. write (*,'("ERROR - no implementation for writing with kind ",i2)') ikind
  317. write (*,'("ERROR in ",a)') rname; status=-1; return
  318. end select
  319. if ( status /= SUCCEED ) then
  320. write (*,'("ERROR - while writing attribute:")')
  321. write (*,'("ERROR - attr name : ",a)') name
  322. write (*,'("ERROR - input kind : ",i2)') kind(i)
  323. write (*,'("ERROR - output kind : ",i2)') ikind
  324. write (*,'("ERROR in ",a)') rname; status=-1; return
  325. end if
  326. ! ok
  327. status = 0
  328. end subroutine obj_WriteAttribute_i<wp>_0d
  329. ! ***
  330. subroutine obj_WriteAttribute_i<wp>_1d( obj_id, name, i, status, knd )
  331. use file_hdf_base, only : wpi
  332. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  333. ! --- in/out -------------------------
  334. integer(wpi), intent(in) :: obj_id
  335. character(len=*), intent(in) :: name
  336. integer(<wp>), intent(in) :: i(:)
  337. integer, intent(inout) :: status
  338. integer, intent(in), optional :: knd
  339. ! --- const --------------------------
  340. character(len=*), parameter :: rname = mname//'/obj_WriteAttribute_i<wp>_1d'
  341. ! --- local -------------------------------
  342. integer :: ikind
  343. ! --- external ----------------------------
  344. integer(wpi), external :: sfSNAtt
  345. ! --- begin -------------------------------
  346. ikind = kind(i)
  347. if ( present(knd) ) ikind = knd
  348. select case ( ikind )
  349. case ( 1 )
  350. status = sfSNAtt( obj_id, name, DFNT_INT8 , size(i), int(i,kind=wp_int8 ) )
  351. case ( 2 )
  352. status = sfSNAtt( obj_id, name, DFNT_INT16, size(i), int(i,kind=wp_int16) )
  353. case ( 4 )
  354. status = sfSNAtt( obj_id, name, DFNT_INT32, size(i), int(i,kind=wp_int32) )
  355. case ( 8 )
  356. status = sfSNAtt( obj_id, name, DFNT_INT64, size(i), int(i,kind=wp_int64) )
  357. case default
  358. write (*,'("ERROR - no implementation for writing with kind ",i2)') ikind
  359. write (*,'("ERROR in ",a)') rname; status=-1; return
  360. end select
  361. if ( status /= SUCCEED ) then
  362. write (*,'("ERROR - while writing attribute:")')
  363. write (*,'("ERROR - attr name : ",a)') name
  364. write (*,'("ERROR - input kind : ",i2)') kind(i)
  365. write (*,'("ERROR - output kind : ",i2)') ikind
  366. write (*,'("ERROR in ",a)') rname; status=-1; return
  367. end if
  368. ! ok
  369. status = 0
  370. end subroutine obj_WriteAttribute_i<wp>_1d
  371. ! ############################################################
  372. ! ###
  373. ! ### scientific data sets
  374. ! ###
  375. ! ############################################################
  376. ! ================================================================
  377. ! read attributes
  378. ! ================================================================
  379. subroutine sds_ReadAttribute_i<wp>_0d( sds, name, i, status )
  380. use file_hdf_base, only : TSds
  381. ! --- in/out -------------------------
  382. type(Tsds), intent(in) :: sds
  383. character(len=*), intent(in) :: name
  384. integer(<wp>), intent(out) :: i
  385. integer, intent(out) :: status
  386. ! --- const --------------------------
  387. character(len=*), parameter :: rname = mname//'/sds_ReadAttribute_i<wp>_0d'
  388. ! --- begin -------------------------------
  389. call ReadAttribute( sds%id, name, i, status )
  390. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  391. ! ok
  392. status = 0
  393. end subroutine sds_ReadAttribute_i<wp>_0d
  394. ! ***
  395. subroutine sds_ReadAttribute_i<wp>_1d( sds, name, i, status )
  396. use file_hdf_base, only : TSds
  397. ! --- in/out -------------------------
  398. type(Tsds), intent(in) :: sds
  399. character(len=*), intent(in) :: name
  400. integer(<wp>), intent(out) :: i(:)
  401. integer, intent(out) :: status
  402. ! --- const --------------------------
  403. character(len=*), parameter :: rname = mname//'/sds_ReadAttribute_i<wp>_1d'
  404. ! --- begin -------------------------------
  405. call ReadAttribute( sds%id, name, i, status )
  406. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  407. ! ok
  408. status = 0
  409. end subroutine sds_ReadAttribute_i<wp>_1d
  410. ! =============================================================
  411. ! === check attributes
  412. ! =============================================================
  413. subroutine sds_CheckAttribute_i<wp>_0d( sds, name, i, status )
  414. use file_hdf_base, only : TSds
  415. ! --- in/out -------------------------
  416. type(TSds), intent(in) :: sds
  417. character(len=*), intent(in) :: name
  418. integer(<wp>), intent(in) :: i
  419. integer, intent(inout) :: status
  420. ! --- const --------------------------
  421. character(len=*), parameter :: rname = mname//'/sds_CheckAttribute_i<wp>_0d'
  422. ! --- local ------------------------------
  423. logical :: verbose
  424. ! --- begin ---------------------------
  425. ! write error messages ?
  426. verbose = status == 0
  427. call CheckAttribute( sds%id, name, i, status )
  428. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  429. if (status<0) then
  430. if (verbose) write (*,'("ERROR in ",a)') rname
  431. status=-1; return
  432. end if
  433. ! ok
  434. status = 0
  435. end subroutine sds_CheckAttribute_i<wp>_0d
  436. ! ***
  437. subroutine sds_CheckAttribute_i<wp>_1d( sds, name, i, status )
  438. use file_hdf_base, only : TSds
  439. ! --- in/out -------------------------
  440. type(TSds), intent(in) :: sds
  441. character(len=*), intent(in) :: name
  442. integer(<wp>), intent(in) :: i(:)
  443. integer, intent(inout) :: status
  444. ! --- const --------------------------
  445. character(len=*), parameter :: rname = mname//'/sds_CheckAttribute_i<wp>_1d'
  446. ! --- local ------------------------------
  447. logical :: verbose
  448. ! --- begin ---------------------------
  449. ! write error messages ?
  450. verbose = status == 0
  451. call CheckAttribute( sds%id, name, i, status )
  452. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  453. if (status<0) then
  454. if (verbose) write (*,'("ERROR in ",a)') rname
  455. status=-1; return
  456. end if
  457. ! ok
  458. status = 0
  459. end subroutine sds_CheckAttribute_i<wp>_1d
  460. ! ================================================================
  461. ! write attributes
  462. ! ================================================================
  463. subroutine sds_WriteAttribute_i<wp>_0d( sds, name, i, status, knd )
  464. use file_hdf_base, only : TSds
  465. ! --- in/out -------------------------
  466. type(Tsds), intent(in) :: sds
  467. character(len=*), intent(in) :: name
  468. integer(<wp>), intent(in) :: i
  469. integer, intent(out) :: status
  470. integer, intent(in), optional :: knd
  471. ! --- const --------------------------
  472. character(len=*), parameter :: rname = mname//'/sds_WriteAttribute_i<wp>_0d'
  473. ! --- begin -------------------------------
  474. call WriteAttribute( sds%id, name, i, status, knd )
  475. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  476. ! ok
  477. status = 0
  478. end subroutine sds_WriteAttribute_i<wp>_0d
  479. ! ***
  480. subroutine sds_WriteAttribute_i<wp>_1d( sds, name, i, status, knd )
  481. use file_hdf_base, only : TSds
  482. ! --- in/out -------------------------
  483. type(Tsds), intent(in) :: sds
  484. character(len=*), intent(in) :: name
  485. integer(<wp>), intent(in) :: i(:)
  486. integer, intent(out) :: status
  487. integer, intent(in), optional :: knd
  488. ! --- const --------------------------
  489. character(len=*), parameter :: rname = mname//'/sds_WriteAttribute_i<wp>_1d'
  490. ! --- begin -------------------------------
  491. call WriteAttribute( sds%id, name, i, status, knd )
  492. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  493. ! ok
  494. status = 0
  495. end subroutine sds_WriteAttribute_i<wp>_1d
  496. ! =============================================================
  497. ! === read data
  498. ! =============================================================
  499. subroutine sds_ReadData_i<wp>_1d( sds, data, status, start, stride )
  500. use parray, only : pa_Init, pa_SetShape, pa_Done
  501. use file_hdf_base, only : wpi
  502. use file_hdf_base, only : TSds
  503. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  504. use file_hdf_base, only : CheckInfo, GetInfo
  505. ! --- const ------------------------------
  506. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_1d'
  507. integer, parameter :: rank = 1
  508. ! --- in/out ----------------------------
  509. type(TSds), intent(in) :: sds
  510. integer(<wp>), intent(out) :: data(:)
  511. integer, intent(out) :: status
  512. integer, intent(in), optional :: start(rank)
  513. integer, intent(in), optional :: stride(rank)
  514. ! --- local -------------------------------
  515. integer :: data_type
  516. integer :: the_start(rank)
  517. integer :: the_stride(rank)
  518. integer(wp_int8 ), pointer :: int8 (:)
  519. integer(wp_int16), pointer :: int16(:)
  520. integer(wp_int32), pointer :: int32(:)
  521. integer(wp_int64), pointer :: int64(:)
  522. ! --- external ----------------------------
  523. integer(wpi), external :: sfRData
  524. ! --- begin -------------------------------
  525. ! check data rank and shape:
  526. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  527. ! read data of specified kind:
  528. the_start = 0; if ( present(start ) ) the_start = start
  529. the_stride = 1; if ( present(stride) ) the_stride = stride
  530. call GetInfo( sds, status, data_type=data_type )
  531. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  532. select case ( data_type )
  533. case ( DFNT_INT8 )
  534. call pa_Init( int8 )
  535. call pa_SetShape( int8 , shape(data) )
  536. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  537. data = int(int8,kind=<wp>)
  538. call pa_Done( int8 )
  539. case ( DFNT_INT16 )
  540. call pa_Init( int16 )
  541. call pa_SetShape( int16, shape(data) )
  542. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  543. data = int(int16,kind=<wp>)
  544. call pa_Done( int16 )
  545. case ( DFNT_INT32 )
  546. call pa_Init( int32 )
  547. call pa_SetShape( int32, shape(data) )
  548. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  549. data = int(int32,kind=<wp>)
  550. call pa_Done( int32 )
  551. case ( DFNT_INT64 )
  552. call pa_Init( int64 )
  553. call pa_SetShape( int64, shape(data) )
  554. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  555. data = int(int64,kind=<wp>)
  556. call pa_Done( int64 )
  557. case default
  558. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  559. write (*,'("ERROR in ",a)') rname; status=1; return
  560. end select
  561. if ( status == FAIL ) then
  562. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  563. write (*,'("ERROR in ",a)') rname; status=1; return
  564. end if
  565. ! ok
  566. status = 0
  567. end subroutine sds_ReadData_i<wp>_1d
  568. ! ***
  569. subroutine sds_ReadData_i<wp>_2d( sds, data, status, start, stride )
  570. use parray, only : pa_Init, pa_SetShape, pa_Done
  571. use file_hdf_base, only : wpi
  572. use file_hdf_base, only : TSds
  573. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  574. use file_hdf_base, only : CheckInfo, GetInfo
  575. ! --- const ------------------------------
  576. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_2d'
  577. integer, parameter :: rank = 2
  578. ! --- in/out ----------------------------
  579. type(TSds), intent(in) :: sds
  580. integer(<wp>), intent(out) :: data(:,:)
  581. integer, intent(out) :: status
  582. integer, intent(in), optional :: start(rank)
  583. integer, intent(in), optional :: stride(rank)
  584. ! --- local -------------------------------
  585. integer :: data_type
  586. integer :: the_start(rank)
  587. integer :: the_stride(rank)
  588. integer(wp_int8 ), pointer :: int8 (:,:)
  589. integer(wp_int16), pointer :: int16(:,:)
  590. integer(wp_int32), pointer :: int32(:,:)
  591. integer(wp_int64), pointer :: int64(:,:)
  592. ! --- external ----------------------------
  593. integer(wpi), external :: sfRData
  594. ! --- begin -------------------------------
  595. ! check data rank and shape:
  596. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  597. ! read data of specified kind:
  598. the_start = 0; if ( present(start ) ) the_start = start
  599. the_stride = 1; if ( present(stride) ) the_stride = stride
  600. call GetInfo( sds, status, data_type=data_type )
  601. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  602. select case ( data_type )
  603. case ( DFNT_INT8 )
  604. call pa_Init( int8 )
  605. call pa_SetShape( int8 , shape(data) )
  606. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  607. data = int(int8,kind=<wp>)
  608. call pa_Done( int8 )
  609. case ( DFNT_INT16 )
  610. call pa_Init( int16 )
  611. call pa_SetShape( int16, shape(data) )
  612. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  613. data = int(int16,kind=<wp>)
  614. call pa_Done( int16 )
  615. case ( DFNT_INT32 )
  616. call pa_Init( int32 )
  617. call pa_SetShape( int32, shape(data) )
  618. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  619. data = int(int32,kind=<wp>)
  620. call pa_Done( int32 )
  621. case ( DFNT_INT64 )
  622. call pa_Init( int64 )
  623. call pa_SetShape( int64, shape(data) )
  624. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  625. data = int(int64,kind=<wp>)
  626. call pa_Done( int64 )
  627. case default
  628. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  629. write (*,'("ERROR in ",a)') rname; status=1; return
  630. end select
  631. if ( status == FAIL ) then
  632. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  633. write (*,'("ERROR in ",a)') rname; status=1; return
  634. end if
  635. ! ok
  636. status = 0
  637. end subroutine sds_ReadData_i<wp>_2d
  638. ! ***
  639. subroutine sds_ReadData_i<wp>_3d( sds, data, status, start, stride )
  640. use parray, only : pa_Init, pa_SetShape, pa_Done
  641. use file_hdf_base, only : wpi
  642. use file_hdf_base, only : TSds
  643. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  644. use file_hdf_base, only : CheckInfo, GetInfo
  645. ! --- const ------------------------------
  646. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_3d'
  647. integer, parameter :: rank = 3
  648. ! --- in/out ----------------------------
  649. type(TSds), intent(in) :: sds
  650. integer(<wp>), intent(out) :: data(:,:,:)
  651. integer, intent(out) :: status
  652. integer, intent(in), optional :: start(rank)
  653. integer, intent(in), optional :: stride(rank)
  654. ! --- local -------------------------------
  655. integer :: data_type
  656. integer :: the_start(rank)
  657. integer :: the_stride(rank)
  658. integer(wp_int8 ), pointer :: int8 (:,:,:)
  659. integer(wp_int16), pointer :: int16(:,:,:)
  660. integer(wp_int32), pointer :: int32(:,:,:)
  661. integer(wp_int64), pointer :: int64(:,:,:)
  662. ! --- external ----------------------------
  663. integer(wpi), external :: sfRData
  664. ! --- begin -------------------------------
  665. ! check data rank and shape:
  666. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  667. ! read data of specified kind:
  668. the_start = 0; if ( present(start ) ) the_start = start
  669. the_stride = 1; if ( present(stride) ) the_stride = stride
  670. call GetInfo( sds, status, data_type=data_type )
  671. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  672. select case ( data_type )
  673. case ( DFNT_INT8 )
  674. call pa_Init( int8 )
  675. call pa_SetShape( int8 , shape(data) )
  676. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  677. data = int(int8,kind=<wp>)
  678. call pa_Done( int8 )
  679. case ( DFNT_INT16 )
  680. call pa_Init( int16 )
  681. call pa_SetShape( int16, shape(data) )
  682. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  683. data = int(int16,kind=<wp>)
  684. call pa_Done( int16 )
  685. case ( DFNT_INT32 )
  686. call pa_Init( int32 )
  687. call pa_SetShape( int32, shape(data) )
  688. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  689. data = int(int32,kind=<wp>)
  690. call pa_Done( int32 )
  691. case ( DFNT_INT64 )
  692. call pa_Init( int64 )
  693. call pa_SetShape( int64, shape(data) )
  694. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  695. data = int(int64,kind=<wp>)
  696. call pa_Done( int64 )
  697. case default
  698. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  699. write (*,'("ERROR in ",a)') rname; status=1; return
  700. end select
  701. if ( status == FAIL ) then
  702. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  703. write (*,'("ERROR in ",a)') rname; status=1; return
  704. end if
  705. ! ok
  706. status = 0
  707. end subroutine sds_ReadData_i<wp>_3d
  708. ! ***
  709. subroutine sds_ReadData_i<wp>_4d( sds, data, status, start, stride )
  710. use parray, only : pa_Init, pa_SetShape, pa_Done
  711. use file_hdf_base, only : wpi
  712. use file_hdf_base, only : TSds
  713. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  714. use file_hdf_base, only : CheckInfo, GetInfo
  715. ! --- const ------------------------------
  716. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_4d'
  717. integer, parameter :: rank = 4
  718. ! --- in/out ----------------------------
  719. type(TSds), intent(in) :: sds
  720. integer(<wp>), intent(out) :: data(:,:,:,:)
  721. integer, intent(out) :: status
  722. integer, intent(in), optional :: start(rank)
  723. integer, intent(in), optional :: stride(rank)
  724. ! --- local -------------------------------
  725. integer :: data_type
  726. integer :: the_start(rank)
  727. integer :: the_stride(rank)
  728. integer(wp_int8 ), pointer :: int8 (:,:,:,:)
  729. integer(wp_int16), pointer :: int16(:,:,:,:)
  730. integer(wp_int32), pointer :: int32(:,:,:,:)
  731. integer(wp_int64), pointer :: int64(:,:,:,:)
  732. ! --- external ----------------------------
  733. integer(wpi), external :: sfRData
  734. ! --- begin -------------------------------
  735. ! check data rank and shape:
  736. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  737. ! read data of specified kind:
  738. the_start = 0; if ( present(start ) ) the_start = start
  739. the_stride = 1; if ( present(stride) ) the_stride = stride
  740. call GetInfo( sds, status, data_type=data_type )
  741. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  742. select case ( data_type )
  743. case ( DFNT_INT8 )
  744. call pa_Init( int8 )
  745. call pa_SetShape( int8 , shape(data) )
  746. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  747. data = int(int8,kind=<wp>)
  748. call pa_Done( int8 )
  749. case ( DFNT_INT16 )
  750. call pa_Init( int16 )
  751. call pa_SetShape( int16, shape(data) )
  752. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  753. data = int(int16,kind=<wp>)
  754. call pa_Done( int16 )
  755. case ( DFNT_INT32 )
  756. call pa_Init( int32 )
  757. call pa_SetShape( int32, shape(data) )
  758. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  759. data = int(int32,kind=<wp>)
  760. call pa_Done( int32 )
  761. case ( DFNT_INT64 )
  762. call pa_Init( int64 )
  763. call pa_SetShape( int64, shape(data) )
  764. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  765. data = int(int64,kind=<wp>)
  766. call pa_Done( int64 )
  767. case default
  768. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  769. write (*,'("ERROR in ",a)') rname; status=1; return
  770. end select
  771. if ( status == FAIL ) then
  772. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  773. write (*,'("ERROR in ",a)') rname; status=1; return
  774. end if
  775. ! ok
  776. status = 0
  777. end subroutine sds_ReadData_i<wp>_4d
  778. ! ***
  779. subroutine sds_ReadData_i<wp>_5d( sds, data, status, start, stride )
  780. use parray, only : pa_Init, pa_SetShape, pa_Done
  781. use file_hdf_base, only : wpi
  782. use file_hdf_base, only : TSds
  783. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  784. use file_hdf_base, only : CheckInfo, GetInfo
  785. ! --- const ------------------------------
  786. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_5d'
  787. integer, parameter :: rank = 5
  788. ! --- in/out ----------------------------
  789. type(TSds), intent(in) :: sds
  790. integer(<wp>), intent(out) :: data(:,:,:,:,:)
  791. integer, intent(out) :: status
  792. integer, intent(in), optional :: start(rank)
  793. integer, intent(in), optional :: stride(rank)
  794. ! --- local -------------------------------
  795. integer :: data_type
  796. integer :: the_start(rank)
  797. integer :: the_stride(rank)
  798. integer(wp_int8 ), pointer :: int8 (:,:,:,:,:)
  799. integer(wp_int16), pointer :: int16(:,:,:,:,:)
  800. integer(wp_int32), pointer :: int32(:,:,:,:,:)
  801. integer(wp_int64), pointer :: int64(:,:,:,:,:)
  802. ! --- external ----------------------------
  803. integer(wpi), external :: sfRData
  804. ! --- begin -------------------------------
  805. ! check data rank and shape:
  806. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  807. ! read data of specified kind:
  808. the_start = 0; if ( present(start ) ) the_start = start
  809. the_stride = 1; if ( present(stride) ) the_stride = stride
  810. call GetInfo( sds, status, data_type=data_type )
  811. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  812. select case ( data_type )
  813. case ( DFNT_INT8 )
  814. call pa_Init( int8 )
  815. call pa_SetShape( int8 , shape(data) )
  816. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  817. data = int(int8,kind=<wp>)
  818. call pa_Done( int8 )
  819. case ( DFNT_INT16 )
  820. call pa_Init( int16 )
  821. call pa_SetShape( int16, shape(data) )
  822. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  823. data = int(int16,kind=<wp>)
  824. call pa_Done( int16 )
  825. case ( DFNT_INT32 )
  826. call pa_Init( int32 )
  827. call pa_SetShape( int32, shape(data) )
  828. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  829. data = int(int32,kind=<wp>)
  830. call pa_Done( int32 )
  831. case ( DFNT_INT64 )
  832. call pa_Init( int64 )
  833. call pa_SetShape( int64, shape(data) )
  834. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  835. data = int(int64,kind=<wp>)
  836. call pa_Done( int64 )
  837. case default
  838. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  839. write (*,'("ERROR in ",a)') rname; status=1; return
  840. end select
  841. if ( status == FAIL ) then
  842. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  843. write (*,'("ERROR in ",a)') rname; status=1; return
  844. end if
  845. ! ok
  846. status = 0
  847. end subroutine sds_ReadData_i<wp>_5d
  848. ! ***
  849. subroutine sds_ReadData_i<wp>_6d( sds, data, status, start, stride )
  850. use parray, only : pa_Init, pa_SetShape, pa_Done
  851. use file_hdf_base, only : wpi
  852. use file_hdf_base, only : TSds
  853. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  854. use file_hdf_base, only : CheckInfo, GetInfo
  855. ! --- const ------------------------------
  856. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_6d'
  857. integer, parameter :: rank = 6
  858. ! --- in/out ----------------------------
  859. type(TSds), intent(in) :: sds
  860. integer(<wp>), intent(out) :: data(:,:,:,:,:,:)
  861. integer, intent(out) :: status
  862. integer, intent(in), optional :: start(rank)
  863. integer, intent(in), optional :: stride(rank)
  864. ! --- local -------------------------------
  865. integer :: data_type
  866. integer :: the_start(rank)
  867. integer :: the_stride(rank)
  868. integer(wp_int8 ), pointer :: int8 (:,:,:,:,:,:)
  869. integer(wp_int16), pointer :: int16(:,:,:,:,:,:)
  870. integer(wp_int32), pointer :: int32(:,:,:,:,:,:)
  871. integer(wp_int64), pointer :: int64(:,:,:,:,:,:)
  872. ! --- external ----------------------------
  873. integer(wpi), external :: sfRData
  874. ! --- begin -------------------------------
  875. ! check data rank and shape:
  876. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  877. ! read data of specified kind:
  878. the_start = 0; if ( present(start ) ) the_start = start
  879. the_stride = 1; if ( present(stride) ) the_stride = stride
  880. call GetInfo( sds, status, data_type=data_type )
  881. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  882. select case ( data_type )
  883. case ( DFNT_INT8 )
  884. call pa_Init( int8 )
  885. call pa_SetShape( int8 , shape(data) )
  886. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  887. data = int(int8,kind=<wp>)
  888. call pa_Done( int8 )
  889. case ( DFNT_INT16 )
  890. call pa_Init( int16 )
  891. call pa_SetShape( int16, shape(data) )
  892. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  893. data = int(int16,kind=<wp>)
  894. call pa_Done( int16 )
  895. case ( DFNT_INT32 )
  896. call pa_Init( int32 )
  897. call pa_SetShape( int32, shape(data) )
  898. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  899. data = int(int32,kind=<wp>)
  900. call pa_Done( int32 )
  901. case ( DFNT_INT64 )
  902. call pa_Init( int64 )
  903. call pa_SetShape( int64, shape(data) )
  904. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  905. data = int(int64,kind=<wp>)
  906. call pa_Done( int64 )
  907. case default
  908. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  909. write (*,'("ERROR in ",a)') rname; status=1; return
  910. end select
  911. if ( status == FAIL ) then
  912. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  913. write (*,'("ERROR in ",a)') rname; status=1; return
  914. end if
  915. ! ok
  916. status = 0
  917. end subroutine sds_ReadData_i<wp>_6d
  918. ! ***
  919. subroutine sds_ReadData_i<wp>_7d( sds, data, status, start, stride )
  920. use parray, only : pa_Init, pa_SetShape, pa_Done
  921. use file_hdf_base, only : wpi
  922. use file_hdf_base, only : TSds
  923. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  924. use file_hdf_base, only : CheckInfo, GetInfo
  925. ! --- const ------------------------------
  926. character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_7d'
  927. integer, parameter :: rank = 7
  928. ! --- in/out ----------------------------
  929. type(TSds), intent(in) :: sds
  930. integer(<wp>), intent(out) :: data(:,:,:,:,:,:,:)
  931. integer, intent(out) :: status
  932. integer, intent(in), optional :: start(rank)
  933. integer, intent(in), optional :: stride(rank)
  934. ! --- local -------------------------------
  935. integer :: data_type
  936. integer :: the_start(rank)
  937. integer :: the_stride(rank)
  938. integer(wp_int8 ), pointer :: int8 (:,:,:,:,:,:,:)
  939. integer(wp_int16), pointer :: int16(:,:,:,:,:,:,:)
  940. integer(wp_int32), pointer :: int32(:,:,:,:,:,:,:)
  941. integer(wp_int64), pointer :: int64(:,:,:,:,:,:,:)
  942. ! --- external ----------------------------
  943. integer(wpi), external :: sfRData
  944. ! --- begin -------------------------------
  945. ! check data rank and shape:
  946. !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
  947. ! read data of specified kind:
  948. the_start = 0; if ( present(start ) ) the_start = start
  949. the_stride = 1; if ( present(stride) ) the_stride = stride
  950. call GetInfo( sds, status, data_type=data_type )
  951. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  952. select case ( data_type )
  953. case ( DFNT_INT8 )
  954. call pa_Init( int8 )
  955. call pa_SetShape( int8 , shape(data) )
  956. status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
  957. data = int(int8,kind=<wp>)
  958. call pa_Done( int8 )
  959. case ( DFNT_INT16 )
  960. call pa_Init( int16 )
  961. call pa_SetShape( int16, shape(data) )
  962. status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
  963. data = int(int16,kind=<wp>)
  964. call pa_Done( int16 )
  965. case ( DFNT_INT32 )
  966. call pa_Init( int32 )
  967. call pa_SetShape( int32, shape(data) )
  968. status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
  969. data = int(int32,kind=<wp>)
  970. call pa_Done( int32 )
  971. case ( DFNT_INT64 )
  972. call pa_Init( int64 )
  973. call pa_SetShape( int64, shape(data) )
  974. status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
  975. data = int(int64,kind=<wp>)
  976. call pa_Done( int64 )
  977. case default
  978. write (*,'("ERROR - not implemented for data type ",i6)') data_type
  979. write (*,'("ERROR in ",a)') rname; status=1; return
  980. end select
  981. if ( status == FAIL ) then
  982. write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
  983. write (*,'("ERROR in ",a)') rname; status=1; return
  984. end if
  985. ! ok
  986. status = 0
  987. end subroutine sds_ReadData_i<wp>_7d
  988. ! =============================================================
  989. ! === Write data
  990. ! =============================================================
  991. subroutine sds_WriteData_i<wp>_1d( sds, data, status, start, stride )
  992. use file_hdf_base, only : wpi
  993. use file_hdf_base, only : TSds
  994. ! --- const --------------------------
  995. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_1d'
  996. integer, parameter :: rank = 1
  997. ! --- in/out -------------------------
  998. type(TSds), intent(in) :: sds
  999. integer(<wp>), intent(in) :: data(:)
  1000. integer, intent(out) :: status
  1001. integer, intent(in), optional :: start(rank)
  1002. integer, intent(in), optional :: stride(rank)
  1003. ! --- local -------------------------------
  1004. integer :: the_start(rank), the_stride(rank)
  1005. ! --- external ----------------------------
  1006. integer(wpi), external :: sfWData
  1007. ! --- begin -------------------------------
  1008. !! check shape
  1009. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1010. ! print *, 'Shape of data does not match shape specified during creation:'
  1011. ! print *, ' data : ', shape(data)
  1012. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1013. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_1d'
  1014. !end if
  1015. ! write data:
  1016. the_start = 0; if ( present(start ) ) the_start = start
  1017. the_stride = 1; if ( present(stride) ) the_stride = stride
  1018. select case ( sds%typ )
  1019. case ( 'int' )
  1020. select case ( sds%knd )
  1021. case ( 1 )
  1022. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1023. case ( 2 )
  1024. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1025. case ( 4 )
  1026. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1027. case ( 8 )
  1028. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1029. case default
  1030. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1031. write (*,'("ERROR in ",a)') rname; status=1; return
  1032. end select
  1033. case ( 'flt' )
  1034. select case ( sds%knd )
  1035. case ( 4 )
  1036. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1037. case ( 8 )
  1038. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1039. case default
  1040. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1041. write (*,'("ERROR in ",a)') rname; status=1; return
  1042. end select
  1043. case default
  1044. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1045. write (*,'("ERROR in ",a)') rname; status=1; return
  1046. end select
  1047. if ( status == FAIL ) then
  1048. write (*,'("ERROR - writing data set:")')
  1049. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1050. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1051. write (*,'("ERROR in ",a)') rname; status=1; return
  1052. end if
  1053. ! ok
  1054. status = 0
  1055. end subroutine sds_WriteData_i<wp>_1d
  1056. ! ***
  1057. subroutine sds_WriteData_i<wp>_2d( sds, data, status, start, stride )
  1058. use file_hdf_base, only : wpi
  1059. use file_hdf_base, only : TSds
  1060. ! --- const --------------------------
  1061. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_2d'
  1062. integer, parameter :: rank = 2
  1063. ! --- in/out -------------------------
  1064. type(TSds), intent(in) :: sds
  1065. integer(<wp>), intent(in) :: data(:,:)
  1066. integer, intent(out) :: status
  1067. integer, intent(in), optional :: start(rank)
  1068. integer, intent(in), optional :: stride(rank)
  1069. ! --- local -------------------------------
  1070. integer :: the_start(rank), the_stride(rank)
  1071. ! --- external ----------------------------
  1072. integer(wpi), external :: sfWData
  1073. ! --- begin -------------------------------
  1074. !! check shape
  1075. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1076. ! print *, 'Shape of data does not match shape specified during creation:'
  1077. ! print *, ' data : ', shape(data)
  1078. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1079. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_2d'
  1080. !end if
  1081. ! write data:
  1082. the_start = 0; if ( present(start ) ) the_start = start
  1083. the_stride = 1; if ( present(stride) ) the_stride = stride
  1084. select case ( sds%typ )
  1085. case ( 'int' )
  1086. select case ( sds%knd )
  1087. case ( 1 )
  1088. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1089. case ( 2 )
  1090. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1091. case ( 4 )
  1092. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1093. case ( 8 )
  1094. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1095. case default
  1096. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1097. write (*,'("ERROR in ",a)') rname; status=1; return
  1098. end select
  1099. case ( 'flt' )
  1100. select case ( sds%knd )
  1101. case ( 4 )
  1102. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1103. case ( 8 )
  1104. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1105. case default
  1106. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1107. write (*,'("ERROR in ",a)') rname; status=1; return
  1108. end select
  1109. case default
  1110. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1111. write (*,'("ERROR in ",a)') rname; status=1; return
  1112. end select
  1113. if ( status == FAIL ) then
  1114. write (*,'("ERROR - writing data set:")')
  1115. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1116. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1117. write (*,'("ERROR in ",a)') rname; status=1; return
  1118. end if
  1119. ! ok
  1120. status = 0
  1121. end subroutine sds_WriteData_i<wp>_2d
  1122. ! ***
  1123. subroutine sds_WriteData_i<wp>_3d( sds, data, status, start, stride )
  1124. use file_hdf_base, only : wpi
  1125. use file_hdf_base, only : TSds
  1126. ! --- const --------------------------
  1127. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_3d'
  1128. integer, parameter :: rank = 3
  1129. ! --- in/out -------------------------
  1130. type(TSds), intent(in) :: sds
  1131. integer(<wp>), intent(in) :: data(:,:,:)
  1132. integer, intent(out) :: status
  1133. integer, intent(in), optional :: start(rank)
  1134. integer, intent(in), optional :: stride(rank)
  1135. ! --- local -------------------------------
  1136. integer :: the_start(rank), the_stride(rank)
  1137. ! --- external ----------------------------
  1138. integer(wpi), external :: sfWData
  1139. ! --- begin -------------------------------
  1140. !! check shape
  1141. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1142. ! print *, 'Shape of data does not match shape specified during creation:'
  1143. ! print *, ' data : ', shape(data)
  1144. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1145. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_3d'
  1146. !end if
  1147. ! write data:
  1148. the_start = 0; if ( present(start ) ) the_start = start
  1149. the_stride = 1; if ( present(stride) ) the_stride = stride
  1150. select case ( sds%typ )
  1151. case ( 'int' )
  1152. select case ( sds%knd )
  1153. case ( 1 )
  1154. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1155. case ( 2 )
  1156. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1157. case ( 4 )
  1158. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1159. case ( 8 )
  1160. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1161. case default
  1162. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1163. write (*,'("ERROR in ",a)') rname; status=1; return
  1164. end select
  1165. case ( 'flt' )
  1166. select case ( sds%knd )
  1167. case ( 4 )
  1168. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1169. case ( 8 )
  1170. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1171. case default
  1172. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1173. write (*,'("ERROR in ",a)') rname; status=1; return
  1174. end select
  1175. case default
  1176. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1177. write (*,'("ERROR in ",a)') rname; status=1; return
  1178. end select
  1179. if ( status == FAIL ) then
  1180. write (*,'("ERROR - writing data set:")')
  1181. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1182. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1183. write (*,'("ERROR in ",a)') rname; status=1; return
  1184. end if
  1185. ! ok
  1186. status = 0
  1187. end subroutine sds_WriteData_i<wp>_3d
  1188. ! ***
  1189. subroutine sds_WriteData_i<wp>_4d( sds, data, status, start, stride )
  1190. use file_hdf_base, only : wpi
  1191. use file_hdf_base, only : TSds
  1192. ! --- const --------------------------
  1193. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_4d'
  1194. integer, parameter :: rank = 4
  1195. ! --- in/out -------------------------
  1196. type(TSds), intent(in) :: sds
  1197. integer(<wp>), intent(in) :: data(:,:,:,:)
  1198. integer, intent(out) :: status
  1199. integer, intent(in), optional :: start(rank)
  1200. integer, intent(in), optional :: stride(rank)
  1201. ! --- local -------------------------------
  1202. integer :: the_start(rank), the_stride(rank)
  1203. ! --- external ----------------------------
  1204. integer(wpi), external :: sfWData
  1205. ! --- begin -------------------------------
  1206. !! check shape
  1207. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1208. ! print *, 'Shape of data does not match shape specified during creation:'
  1209. ! print *, ' data : ', shape(data)
  1210. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1211. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_4d'
  1212. !end if
  1213. ! write data:
  1214. the_start = 0; if ( present(start ) ) the_start = start
  1215. the_stride = 1; if ( present(stride) ) the_stride = stride
  1216. select case ( sds%typ )
  1217. case ( 'int' )
  1218. select case ( sds%knd )
  1219. case ( 1 )
  1220. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1221. case ( 2 )
  1222. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1223. case ( 4 )
  1224. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1225. case ( 8 )
  1226. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1227. case default
  1228. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1229. write (*,'("ERROR in ",a)') rname; status=1; return
  1230. end select
  1231. case ( 'flt' )
  1232. select case ( sds%knd )
  1233. case ( 4 )
  1234. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1235. case ( 8 )
  1236. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1237. case default
  1238. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1239. write (*,'("ERROR in ",a)') rname; status=1; return
  1240. end select
  1241. case default
  1242. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1243. write (*,'("ERROR in ",a)') rname; status=1; return
  1244. end select
  1245. if ( status == FAIL ) then
  1246. write (*,'("ERROR - writing data set:")')
  1247. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1248. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1249. write (*,'("ERROR in ",a)') rname; status=1; return
  1250. end if
  1251. ! ok
  1252. status = 0
  1253. end subroutine sds_WriteData_i<wp>_4d
  1254. ! ***
  1255. subroutine sds_WriteData_i<wp>_5d( sds, data, status, start, stride )
  1256. use file_hdf_base, only : wpi
  1257. use file_hdf_base, only : TSds
  1258. ! --- const --------------------------
  1259. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_5d'
  1260. integer, parameter :: rank = 5
  1261. ! --- in/out -------------------------
  1262. type(TSds), intent(in) :: sds
  1263. integer(<wp>), intent(in) :: data(:,:,:,:,:)
  1264. integer, intent(out) :: status
  1265. integer, intent(in), optional :: start(rank)
  1266. integer, intent(in), optional :: stride(rank)
  1267. ! --- local -------------------------------
  1268. integer :: the_start(rank), the_stride(rank)
  1269. ! --- external ----------------------------
  1270. integer(wpi), external :: sfWData
  1271. ! --- begin -------------------------------
  1272. !! check shape
  1273. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1274. ! print *, 'Shape of data does not match shape specified during creation:'
  1275. ! print *, ' data : ', shape(data)
  1276. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1277. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_5d'
  1278. !end if
  1279. ! write data:
  1280. the_start = 0; if ( present(start ) ) the_start = start
  1281. the_stride = 1; if ( present(stride) ) the_stride = stride
  1282. select case ( sds%typ )
  1283. case ( 'int' )
  1284. select case ( sds%knd )
  1285. case ( 1 )
  1286. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1287. case ( 2 )
  1288. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1289. case ( 4 )
  1290. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1291. case ( 8 )
  1292. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1293. case default
  1294. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1295. write (*,'("ERROR in ",a)') rname; status=1; return
  1296. end select
  1297. case ( 'flt' )
  1298. select case ( sds%knd )
  1299. case ( 4 )
  1300. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1301. case ( 8 )
  1302. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1303. case default
  1304. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1305. write (*,'("ERROR in ",a)') rname; status=1; return
  1306. end select
  1307. case default
  1308. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1309. write (*,'("ERROR in ",a)') rname; status=1; return
  1310. end select
  1311. if ( status == FAIL ) then
  1312. write (*,'("ERROR - writing data set:")')
  1313. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1314. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1315. write (*,'("ERROR in ",a)') rname; status=1; return
  1316. end if
  1317. ! ok
  1318. status = 0
  1319. end subroutine sds_WriteData_i<wp>_5d
  1320. ! ***
  1321. subroutine sds_WriteData_i<wp>_6d( sds, data, status, start, stride )
  1322. use file_hdf_base, only : wpi
  1323. use file_hdf_base, only : TSds
  1324. ! --- const --------------------------
  1325. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_6d'
  1326. integer, parameter :: rank = 6
  1327. ! --- in/out -------------------------
  1328. type(TSds), intent(in) :: sds
  1329. integer(<wp>), intent(in) :: data(:,:,:,:,:,:)
  1330. integer, intent(out) :: status
  1331. integer, intent(in), optional :: start(rank)
  1332. integer, intent(in), optional :: stride(rank)
  1333. ! --- local -------------------------------
  1334. integer :: the_start(rank), the_stride(rank)
  1335. ! --- external ----------------------------
  1336. integer(wpi), external :: sfWData
  1337. ! --- begin -------------------------------
  1338. !! check shape
  1339. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1340. ! print *, 'Shape of data does not match shape specified during creation:'
  1341. ! print *, ' data : ', shape(data)
  1342. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1343. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_6d'
  1344. !end if
  1345. ! write data:
  1346. the_start = 0; if ( present(start ) ) the_start = start
  1347. the_stride = 1; if ( present(stride) ) the_stride = stride
  1348. select case ( sds%typ )
  1349. case ( 'int' )
  1350. select case ( sds%knd )
  1351. case ( 1 )
  1352. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1353. case ( 2 )
  1354. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1355. case ( 4 )
  1356. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1357. case ( 8 )
  1358. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1359. case default
  1360. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1361. write (*,'("ERROR in ",a)') rname; status=1; return
  1362. end select
  1363. case ( 'flt' )
  1364. select case ( sds%knd )
  1365. case ( 4 )
  1366. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1367. case ( 8 )
  1368. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1369. case default
  1370. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1371. write (*,'("ERROR in ",a)') rname; status=1; return
  1372. end select
  1373. case default
  1374. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1375. write (*,'("ERROR in ",a)') rname; status=1; return
  1376. end select
  1377. if ( status == FAIL ) then
  1378. write (*,'("ERROR - writing data set:")')
  1379. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1380. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1381. write (*,'("ERROR in ",a)') rname; status=1; return
  1382. end if
  1383. ! ok
  1384. status = 0
  1385. end subroutine sds_WriteData_i<wp>_6d
  1386. ! ***
  1387. subroutine sds_WriteData_i<wp>_7d( sds, data, status, start, stride )
  1388. use file_hdf_base, only : wpi
  1389. use file_hdf_base, only : TSds
  1390. ! --- const --------------------------
  1391. character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_7d'
  1392. integer, parameter :: rank = 7
  1393. ! --- in/out -------------------------
  1394. type(TSds), intent(in) :: sds
  1395. integer(<wp>), intent(in) :: data(:,:,:,:,:,:,:)
  1396. integer, intent(out) :: status
  1397. integer, intent(in), optional :: start(rank)
  1398. integer, intent(in), optional :: stride(rank)
  1399. ! --- local -------------------------------
  1400. integer :: the_start(rank), the_stride(rank)
  1401. ! --- external ----------------------------
  1402. integer(wpi), external :: sfWData
  1403. ! --- begin -------------------------------
  1404. !! check shape
  1405. !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
  1406. ! print *, 'Shape of data does not match shape specified during creation:'
  1407. ! print *, ' data : ', shape(data)
  1408. ! print *, ' created for : ', sds%shp(1:sds%rnk)
  1409. ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_7d'
  1410. !end if
  1411. ! write data:
  1412. the_start = 0; if ( present(start ) ) the_start = start
  1413. the_stride = 1; if ( present(stride) ) the_stride = stride
  1414. select case ( sds%typ )
  1415. case ( 'int' )
  1416. select case ( sds%knd )
  1417. case ( 1 )
  1418. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
  1419. case ( 2 )
  1420. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
  1421. case ( 4 )
  1422. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
  1423. case ( 8 )
  1424. status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
  1425. case default
  1426. write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
  1427. write (*,'("ERROR in ",a)') rname; status=1; return
  1428. end select
  1429. case ( 'flt' )
  1430. select case ( sds%knd )
  1431. case ( 4 )
  1432. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
  1433. case ( 8 )
  1434. status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
  1435. case default
  1436. write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
  1437. write (*,'("ERROR in ",a)') rname; status=1; return
  1438. end select
  1439. case default
  1440. write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
  1441. write (*,'("ERROR in ",a)') rname; status=1; return
  1442. end select
  1443. if ( status == FAIL ) then
  1444. write (*,'("ERROR - writing data set:")')
  1445. write (*,'("ERROR - data set : ",a)') trim(sds%name)
  1446. write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
  1447. write (*,'("ERROR in ",a)') rname; status=1; return
  1448. end if
  1449. ! ok
  1450. status = 0
  1451. end subroutine sds_WriteData_i<wp>_7d
  1452. ! ############################################################
  1453. ! ###
  1454. ! ### dimensions
  1455. ! ###
  1456. ! ############################################################
  1457. ! ================================================================
  1458. ! set dimension scale
  1459. ! ================================================================
  1460. subroutine dim_SetScale_i<wp>( sdim, scale, status, knd )
  1461. use file_hdf_base, only : wpi
  1462. use file_hdf_base, only : TSdsDim
  1463. use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
  1464. ! --- in/out -------------------------
  1465. type(TSdsDim), intent(in) :: sdim
  1466. integer(<wp>), intent(in) :: scale(:)
  1467. integer, intent(out) :: status
  1468. integer, intent(in), optional :: knd
  1469. ! --- const --------------------------
  1470. character(len=*), parameter :: rname = mname//'/dim_SetScale_i<wp>'
  1471. ! --- local ---------------------------
  1472. integer :: ikind
  1473. ! --- external ---------------------------
  1474. integer(wpi), external :: sfSDScale
  1475. ! --- begin ---------------------------
  1476. ikind = kind(scale)
  1477. if ( present(knd) ) ikind = knd
  1478. select case ( ikind )
  1479. case ( 1 )
  1480. status = sfSDScale( sdim%id, size(scale), DFNT_INT8 , int(scale,kind=wp_int8 ) )
  1481. case ( 2 )
  1482. status = sfSDScale( sdim%id, size(scale), DFNT_INT16, int(scale,kind=wp_int16) )
  1483. case ( 4 )
  1484. status = sfSDScale( sdim%id, size(scale), DFNT_INT32, int(scale,kind=wp_int32) )
  1485. case ( 8 )
  1486. status = sfSDScale( sdim%id, size(scale), DFNT_INT64, int(scale,kind=wp_int64) )
  1487. case default
  1488. write (*,'("ERROR - unsupported integer kind : ",i4)') ikind
  1489. write (*,'("ERROR in ",a)') rname; status=1; return
  1490. end select
  1491. if ( status /= SUCCEED ) then
  1492. write (*,'("ERROR - writing scale")')
  1493. write (*,'("ERROR in ",a)') rname; status=1; return
  1494. end if
  1495. ! ok
  1496. status = 0
  1497. end subroutine dim_SetScale_i<wp>
  1498. ! ================================================================
  1499. ! set dimension stuff
  1500. ! ================================================================
  1501. subroutine sds_SetDim_i<wp>( sds, dim_index, name, unit, scale, status, knd )
  1502. use file_hdf_base, only : TSds, TSdsDim, Init, Done
  1503. use file_hdf_base, only : MAX_DATA_RANK
  1504. use file_hdf_base, only : GetInfo
  1505. use file_hdf_base, only : Select, SetName
  1506. use file_hdf_s, only : WriteAttribute
  1507. ! --- in/out -------------------------
  1508. type(TSds), intent(in) :: sds
  1509. integer, intent(in) :: dim_index
  1510. character(len=*), intent(in) :: name
  1511. character(len=*), intent(in) :: unit
  1512. integer(<wp>), intent(in) :: scale(:)
  1513. integer, intent(out) :: status
  1514. integer, intent(in), optional :: knd
  1515. ! --- const --------------------------
  1516. character(len=*), parameter :: rname = mname//'/sds_SetDim_i<wp>'
  1517. ! --- local ---------------------------
  1518. integer :: data_rank, data_dims(0:MAX_DATA_RANK-1)
  1519. type(TSdsDim) :: sdim
  1520. ! --- begin ---------------------------
  1521. call GetInfo( sds, status, data_rank=data_rank, data_dims=data_dims )
  1522. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1523. if ( dim_index < 0 .or. dim_index > data_rank-1 ) then
  1524. write (*,'("ERROR - wrong dimension index : ",i4)') dim_index
  1525. write (*,'("ERROR - expecting range 0, .., ",i4)') data_rank-1
  1526. write (*,'("ERROR in ",a)') rname; status=1; return
  1527. end if
  1528. call Init( sdim, status )
  1529. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1530. call Select( sdim, sds, dim_index, status )
  1531. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1532. call SetName( sdim, name, status )
  1533. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1534. call WriteAttribute( sdim, 'unit', unit, status )
  1535. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1536. if ( size(scale) /= data_dims(dim_index) ) then
  1537. write (*,'("ERROR - wrong scale length : ",i4)') size(scale)
  1538. write (*,'("ERROR - expecting length ",i4," for dim index ",i4)') data_dims(dim_index), dim_index
  1539. write (*,'("ERROR in ",a)') rname; status=1; return
  1540. end if
  1541. call SetScale( sdim, scale, status, knd )
  1542. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1543. call Done( sdim, status )
  1544. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1545. ! ok
  1546. status = 0
  1547. end subroutine sds_SetDim_i<wp>
  1548. ! ================================================================
  1549. ! read attributes
  1550. ! ================================================================
  1551. subroutine dim_ReadAttribute_i<wp>_0d( sdim, name, i, status )
  1552. use file_hdf_base, only : TSdsDim
  1553. ! --- in/out -------------------------
  1554. type(TSdsDim), intent(in) :: sdim
  1555. character(len=*), intent(in) :: name
  1556. integer(<wp>), intent(out) :: i
  1557. integer, intent(out) :: status
  1558. ! --- const --------------------------
  1559. character(len=*), parameter :: rname = mname//'/dim_ReadAttribute_i<wp>_0d'
  1560. ! --- begin -------------------------------
  1561. call ReadAttribute( sdim%id, name, i, status )
  1562. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1563. ! ok
  1564. status = 0
  1565. end subroutine dim_ReadAttribute_i<wp>_0d
  1566. ! ***
  1567. subroutine dim_ReadAttribute_i<wp>_1d( sdim, name, i, status )
  1568. use file_hdf_base, only : TSdsDim
  1569. ! --- in/out -------------------------
  1570. type(TSdsDim), intent(in) :: sdim
  1571. character(len=*), intent(in) :: name
  1572. integer(<wp>), intent(out) :: i(:)
  1573. integer, intent(out) :: status
  1574. ! --- const --------------------------
  1575. character(len=*), parameter :: rname = mname//'/dim_ReadAttribute_i<wp>_1d'
  1576. ! --- begin -------------------------------
  1577. call ReadAttribute( sdim%id, name, i, status )
  1578. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1579. ! ok
  1580. status = 0
  1581. end subroutine dim_ReadAttribute_i<wp>_1d
  1582. ! =============================================================
  1583. ! === check attributes
  1584. ! =============================================================
  1585. subroutine dim_CheckAttribute_i<wp>_0d( sdim, name, i, status )
  1586. use file_hdf_base, only : TSdsDim
  1587. ! --- in/out -------------------------
  1588. type(TSdsDim), intent(in) :: sdim
  1589. character(len=*), intent(in) :: name
  1590. integer(<wp>), intent(in) :: i
  1591. integer, intent(inout) :: status
  1592. ! --- const --------------------------
  1593. character(len=*), parameter :: rname = mname//'/dim_CheckAttribute_i<wp>_0d'
  1594. ! --- local ------------------------------
  1595. logical :: verbose
  1596. ! --- begin ---------------------------
  1597. ! write error messages ?
  1598. verbose = status == 0
  1599. call CheckAttribute( sdim%id, name, i, status )
  1600. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1601. if (status<0) then
  1602. if (verbose) write (*,'("ERROR in ",a)') rname
  1603. status=-1; return
  1604. end if
  1605. ! ok
  1606. status = 0
  1607. end subroutine dim_CheckAttribute_i<wp>_0d
  1608. ! ***
  1609. subroutine dim_CheckAttribute_i<wp>_1d( sdim, name, i, status )
  1610. use file_hdf_base, only : TSdsDim
  1611. ! --- in/out -------------------------
  1612. type(TSdsDim), intent(in) :: sdim
  1613. character(len=*), intent(in) :: name
  1614. integer(<wp>), intent(in) :: i(:)
  1615. integer, intent(inout) :: status
  1616. ! --- const --------------------------
  1617. character(len=*), parameter :: rname = mname//'/dim_CheckAttribute_i<wp>_1d'
  1618. ! --- local ------------------------------
  1619. logical :: verbose
  1620. ! --- begin ---------------------------
  1621. ! write error messages ?
  1622. verbose = status == 0
  1623. call CheckAttribute( sdim%id, name, i, status )
  1624. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1625. if (status<0) then
  1626. if (verbose) write (*,'("ERROR in ",a)') rname
  1627. status=-1; return
  1628. end if
  1629. ! ok
  1630. status = 0
  1631. end subroutine dim_CheckAttribute_i<wp>_1d
  1632. ! ================================================================
  1633. ! write attributes
  1634. ! ================================================================
  1635. subroutine dim_WriteAttribute_i<wp>_0d( sdim, name, i, status, knd )
  1636. use file_hdf_base, only : TSdsDim
  1637. ! --- in/out -------------------------
  1638. type(TSdsDim), intent(in) :: sdim
  1639. character(len=*), intent(in) :: name
  1640. integer(<wp>), intent(in) :: i
  1641. integer, intent(out) :: status
  1642. integer, intent(in), optional :: knd
  1643. ! --- const --------------------------
  1644. character(len=*), parameter :: rname = mname//'/dim_WriteAttribute_i<wp>_0d'
  1645. ! --- begin -------------------------------
  1646. call WriteAttribute( sdim%id, name, i, status, knd )
  1647. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1648. ! ok
  1649. status = 0
  1650. end subroutine dim_WriteAttribute_i<wp>_0d
  1651. ! ***
  1652. subroutine dim_WriteAttribute_i<wp>_1d( sdim, name, i, status, knd )
  1653. use file_hdf_base, only : TSdsDim
  1654. ! --- in/out -------------------------
  1655. type(TSdsDim), intent(in) :: sdim
  1656. character(len=*), intent(in) :: name
  1657. integer(<wp>), intent(in) :: i(:)
  1658. integer, intent(out) :: status
  1659. integer, intent(in), optional :: knd
  1660. ! --- const --------------------------
  1661. character(len=*), parameter :: rname = mname//'/dim_WriteAttribute_i<wp>_1d'
  1662. ! --- begin -------------------------------
  1663. call WriteAttribute( sdim%id, name, i, status, knd )
  1664. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1665. ! ok
  1666. status = 0
  1667. end subroutine dim_WriteAttribute_i<wp>_1d
  1668. ! ############################################################
  1669. ! ###
  1670. ! ### hdf files
  1671. ! ###
  1672. ! ############################################################
  1673. ! ================================================================
  1674. ! read attributes
  1675. ! ================================================================
  1676. subroutine hdf_ReadAttribute_i<wp>_0d( hdf, name, i, status )
  1677. use file_hdf_base, only : THdfFile
  1678. ! --- in/out -------------------------
  1679. type(THdfFile), intent(in) :: hdf
  1680. character(len=*), intent(in) :: name
  1681. integer(<wp>), intent(out) :: i
  1682. integer, intent(out) :: status
  1683. ! --- const --------------------------
  1684. character(len=*), parameter :: rname = mname//'/hdf_ReadAttribute_i<wp>_0d'
  1685. ! --- begin -------------------------------
  1686. call ReadAttribute( hdf%id, name, i, status )
  1687. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1688. ! ok
  1689. status = 0
  1690. end subroutine hdf_ReadAttribute_i<wp>_0d
  1691. ! ***
  1692. subroutine hdf_ReadAttribute_i<wp>_1d( hdf, name, i, status )
  1693. use file_hdf_base, only : THdfFile
  1694. ! --- in/out -------------------------
  1695. type(THdfFile), intent(in) :: hdf
  1696. character(len=*), intent(in) :: name
  1697. integer(<wp>), intent(out) :: i(:)
  1698. integer, intent(out) :: status
  1699. ! --- const --------------------------
  1700. character(len=*), parameter :: rname = mname//'/hdf_ReadAttribute_i<wp>_1d'
  1701. ! --- begin -------------------------------
  1702. call ReadAttribute( hdf%id, name, i, status )
  1703. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1704. ! ok
  1705. status = 0
  1706. end subroutine hdf_ReadAttribute_i<wp>_1d
  1707. ! =============================================================
  1708. ! === check attributes
  1709. ! =============================================================
  1710. subroutine hdf_CheckAttribute_i<wp>_0d( hdf, name, i, status )
  1711. use file_hdf_base, only : THdfFile
  1712. ! --- in/out -------------------------
  1713. type(THdfFile), intent(in) :: hdf
  1714. character(len=*), intent(in) :: name
  1715. integer(<wp>), intent(in) :: i
  1716. integer, intent(inout) :: status
  1717. ! --- const --------------------------
  1718. character(len=*), parameter :: rname = mname//'/hdf_CheckAttribute_i<wp>_0d'
  1719. ! --- local ------------------------------
  1720. logical :: verbose
  1721. ! --- begin ---------------------------
  1722. ! write error messages ?
  1723. verbose = status == 0
  1724. call CheckAttribute( hdf%id, name, i, status )
  1725. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1726. if (status<0) then
  1727. if (verbose) write (*,'("ERROR in ",a)') rname
  1728. status=-1; return
  1729. end if
  1730. ! ok
  1731. status = 0
  1732. end subroutine hdf_CheckAttribute_i<wp>_0d
  1733. ! ***
  1734. subroutine hdf_CheckAttribute_i<wp>_1d( hdf, name, i, status )
  1735. use file_hdf_base, only : THdfFile
  1736. ! --- in/out -------------------------
  1737. type(THdfFile), intent(in) :: hdf
  1738. character(len=*), intent(in) :: name
  1739. integer(<wp>), intent(in) :: i(:)
  1740. integer, intent(inout) :: status
  1741. ! --- const --------------------------
  1742. character(len=*), parameter :: rname = mname//'/hdf_CheckAttribute_i<wp>_1d'
  1743. ! --- local ------------------------------
  1744. logical :: verbose
  1745. ! --- begin ---------------------------
  1746. ! write error messages ?
  1747. verbose = status == 0
  1748. call CheckAttribute( hdf%id, name, i, status )
  1749. if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1750. if (status<0) then
  1751. if (verbose) write (*,'("ERROR in ",a)') rname
  1752. status=-1; return
  1753. end if
  1754. ! ok
  1755. status = 0
  1756. end subroutine hdf_CheckAttribute_i<wp>_1d
  1757. ! ================================================================
  1758. ! write attributes
  1759. ! ================================================================
  1760. subroutine hdf_WriteAttribute_i<wp>_0d( hdf, name, i, status, knd )
  1761. use file_hdf_base, only : THdfFile
  1762. ! --- in/out -------------------------
  1763. type(THdfFile), intent(in) :: hdf
  1764. character(len=*), intent(in) :: name
  1765. integer(<wp>), intent(in) :: i
  1766. integer, intent(out) :: status
  1767. integer, intent(in), optional :: knd
  1768. ! --- const --------------------------
  1769. character(len=*), parameter :: rname = mname//'/hdf_WriteAttribute_i<wp>_0d'
  1770. ! --- begin -------------------------------
  1771. call WriteAttribute( hdf%id, name, i, status, knd )
  1772. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1773. ! ok
  1774. status = 0
  1775. end subroutine hdf_WriteAttribute_i<wp>_0d
  1776. ! ***
  1777. subroutine hdf_WriteAttribute_i<wp>_1d( hdf, name, i, status, knd )
  1778. use file_hdf_base, only : THdfFile
  1779. ! --- in/out -------------------------
  1780. type(THdfFile), intent(in) :: hdf
  1781. character(len=*), intent(in) :: name
  1782. integer(<wp>), intent(in) :: i(:)
  1783. integer, intent(out) :: status
  1784. integer, intent(in), optional :: knd
  1785. ! --- const --------------------------
  1786. character(len=*), parameter :: rname = mname//'/hdf_WriteAttribute_i<wp>_1d'
  1787. ! --- begin -------------------------------
  1788. call WriteAttribute( hdf%id, name, i, status, knd )
  1789. if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
  1790. ! ok
  1791. status = 0
  1792. end subroutine hdf_WriteAttribute_i<wp>_1d
  1793. end module file_hdf_i<wp>