12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531 |
- !
- ! Template for file_hdf routines with integer arguments.
- !
- ! To generate kind specific versions, use:
- !
- ! /bin/sed -e 's/<wp>/1/g' file_hdf_iwp.F90.in > file_hdf_i1.F90
- ! /bin/sed -e 's/<wp>/2/g' file_hdf_iwp.F90.in > file_hdf_i2.F90
- ! /bin/sed -e 's/<wp>/4/g' file_hdf_iwp.F90.in > file_hdf_i4.F90
- ! /bin/sed -e 's/<wp>/8/g' file_hdf_iwp.F90.in > file_hdf_i8.F90
- !
- module file_hdf_i<wp>
- implicit none
-
- ! --- in/out --------------------------
-
- private
-
- public :: ReadData
- public :: WriteData
-
- public :: SetScale, SetDim
- public :: ReadAttribute, CheckAttribute
- public :: WriteAttribute
-
- ! --- const ----------------------------
-
- include "hdf.f90"
-
- character(len=*), parameter :: mname = 'file_hdf_i<wp>'
-
- ! --- interfaces ------------------------
-
- interface ReadData
- module procedure sds_ReadData_i<wp>_1d
- module procedure sds_ReadData_i<wp>_2d
- module procedure sds_ReadData_i<wp>_3d
- module procedure sds_ReadData_i<wp>_4d
- module procedure sds_ReadData_i<wp>_5d
- module procedure sds_ReadData_i<wp>_6d
- module procedure sds_ReadData_i<wp>_7d
- end interface
- interface WriteData
- module procedure sds_WriteData_i<wp>_1d
- module procedure sds_WriteData_i<wp>_2d
- module procedure sds_WriteData_i<wp>_3d
- module procedure sds_WriteData_i<wp>_4d
- module procedure sds_WriteData_i<wp>_5d
- module procedure sds_WriteData_i<wp>_6d
- module procedure sds_WriteData_i<wp>_7d
- end interface
-
- interface SetScale
- module procedure dim_SetScale_i<wp>
- end interface
-
- interface SetDim
- module procedure sds_SetDim_i<wp>
- end interface
-
- interface ReadAttribute
- module procedure obj_ReadAttribute_i<wp>_0d
- module procedure obj_ReadAttribute_i<wp>_1d
- !
- module procedure sds_ReadAttribute_i<wp>_0d
- module procedure sds_ReadAttribute_i<wp>_1d
- !
- module procedure dim_ReadAttribute_i<wp>_0d
- module procedure dim_ReadAttribute_i<wp>_1d
- !
- module procedure hdf_ReadAttribute_i<wp>_0d
- module procedure hdf_ReadAttribute_i<wp>_1d
- end interface
-
- interface CheckAttribute
- module procedure obj_CheckAttribute_i<wp>_0d
- module procedure obj_CheckAttribute_i<wp>_1d
- !
- module procedure sds_CheckAttribute_i<wp>_0d
- module procedure sds_CheckAttribute_i<wp>_1d
- !
- module procedure dim_CheckAttribute_i<wp>_0d
- module procedure dim_CheckAttribute_i<wp>_1d
- !
- module procedure hdf_CheckAttribute_i<wp>_0d
- module procedure hdf_CheckAttribute_i<wp>_1d
- end interface
-
- interface WriteAttribute
- module procedure obj_WriteAttribute_i<wp>_0d
- module procedure obj_WriteAttribute_i<wp>_1d
- !
- module procedure sds_WriteAttribute_i<wp>_0d
- module procedure sds_WriteAttribute_i<wp>_1d
- !
- module procedure dim_WriteAttribute_i<wp>_0d
- module procedure dim_WriteAttribute_i<wp>_1d
- !
- module procedure hdf_WriteAttribute_i<wp>_0d
- module procedure hdf_WriteAttribute_i<wp>_1d
- end interface
-
- contains
- ! ############################################################
- ! ###
- ! ### objects
- ! ###
- ! ############################################################
-
-
- ! ================================================================
- ! ===
- ! === read attributes
- ! ===
- ! ================================================================
-
-
- subroutine obj_ReadAttribute_i<wp>_0d( obj_id, name, i, status )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : FindAttribute, CheckAttributeInfo, GetAttributeInfo
-
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_ReadAttribute_i<wp>_0d'
- ! --- local -------------------------------
-
- integer :: attr_index, data_type
- integer(wp_int8 ) :: int8
- integer(wp_int16) :: int16
- integer(wp_int32) :: int32
- integer(wp_int64) :: int64
-
- ! --- external ----------------------------
- integer(wpi), external :: sfRNAtt
- ! --- begin -------------------------------
-
- call FindAttribute( obj_id, name, attr_index, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call CheckAttributeInfo( obj_id, attr_index, status, n_values=1 )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! extract value:
- call GetAttributeInfo( obj_id, attr_index, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- status = sfRNAtt( obj_id, attr_index, int8 ); i = int(int8 ,kind=<wp>)
- case ( DFNT_INT16 )
- status = sfRNAtt( obj_id, attr_index, int16 ); i = int(int16,kind=<wp>)
- case ( DFNT_INT32 )
- status = sfRNAtt( obj_id, attr_index, int32 ); i = int(int32,kind=<wp>)
- case ( DFNT_INT64 )
- status = sfRNAtt( obj_id, attr_index, int64 ); i = int(int64,kind=<wp>)
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status /= SUCCEED ) then
- write (*,'("ERROR - reading attribute : ",a)') trim(name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_ReadAttribute_i<wp>_0d
-
- ! ***
-
-
- subroutine obj_ReadAttribute_i<wp>_1d( obj_id, name, i, status )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : FindAttribute, CheckAttributeInfo, GetAttributeInfo
-
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i(:)
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_ReadAttribute_i<wp>_1d'
- ! --- local -------------------------------
-
- integer :: attr_index, data_type
- integer :: n
- integer(wp_int8 ), allocatable :: int8 (:)
- integer(wp_int16), allocatable :: int16(:)
- integer(wp_int32), allocatable :: int32(:)
- integer(wp_int64), allocatable :: int64(:)
-
- ! --- external ----------------------------
- integer(wpi), external :: sfRNAtt
- ! --- begin -------------------------------
-
- n = size(i)
-
- call FindAttribute( obj_id, name, attr_index, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call CheckAttributeInfo( obj_id, attr_index, status, n_values=n )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! extract value:
- call GetAttributeInfo( obj_id, attr_index, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- allocate( int8 (n) )
- status = sfRNAtt( obj_id, attr_index, int8 )
- i = int(int8 ,kind=<wp>)
- deallocate( int8 )
- case ( DFNT_INT16 )
- allocate( int16(n) )
- status = sfRNAtt( obj_id, attr_index, int16 )
- i = int(int16,kind=<wp>)
- deallocate( int16 )
- case ( DFNT_INT32 )
- allocate( int32(n) )
- status = sfRNAtt( obj_id, attr_index, int32 )
- i = int(int32,kind=<wp>)
- deallocate( int32 )
- case ( DFNT_INT64 )
- allocate( int64(n) )
- status = sfRNAtt( obj_id, attr_index, int64 )
- i = int(int64,kind=<wp>)
- deallocate( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status /= SUCCEED ) then
- write (*,'("ERROR - reading attribute : ",a)') trim(name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_ReadAttribute_i<wp>_1d
-
-
- ! ================================================================
- ! ===
- ! === check attributes
- ! ===
- ! ================================================================
-
-
- subroutine obj_CheckAttribute_i<wp>_0d( obj_id, name, i, status )
-
- use file_hdf_base, only : wpi
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_CheckAttribute_i<wp>_0d'
- ! --- local -------------------------------
-
- logical :: verbose
- integer(<wp>) :: attr_i
-
- ! --- begin -------------------------------
-
- ! write error messages ?
- verbose = status == 0
- call ReadAttribute( obj_id, name, attr_i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! check:
- if ( attr_i /= i ) then
- if (verbose) then
- write (*,'("ERROR - foud different attribute values:")')
- write (*,'("ERROR - attr name : ",a)') trim(name)
- write (*,'("ERROR - requested : ",i6)') i
- write (*,'("ERROR - found : ",i6)') attr_i
- write (*,'("ERROR in ",a)') rname
- end if
- status=-1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_CheckAttribute_i<wp>_0d
-
- ! ***
-
-
- subroutine obj_CheckAttribute_i<wp>_1d( obj_id, name, i, status )
-
- use file_hdf_base, only : wpi
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_CheckAttribute_i<wp>_1d'
- ! --- local -------------------------------
-
- logical :: verbose
- integer :: n
- integer(<wp>), allocatable :: attr_i(:)
- logical :: failed
-
- ! --- begin -------------------------------
-
- ! write error messages ?
- verbose = status == 0
- n = size(i)
- allocate( attr_i(n) )
-
- call ReadAttribute( obj_id, name, attr_i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! check:
- failed = any( attr_i /= i )
-
- ! clear
- deallocate( attr_i )
-
- ! not ok ?
- if ( failed ) then
- if (verbose) then
- write (*,'("ERROR - foud different attribute values:")')
- write (*,'("ERROR - attr name : ",a)') trim(name)
- write (*,'("ERROR - requested : ",i6)') i
- write (*,'("ERROR - found : ",i6)') attr_i
- write (*,'("ERROR in ",a)') rname
- end if
- status=-1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_CheckAttribute_i<wp>_1d
-
- ! ================================================================
- ! ===
- ! === write attributes
- ! ===
- ! ================================================================
-
-
- subroutine obj_WriteAttribute_i<wp>_0d( obj_id, name, i, status, knd )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(inout) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_WriteAttribute_i<wp>_0d'
- ! --- local -------------------------------
-
- integer :: ikind
- ! --- external ----------------------------
- integer(wpi), external :: sfSNAtt
- ! --- begin -------------------------------
- ikind = kind(i)
- if ( present(knd) ) ikind = knd
- select case ( ikind )
- case ( 1 )
- status = sfSNAtt( obj_id, name, DFNT_INT8 , 1, int(i,kind=wp_int8 ) )
- case ( 2 )
- status = sfSNAtt( obj_id, name, DFNT_INT16, 1, int(i,kind=wp_int16) )
- case ( 4 )
- status = sfSNAtt( obj_id, name, DFNT_INT32, 1, int(i,kind=wp_int32) )
- case ( 8 )
- status = sfSNAtt( obj_id, name, DFNT_INT64, 1, int(i,kind=wp_int64) )
- case default
- write (*,'("ERROR - no implementation for writing with kind ",i2)') ikind
- write (*,'("ERROR in ",a)') rname; status=-1; return
- end select
- if ( status /= SUCCEED ) then
- write (*,'("ERROR - while writing attribute:")')
- write (*,'("ERROR - attr name : ",a)') name
- write (*,'("ERROR - input kind : ",i2)') kind(i)
- write (*,'("ERROR - output kind : ",i2)') ikind
- write (*,'("ERROR in ",a)') rname; status=-1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_WriteAttribute_i<wp>_0d
-
-
- ! ***
-
-
- subroutine obj_WriteAttribute_i<wp>_1d( obj_id, name, i, status, knd )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- ! --- in/out -------------------------
-
- integer(wpi), intent(in) :: obj_id
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(inout) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/obj_WriteAttribute_i<wp>_1d'
- ! --- local -------------------------------
-
- integer :: ikind
- ! --- external ----------------------------
- integer(wpi), external :: sfSNAtt
- ! --- begin -------------------------------
- ikind = kind(i)
- if ( present(knd) ) ikind = knd
- select case ( ikind )
- case ( 1 )
- status = sfSNAtt( obj_id, name, DFNT_INT8 , size(i), int(i,kind=wp_int8 ) )
- case ( 2 )
- status = sfSNAtt( obj_id, name, DFNT_INT16, size(i), int(i,kind=wp_int16) )
- case ( 4 )
- status = sfSNAtt( obj_id, name, DFNT_INT32, size(i), int(i,kind=wp_int32) )
- case ( 8 )
- status = sfSNAtt( obj_id, name, DFNT_INT64, size(i), int(i,kind=wp_int64) )
- case default
- write (*,'("ERROR - no implementation for writing with kind ",i2)') ikind
- write (*,'("ERROR in ",a)') rname; status=-1; return
- end select
- if ( status /= SUCCEED ) then
- write (*,'("ERROR - while writing attribute:")')
- write (*,'("ERROR - attr name : ",a)') name
- write (*,'("ERROR - input kind : ",i2)') kind(i)
- write (*,'("ERROR - output kind : ",i2)') ikind
- write (*,'("ERROR in ",a)') rname; status=-1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine obj_WriteAttribute_i<wp>_1d
-
-
-
- ! ############################################################
- ! ###
- ! ### scientific data sets
- ! ###
- ! ############################################################
-
- ! ================================================================
- ! read attributes
- ! ================================================================
-
-
- subroutine sds_ReadAttribute_i<wp>_0d( sds, name, i, status )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(Tsds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call ReadAttribute( sds%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine sds_ReadAttribute_i<wp>_1d( sds, name, i, status )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(Tsds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i(:)
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call ReadAttribute( sds%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadAttribute_i<wp>_1d
-
-
- ! =============================================================
- ! === check attributes
- ! =============================================================
-
- subroutine sds_CheckAttribute_i<wp>_0d( sds, name, i, status )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_CheckAttribute_i<wp>_0d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( sds%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine sds_CheckAttribute_i<wp>_0d
-
-
- ! ***
-
-
- subroutine sds_CheckAttribute_i<wp>_1d( sds, name, i, status )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_CheckAttribute_i<wp>_1d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( sds%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine sds_CheckAttribute_i<wp>_1d
-
-
- ! ================================================================
- ! write attributes
- ! ================================================================
-
-
- subroutine sds_WriteAttribute_i<wp>_0d( sds, name, i, status, knd )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(Tsds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(out) :: status
-
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call WriteAttribute( sds%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine sds_WriteAttribute_i<wp>_1d( sds, name, i, status, knd )
-
- use file_hdf_base, only : TSds
- ! --- in/out -------------------------
-
- type(Tsds), intent(in) :: sds
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call WriteAttribute( sds%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteAttribute_i<wp>_1d
-
-
- ! =============================================================
- ! === read data
- ! =============================================================
-
- subroutine sds_ReadData_i<wp>_1d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_1d'
- integer, parameter :: rank = 1
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:)
- integer(wp_int16), pointer :: int16(:)
- integer(wp_int32), pointer :: int32(:)
- integer(wp_int64), pointer :: int64(:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_1d
-
- ! ***
- subroutine sds_ReadData_i<wp>_2d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_2d'
- integer, parameter :: rank = 2
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:)
- integer(wp_int16), pointer :: int16(:,:)
- integer(wp_int32), pointer :: int32(:,:)
- integer(wp_int64), pointer :: int64(:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_2d
-
- ! ***
- subroutine sds_ReadData_i<wp>_3d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_3d'
- integer, parameter :: rank = 3
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:,:)
- integer(wp_int16), pointer :: int16(:,:,:)
- integer(wp_int32), pointer :: int32(:,:,:)
- integer(wp_int64), pointer :: int64(:,:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_3d
-
- ! ***
- subroutine sds_ReadData_i<wp>_4d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_4d'
- integer, parameter :: rank = 4
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:,:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:,:,:)
- integer(wp_int16), pointer :: int16(:,:,:,:)
- integer(wp_int32), pointer :: int32(:,:,:,:)
- integer(wp_int64), pointer :: int64(:,:,:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_4d
-
- ! ***
- subroutine sds_ReadData_i<wp>_5d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_5d'
- integer, parameter :: rank = 5
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:,:,:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:,:,:,:)
- integer(wp_int16), pointer :: int16(:,:,:,:,:)
- integer(wp_int32), pointer :: int32(:,:,:,:,:)
- integer(wp_int64), pointer :: int64(:,:,:,:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_5d
-
- ! ***
- subroutine sds_ReadData_i<wp>_6d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_6d'
- integer, parameter :: rank = 6
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:,:,:,:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:,:,:,:,:)
- integer(wp_int16), pointer :: int16(:,:,:,:,:,:)
- integer(wp_int32), pointer :: int32(:,:,:,:,:,:)
- integer(wp_int64), pointer :: int64(:,:,:,:,:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_6d
-
- ! ***
- subroutine sds_ReadData_i<wp>_7d( sds, data, status, start, stride )
-
- use parray, only : pa_Init, pa_SetShape, pa_Done
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- use file_hdf_base, only : CheckInfo, GetInfo
- ! --- const ------------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_ReadData_i<wp>_7d'
- integer, parameter :: rank = 7
-
- ! --- in/out ----------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(out) :: data(:,:,:,:,:,:,:)
- integer, intent(out) :: status
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: data_type
- integer :: the_start(rank)
- integer :: the_stride(rank)
- integer(wp_int8 ), pointer :: int8 (:,:,:,:,:,:,:)
- integer(wp_int16), pointer :: int16(:,:,:,:,:,:,:)
- integer(wp_int32), pointer :: int32(:,:,:,:,:,:,:)
- integer(wp_int64), pointer :: int64(:,:,:,:,:,:,:)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfRData
- ! --- begin -------------------------------
-
- ! check data rank and shape:
- !call CheckInfo( sds, data_rank=rank, data_dims=shape(data) )
- ! read data of specified kind:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- call GetInfo( sds, status, data_type=data_type )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- select case ( data_type )
- case ( DFNT_INT8 )
- call pa_Init( int8 )
- call pa_SetShape( int8 , shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int8 ), int8 )
- data = int(int8,kind=<wp>)
- call pa_Done( int8 )
- case ( DFNT_INT16 )
- call pa_Init( int16 )
- call pa_SetShape( int16, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int16), int16 )
- data = int(int16,kind=<wp>)
- call pa_Done( int16 )
- case ( DFNT_INT32 )
- call pa_Init( int32 )
- call pa_SetShape( int32, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int32), int32 )
- data = int(int32,kind=<wp>)
- call pa_Done( int32 )
- case ( DFNT_INT64 )
- call pa_Init( int64 )
- call pa_SetShape( int64, shape(data) )
- status = sfRData( sds%id, the_start, the_stride, shape(int64), int64 )
- data = int(int64,kind=<wp>)
- call pa_Done( int64 )
- case default
- write (*,'("ERROR - not implemented for data type ",i6)') data_type
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - reading data `",a,"`")') trim(sds%name)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_ReadData_i<wp>_7d
-
- ! =============================================================
- ! === Write data
- ! =============================================================
- subroutine sds_WriteData_i<wp>_1d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_1d'
- integer, parameter :: rank = 1
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_1d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_1d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_2d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_2d'
- integer, parameter :: rank = 2
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_2d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_2d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_3d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_3d'
- integer, parameter :: rank = 3
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_3d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_3d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_4d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_4d'
- integer, parameter :: rank = 4
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:,:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_4d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_4d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_5d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_5d'
- integer, parameter :: rank = 5
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:,:,:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_5d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_5d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_6d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_6d'
- integer, parameter :: rank = 6
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:,:,:,:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_6d'
- !end if
-
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_6d
-
-
- ! ***
-
- subroutine sds_WriteData_i<wp>_7d( sds, data, status, start, stride )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSds
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_WriteData_i<wp>_7d'
- integer, parameter :: rank = 7
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer(<wp>), intent(in) :: data(:,:,:,:,:,:,:)
- integer, intent(out) :: status
-
- integer, intent(in), optional :: start(rank)
- integer, intent(in), optional :: stride(rank)
-
- ! --- local -------------------------------
-
- integer :: the_start(rank), the_stride(rank)
-
- ! --- external ----------------------------
-
- integer(wpi), external :: sfWData
-
- ! --- begin -------------------------------
-
- !! check shape
- !if ( any( shape(data) /= sds%shp(1:sds%rnk) ) ) then
- ! print *, 'Shape of data does not match shape specified during creation:'
- ! print *, ' data : ', shape(data)
- ! print *, ' created for : ', sds%shp(1:sds%rnk)
- ! stop 'FATAL ERROR IN sds_WriteData_i<wp>_7d'
- !end if
- ! write data:
- the_start = 0; if ( present(start ) ) the_start = start
- the_stride = 1; if ( present(stride) ) the_stride = stride
- select case ( sds%typ )
- case ( 'int' )
- select case ( sds%knd )
- case ( 1 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=1) )
- case ( 2 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=2) )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), int(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case ( 'flt' )
- select case ( sds%knd )
- case ( 4 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=4) )
- case ( 8 )
- status = sfWData( sds%id, the_start, the_stride, shape(data), real(data,kind=8) )
- case default
- write (*,'("ERROR - unsupported real kind : ",i4)') sds%knd
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- case default
- write (*,'("ERROR - unknown sds%typ : ",a)') trim(sds%typ)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status == FAIL ) then
- write (*,'("ERROR - writing data set:")')
- write (*,'("ERROR - data set : ",a)') trim(sds%name)
- write (*,'("ERROR - hdf file : ",a)') trim(sds%hdfname)
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- ! ok
- status = 0
-
- end subroutine sds_WriteData_i<wp>_7d
-
-
-
- ! ############################################################
- ! ###
- ! ### dimensions
- ! ###
- ! ############################################################
-
- ! ================================================================
- ! set dimension scale
- ! ================================================================
-
-
- subroutine dim_SetScale_i<wp>( sdim, scale, status, knd )
-
- use file_hdf_base, only : wpi
- use file_hdf_base, only : TSdsDim
- use file_hdf_base, only : wp_int8, wp_int16, wp_int32, wp_int64
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- integer(<wp>), intent(in) :: scale(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_SetScale_i<wp>'
- ! --- local ---------------------------
-
- integer :: ikind
- ! --- external ---------------------------
-
- integer(wpi), external :: sfSDScale
-
- ! --- begin ---------------------------
-
- ikind = kind(scale)
- if ( present(knd) ) ikind = knd
- select case ( ikind )
- case ( 1 )
- status = sfSDScale( sdim%id, size(scale), DFNT_INT8 , int(scale,kind=wp_int8 ) )
- case ( 2 )
- status = sfSDScale( sdim%id, size(scale), DFNT_INT16, int(scale,kind=wp_int16) )
- case ( 4 )
- status = sfSDScale( sdim%id, size(scale), DFNT_INT32, int(scale,kind=wp_int32) )
- case ( 8 )
- status = sfSDScale( sdim%id, size(scale), DFNT_INT64, int(scale,kind=wp_int64) )
- case default
- write (*,'("ERROR - unsupported integer kind : ",i4)') ikind
- write (*,'("ERROR in ",a)') rname; status=1; return
- end select
- if ( status /= SUCCEED ) then
- write (*,'("ERROR - writing scale")')
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
- ! ok
- status = 0
-
- end subroutine dim_SetScale_i<wp>
-
- ! ================================================================
- ! set dimension stuff
- ! ================================================================
-
-
- subroutine sds_SetDim_i<wp>( sds, dim_index, name, unit, scale, status, knd )
-
- use file_hdf_base, only : TSds, TSdsDim, Init, Done
- use file_hdf_base, only : MAX_DATA_RANK
- use file_hdf_base, only : GetInfo
- use file_hdf_base, only : Select, SetName
- use file_hdf_s, only : WriteAttribute
-
- ! --- in/out -------------------------
-
- type(TSds), intent(in) :: sds
- integer, intent(in) :: dim_index
- character(len=*), intent(in) :: name
- character(len=*), intent(in) :: unit
- integer(<wp>), intent(in) :: scale(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/sds_SetDim_i<wp>'
- ! --- local ---------------------------
-
- integer :: data_rank, data_dims(0:MAX_DATA_RANK-1)
- type(TSdsDim) :: sdim
- ! --- begin ---------------------------
-
- call GetInfo( sds, status, data_rank=data_rank, data_dims=data_dims )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if ( dim_index < 0 .or. dim_index > data_rank-1 ) then
- write (*,'("ERROR - wrong dimension index : ",i4)') dim_index
- write (*,'("ERROR - expecting range 0, .., ",i4)') data_rank-1
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
-
- call Init( sdim, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call Select( sdim, sds, dim_index, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call SetName( sdim, name, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call WriteAttribute( sdim, 'unit', unit, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if ( size(scale) /= data_dims(dim_index) ) then
- write (*,'("ERROR - wrong scale length : ",i4)') size(scale)
- write (*,'("ERROR - expecting length ",i4," for dim index ",i4)') data_dims(dim_index), dim_index
- write (*,'("ERROR in ",a)') rname; status=1; return
- end if
- call SetScale( sdim, scale, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- call Done( sdim, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine sds_SetDim_i<wp>
-
- ! ================================================================
- ! read attributes
- ! ================================================================
-
-
- subroutine dim_ReadAttribute_i<wp>_0d( sdim, name, i, status )
-
- use file_hdf_base, only : TSdsDim
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i
- integer, intent(out) :: status
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_ReadAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call ReadAttribute( sdim%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine dim_ReadAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine dim_ReadAttribute_i<wp>_1d( sdim, name, i, status )
-
- use file_hdf_base, only : TSdsDim
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i(:)
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_ReadAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call ReadAttribute( sdim%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine dim_ReadAttribute_i<wp>_1d
-
-
- ! =============================================================
- ! === check attributes
- ! =============================================================
-
- subroutine dim_CheckAttribute_i<wp>_0d( sdim, name, i, status )
-
- use file_hdf_base, only : TSdsDim
-
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_CheckAttribute_i<wp>_0d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( sdim%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine dim_CheckAttribute_i<wp>_0d
-
-
- ! ***
-
-
- subroutine dim_CheckAttribute_i<wp>_1d( sdim, name, i, status )
-
- use file_hdf_base, only : TSdsDim
-
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_CheckAttribute_i<wp>_1d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( sdim%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine dim_CheckAttribute_i<wp>_1d
-
-
- ! ================================================================
- ! write attributes
- ! ================================================================
-
-
- subroutine dim_WriteAttribute_i<wp>_0d( sdim, name, i, status, knd )
-
- use file_hdf_base, only : TSdsDim
-
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_WriteAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call WriteAttribute( sdim%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine dim_WriteAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine dim_WriteAttribute_i<wp>_1d( sdim, name, i, status, knd )
-
- use file_hdf_base, only : TSdsDim
-
- ! --- in/out -------------------------
-
- type(TSdsDim), intent(in) :: sdim
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/dim_WriteAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call WriteAttribute( sdim%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine dim_WriteAttribute_i<wp>_1d
-
-
- ! ############################################################
- ! ###
- ! ### hdf files
- ! ###
- ! ############################################################
-
- ! ================================================================
- ! read attributes
- ! ================================================================
-
-
- subroutine hdf_ReadAttribute_i<wp>_0d( hdf, name, i, status )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_ReadAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call ReadAttribute( hdf%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine hdf_ReadAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine hdf_ReadAttribute_i<wp>_1d( hdf, name, i, status )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(out) :: i(:)
- integer, intent(out) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_ReadAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call ReadAttribute( hdf%id, name, i, status )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine hdf_ReadAttribute_i<wp>_1d
-
-
- ! =============================================================
- ! === check attributes
- ! =============================================================
-
- subroutine hdf_CheckAttribute_i<wp>_0d( hdf, name, i, status )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_CheckAttribute_i<wp>_0d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( hdf%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine hdf_CheckAttribute_i<wp>_0d
-
-
- ! ***
-
-
- subroutine hdf_CheckAttribute_i<wp>_1d( hdf, name, i, status )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(inout) :: status
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_CheckAttribute_i<wp>_1d'
- ! --- local ------------------------------
-
- logical :: verbose
-
- ! --- begin ---------------------------
-
- ! write error messages ?
- verbose = status == 0
-
- call CheckAttribute( hdf%id, name, i, status )
- if (status>0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
- if (status<0) then
- if (verbose) write (*,'("ERROR in ",a)') rname
- status=-1; return
- end if
- ! ok
- status = 0
-
- end subroutine hdf_CheckAttribute_i<wp>_1d
-
-
- ! ================================================================
- ! write attributes
- ! ================================================================
-
-
- subroutine hdf_WriteAttribute_i<wp>_0d( hdf, name, i, status, knd )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_WriteAttribute_i<wp>_0d'
- ! --- begin -------------------------------
-
- call WriteAttribute( hdf%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine hdf_WriteAttribute_i<wp>_0d
-
-
- ! ***
-
- subroutine hdf_WriteAttribute_i<wp>_1d( hdf, name, i, status, knd )
-
- use file_hdf_base, only : THdfFile
-
- ! --- in/out -------------------------
-
- type(THdfFile), intent(in) :: hdf
- character(len=*), intent(in) :: name
- integer(<wp>), intent(in) :: i(:)
- integer, intent(out) :: status
- integer, intent(in), optional :: knd
-
- ! --- const --------------------------
-
- character(len=*), parameter :: rname = mname//'/hdf_WriteAttribute_i<wp>_1d'
- ! --- begin -------------------------------
-
- call WriteAttribute( hdf%id, name, i, status, knd )
- if (status/=0) then; write (*,'("ERROR in ",a)') rname; status=1; return; end if
-
- ! ok
- status = 0
-
- end subroutine hdf_WriteAttribute_i<wp>_1d
-
-
- end module file_hdf_i<wp>
|