file_hdf_r8.F90 85 KB

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