mdf.F90 1.2 MB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719117201172111722117231172411725117261172711728117291173011731117321173311734117351173611737117381173911740117411174211743117441174511746117471174811749117501175111752117531175411755117561175711758117591176011761117621176311764117651176611767117681176911770117711177211773117741177511776117771177811779117801178111782117831178411785117861178711788117891179011791117921179311794117951179611797117981179911800118011180211803118041180511806118071180811809118101181111812118131181411815118161181711818118191182011821118221182311824118251182611827118281182911830118311183211833118341183511836118371183811839118401184111842118431184411845118461184711848118491185011851118521185311854118551185611857118581185911860118611186211863118641186511866118671186811869118701187111872118731187411875118761187711878118791188011881118821188311884118851188611887118881188911890118911189211893118941189511896118971189811899119001190111902119031190411905119061190711908119091191011911119121191311914119151191611917119181191911920119211192211923119241192511926119271192811929119301193111932119331193411935119361193711938119391194011941119421194311944119451194611947119481194911950119511195211953119541195511956119571195811959119601196111962119631196411965119661196711968119691197011971119721197311974119751197611977119781197911980119811198211983119841198511986119871198811989119901199111992119931199411995119961199711998119991200012001120021200312004120051200612007120081200912010120111201212013120141201512016120171201812019120201202112022120231202412025120261202712028120291203012031120321203312034120351203612037120381203912040120411204212043120441204512046120471204812049120501205112052120531205412055120561205712058120591206012061120621206312064120651206612067120681206912070120711207212073120741207512076120771207812079120801208112082120831208412085120861208712088120891209012091120921209312094120951209612097120981209912100121011210212103121041210512106121071210812109121101211112112121131211412115121161211712118121191212012121121221212312124121251212612127121281212912130121311213212133121341213512136121371213812139121401214112142121431214412145121461214712148121491215012151121521215312154121551215612157121581215912160121611216212163121641216512166121671216812169121701217112172121731217412175121761217712178121791218012181121821218312184121851218612187121881218912190121911219212193121941219512196121971219812199122001220112202122031220412205122061220712208122091221012211122121221312214122151221612217122181221912220122211222212223122241222512226122271222812229122301223112232122331223412235122361223712238122391224012241122421224312244122451224612247122481224912250122511225212253122541225512256122571225812259122601226112262122631226412265122661226712268122691227012271122721227312274122751227612277122781227912280122811228212283122841228512286122871228812289122901229112292122931229412295122961229712298122991230012301123021230312304123051230612307123081230912310123111231212313123141231512316123171231812319123201232112322123231232412325123261232712328123291233012331123321233312334123351233612337123381233912340123411234212343123441234512346123471234812349123501235112352123531235412355123561235712358123591236012361123621236312364123651236612367123681236912370123711237212373123741237512376123771237812379123801238112382123831238412385123861238712388123891239012391123921239312394123951239612397123981239912400124011240212403124041240512406124071240812409124101241112412124131241412415124161241712418124191242012421124221242312424124251242612427124281242912430124311243212433124341243512436124371243812439124401244112442124431244412445124461244712448124491245012451124521245312454124551245612457124581245912460124611246212463124641246512466124671246812469124701247112472124731247412475124761247712478124791248012481124821248312484124851248612487124881248912490124911249212493124941249512496124971249812499125001250112502125031250412505125061250712508125091251012511125121251312514125151251612517125181251912520125211252212523125241252512526125271252812529125301253112532125331253412535125361253712538125391254012541125421254312544125451254612547125481254912550125511255212553125541255512556125571255812559125601256112562125631256412565125661256712568125691257012571125721257312574125751257612577125781257912580125811258212583125841258512586125871258812589125901259112592125931259412595125961259712598125991260012601126021260312604126051260612607126081260912610126111261212613126141261512616126171261812619126201262112622126231262412625126261262712628126291263012631126321263312634126351263612637126381263912640126411264212643126441264512646126471264812649126501265112652126531265412655126561265712658126591266012661126621266312664126651266612667126681266912670126711267212673126741267512676126771267812679126801268112682126831268412685126861268712688126891269012691126921269312694126951269612697126981269912700127011270212703127041270512706127071270812709127101271112712127131271412715127161271712718127191272012721127221272312724127251272612727127281272912730127311273212733127341273512736127371273812739127401274112742127431274412745127461274712748127491275012751127521275312754127551275612757127581275912760127611276212763127641276512766127671276812769127701277112772127731277412775127761277712778127791278012781127821278312784127851278612787127881278912790127911279212793127941279512796127971279812799128001280112802128031280412805128061280712808128091281012811128121281312814128151281612817128181281912820128211282212823128241282512826128271282812829128301283112832128331283412835128361283712838128391284012841128421284312844128451284612847128481284912850128511285212853128541285512856128571285812859128601286112862128631286412865128661286712868128691287012871128721287312874128751287612877128781287912880128811288212883128841288512886128871288812889128901289112892128931289412895128961289712898128991290012901129021290312904129051290612907129081290912910129111291212913129141291512916129171291812919129201292112922129231292412925129261292712928129291293012931129321293312934129351293612937129381293912940129411294212943129441294512946129471294812949129501295112952129531295412955129561295712958129591296012961129621296312964129651296612967129681296912970129711297212973129741297512976129771297812979129801298112982129831298412985129861298712988129891299012991129921299312994129951299612997129981299913000130011300213003130041300513006130071300813009130101301113012130131301413015130161301713018130191302013021130221302313024130251302613027130281302913030130311303213033130341303513036130371303813039130401304113042130431304413045130461304713048130491305013051130521305313054130551305613057130581305913060130611306213063130641306513066130671306813069130701307113072130731307413075130761307713078130791308013081130821308313084130851308613087130881308913090130911309213093130941309513096130971309813099131001310113102131031310413105131061310713108131091311013111131121311313114131151311613117131181311913120131211312213123131241312513126131271312813129131301313113132131331313413135131361313713138131391314013141131421314313144131451314613147131481314913150131511315213153131541315513156131571315813159131601316113162131631316413165131661316713168131691317013171131721317313174131751317613177131781317913180131811318213183131841318513186131871318813189131901319113192131931319413195131961319713198131991320013201132021320313204132051320613207132081320913210132111321213213132141321513216132171321813219132201322113222132231322413225132261322713228132291323013231132321323313234132351323613237132381323913240132411324213243132441324513246132471324813249132501325113252132531325413255132561325713258132591326013261132621326313264132651326613267132681326913270132711327213273132741327513276132771327813279132801328113282132831328413285132861328713288132891329013291132921329313294132951329613297132981329913300133011330213303133041330513306133071330813309133101331113312133131331413315133161331713318133191332013321133221332313324133251332613327133281332913330133311333213333133341333513336133371333813339133401334113342133431334413345133461334713348133491335013351133521335313354133551335613357133581335913360133611336213363133641336513366133671336813369133701337113372133731337413375133761337713378133791338013381133821338313384133851338613387133881338913390133911339213393133941339513396133971339813399134001340113402134031340413405134061340713408134091341013411134121341313414134151341613417134181341913420134211342213423134241342513426134271342813429134301343113432134331343413435134361343713438134391344013441134421344313444134451344613447134481344913450134511345213453134541345513456134571345813459134601346113462134631346413465134661346713468134691347013471134721347313474134751347613477134781347913480134811348213483134841348513486134871348813489134901349113492134931349413495134961349713498134991350013501135021350313504135051350613507135081350913510135111351213513135141351513516135171351813519135201352113522135231352413525135261352713528135291353013531135321353313534135351353613537135381353913540135411354213543135441354513546135471354813549135501355113552135531355413555135561355713558135591356013561135621356313564135651356613567135681356913570135711357213573135741357513576135771357813579135801358113582135831358413585135861358713588135891359013591135921359313594135951359613597135981359913600136011360213603136041360513606136071360813609136101361113612136131361413615136161361713618136191362013621136221362313624136251362613627136281362913630136311363213633136341363513636136371363813639136401364113642136431364413645136461364713648136491365013651136521365313654136551365613657136581365913660136611366213663136641366513666136671366813669136701367113672136731367413675136761367713678136791368013681136821368313684136851368613687136881368913690136911369213693136941369513696136971369813699137001370113702137031370413705137061370713708137091371013711137121371313714137151371613717137181371913720137211372213723137241372513726137271372813729137301373113732137331373413735137361373713738137391374013741137421374313744137451374613747137481374913750137511375213753137541375513756137571375813759137601376113762137631376413765137661376713768137691377013771137721377313774137751377613777137781377913780137811378213783137841378513786137871378813789137901379113792137931379413795137961379713798137991380013801138021380313804138051380613807138081380913810138111381213813138141381513816138171381813819138201382113822138231382413825138261382713828138291383013831138321383313834138351383613837138381383913840138411384213843138441384513846138471384813849138501385113852138531385413855138561385713858138591386013861138621386313864138651386613867138681386913870138711387213873138741387513876138771387813879138801388113882138831388413885138861388713888138891389013891138921389313894138951389613897138981389913900139011390213903139041390513906139071390813909139101391113912139131391413915139161391713918139191392013921139221392313924139251392613927139281392913930139311393213933139341393513936139371393813939139401394113942139431394413945139461394713948139491395013951139521395313954139551395613957139581395913960139611396213963139641396513966139671396813969139701397113972139731397413975139761397713978139791398013981139821398313984139851398613987139881398913990139911399213993139941399513996139971399813999140001400114002140031400414005140061400714008140091401014011140121401314014140151401614017140181401914020140211402214023140241402514026140271402814029140301403114032140331403414035140361403714038140391404014041140421404314044140451404614047140481404914050140511405214053140541405514056140571405814059140601406114062140631406414065140661406714068140691407014071140721407314074140751407614077140781407914080140811408214083140841408514086140871408814089140901409114092140931409414095140961409714098140991410014101141021410314104141051410614107141081410914110141111411214113141141411514116141171411814119141201412114122141231412414125141261412714128141291413014131141321413314134141351413614137141381413914140141411414214143141441414514146141471414814149141501415114152141531415414155141561415714158141591416014161141621416314164141651416614167141681416914170141711417214173141741417514176141771417814179141801418114182141831418414185141861418714188141891419014191141921419314194141951419614197141981419914200142011420214203142041420514206142071420814209142101421114212142131421414215142161421714218142191422014221142221422314224142251422614227142281422914230142311423214233142341423514236142371423814239142401424114242142431424414245142461424714248142491425014251142521425314254142551425614257142581425914260142611426214263142641426514266142671426814269142701427114272142731427414275142761427714278142791428014281142821428314284142851428614287142881428914290142911429214293142941429514296142971429814299143001430114302143031430414305143061430714308143091431014311143121431314314143151431614317143181431914320143211432214323143241432514326143271432814329143301433114332143331433414335143361433714338143391434014341143421434314344143451434614347143481434914350143511435214353143541435514356143571435814359143601436114362143631436414365143661436714368143691437014371143721437314374143751437614377143781437914380143811438214383143841438514386143871438814389143901439114392143931439414395143961439714398143991440014401144021440314404144051440614407144081440914410144111441214413144141441514416144171441814419144201442114422144231442414425144261442714428144291443014431144321443314434144351443614437144381443914440144411444214443144441444514446144471444814449144501445114452144531445414455144561445714458144591446014461144621446314464144651446614467144681446914470144711447214473144741447514476144771447814479144801448114482144831448414485144861448714488144891449014491144921449314494144951449614497144981449914500145011450214503145041450514506145071450814509145101451114512145131451414515145161451714518145191452014521145221452314524145251452614527145281452914530145311453214533145341453514536145371453814539145401454114542145431454414545145461454714548145491455014551145521455314554145551455614557145581455914560145611456214563145641456514566145671456814569145701457114572145731457414575145761457714578145791458014581145821458314584145851458614587145881458914590145911459214593145941459514596145971459814599146001460114602146031460414605146061460714608146091461014611146121461314614146151461614617146181461914620146211462214623146241462514626146271462814629146301463114632146331463414635146361463714638146391464014641146421464314644146451464614647146481464914650146511465214653146541465514656146571465814659146601466114662146631466414665146661466714668146691467014671146721467314674146751467614677146781467914680146811468214683146841468514686146871468814689146901469114692146931469414695146961469714698146991470014701147021470314704147051470614707147081470914710147111471214713147141471514716147171471814719147201472114722147231472414725147261472714728147291473014731147321473314734147351473614737147381473914740147411474214743147441474514746147471474814749147501475114752147531475414755147561475714758147591476014761147621476314764147651476614767147681476914770147711477214773147741477514776147771477814779147801478114782147831478414785147861478714788147891479014791147921479314794147951479614797147981479914800148011480214803148041480514806148071480814809148101481114812148131481414815148161481714818148191482014821148221482314824148251482614827148281482914830148311483214833148341483514836148371483814839148401484114842148431484414845148461484714848148491485014851148521485314854148551485614857148581485914860148611486214863148641486514866148671486814869148701487114872148731487414875148761487714878148791488014881148821488314884148851488614887148881488914890148911489214893148941489514896148971489814899149001490114902149031490414905149061490714908149091491014911149121491314914149151491614917149181491914920149211492214923149241492514926149271492814929149301493114932149331493414935149361493714938149391494014941149421494314944149451494614947149481494914950149511495214953149541495514956149571495814959149601496114962149631496414965149661496714968149691497014971149721497314974149751497614977149781497914980149811498214983149841498514986149871498814989149901499114992149931499414995149961499714998149991500015001150021500315004150051500615007150081500915010150111501215013150141501515016150171501815019150201502115022150231502415025150261502715028150291503015031150321503315034150351503615037150381503915040150411504215043150441504515046150471504815049150501505115052150531505415055150561505715058150591506015061150621506315064150651506615067150681506915070150711507215073150741507515076150771507815079150801508115082150831508415085150861508715088150891509015091150921509315094150951509615097150981509915100151011510215103151041510515106151071510815109151101511115112151131511415115151161511715118151191512015121151221512315124151251512615127151281512915130151311513215133151341513515136151371513815139151401514115142151431514415145151461514715148151491515015151151521515315154151551515615157151581515915160151611516215163151641516515166151671516815169151701517115172151731517415175151761517715178151791518015181151821518315184151851518615187151881518915190151911519215193151941519515196151971519815199152001520115202152031520415205152061520715208152091521015211152121521315214152151521615217152181521915220152211522215223152241522515226152271522815229152301523115232152331523415235152361523715238152391524015241152421524315244152451524615247152481524915250152511525215253152541525515256152571525815259152601526115262152631526415265152661526715268152691527015271152721527315274152751527615277152781527915280152811528215283152841528515286152871528815289152901529115292152931529415295152961529715298152991530015301153021530315304153051530615307153081530915310153111531215313153141531515316153171531815319153201532115322153231532415325153261532715328153291533015331153321533315334153351533615337153381533915340153411534215343153441534515346153471534815349153501535115352153531535415355153561535715358153591536015361153621536315364153651536615367153681536915370153711537215373153741537515376153771537815379153801538115382153831538415385153861538715388153891539015391153921539315394153951539615397153981539915400154011540215403154041540515406154071540815409154101541115412154131541415415154161541715418154191542015421154221542315424154251542615427154281542915430154311543215433154341543515436154371543815439154401544115442154431544415445154461544715448154491545015451154521545315454154551545615457154581545915460154611546215463154641546515466154671546815469154701547115472154731547415475154761547715478154791548015481154821548315484154851548615487154881548915490154911549215493154941549515496154971549815499155001550115502155031550415505155061550715508155091551015511155121551315514155151551615517155181551915520155211552215523155241552515526155271552815529155301553115532155331553415535155361553715538155391554015541155421554315544155451554615547155481554915550155511555215553155541555515556155571555815559155601556115562155631556415565155661556715568155691557015571155721557315574155751557615577155781557915580155811558215583155841558515586155871558815589155901559115592155931559415595155961559715598155991560015601156021560315604156051560615607156081560915610156111561215613156141561515616156171561815619156201562115622156231562415625156261562715628156291563015631156321563315634156351563615637156381563915640156411564215643156441564515646156471564815649156501565115652156531565415655156561565715658156591566015661156621566315664156651566615667156681566915670156711567215673156741567515676156771567815679156801568115682156831568415685156861568715688156891569015691156921569315694156951569615697156981569915700157011570215703157041570515706157071570815709157101571115712157131571415715157161571715718157191572015721157221572315724157251572615727157281572915730157311573215733157341573515736157371573815739157401574115742157431574415745157461574715748157491575015751157521575315754157551575615757157581575915760157611576215763157641576515766157671576815769157701577115772157731577415775157761577715778157791578015781157821578315784157851578615787157881578915790157911579215793157941579515796157971579815799158001580115802158031580415805158061580715808158091581015811158121581315814158151581615817158181581915820158211582215823158241582515826158271582815829158301583115832158331583415835158361583715838158391584015841158421584315844158451584615847158481584915850158511585215853158541585515856158571585815859158601586115862158631586415865158661586715868158691587015871158721587315874158751587615877158781587915880158811588215883158841588515886158871588815889158901589115892158931589415895158961589715898158991590015901159021590315904159051590615907159081590915910159111591215913159141591515916159171591815919159201592115922159231592415925159261592715928159291593015931159321593315934159351593615937159381593915940159411594215943159441594515946159471594815949159501595115952159531595415955159561595715958159591596015961159621596315964159651596615967159681596915970159711597215973159741597515976159771597815979159801598115982159831598415985159861598715988159891599015991159921599315994159951599615997159981599916000160011600216003160041600516006160071600816009160101601116012160131601416015160161601716018160191602016021160221602316024160251602616027160281602916030160311603216033160341603516036160371603816039160401604116042160431604416045160461604716048160491605016051160521605316054160551605616057160581605916060160611606216063160641606516066160671606816069160701607116072160731607416075160761607716078160791608016081160821608316084160851608616087160881608916090160911609216093160941609516096160971609816099161001610116102161031610416105161061610716108161091611016111161121611316114161151611616117161181611916120161211612216123161241612516126161271612816129161301613116132161331613416135161361613716138161391614016141161421614316144161451614616147161481614916150161511615216153161541615516156161571615816159161601616116162161631616416165161661616716168161691617016171161721617316174161751617616177161781617916180161811618216183161841618516186161871618816189161901619116192161931619416195161961619716198161991620016201162021620316204162051620616207162081620916210162111621216213162141621516216162171621816219162201622116222162231622416225162261622716228162291623016231162321623316234162351623616237162381623916240162411624216243162441624516246162471624816249162501625116252162531625416255162561625716258162591626016261162621626316264162651626616267162681626916270162711627216273162741627516276162771627816279162801628116282162831628416285162861628716288162891629016291162921629316294162951629616297162981629916300163011630216303163041630516306163071630816309163101631116312163131631416315163161631716318163191632016321163221632316324163251632616327163281632916330163311633216333163341633516336163371633816339163401634116342163431634416345163461634716348163491635016351163521635316354163551635616357163581635916360163611636216363163641636516366163671636816369163701637116372163731637416375163761637716378163791638016381163821638316384163851638616387163881638916390163911639216393163941639516396163971639816399164001640116402164031640416405164061640716408164091641016411164121641316414164151641616417164181641916420164211642216423164241642516426164271642816429164301643116432164331643416435164361643716438164391644016441164421644316444164451644616447164481644916450164511645216453164541645516456164571645816459164601646116462164631646416465164661646716468164691647016471164721647316474164751647616477164781647916480164811648216483164841648516486164871648816489164901649116492164931649416495164961649716498164991650016501165021650316504165051650616507165081650916510165111651216513165141651516516165171651816519165201652116522165231652416525165261652716528165291653016531165321653316534165351653616537165381653916540165411654216543165441654516546165471654816549165501655116552165531655416555165561655716558165591656016561165621656316564165651656616567165681656916570165711657216573165741657516576165771657816579165801658116582165831658416585165861658716588165891659016591165921659316594165951659616597165981659916600166011660216603166041660516606166071660816609166101661116612166131661416615166161661716618166191662016621166221662316624166251662616627166281662916630166311663216633166341663516636166371663816639166401664116642166431664416645166461664716648166491665016651166521665316654166551665616657166581665916660166611666216663166641666516666166671666816669166701667116672166731667416675166761667716678166791668016681166821668316684166851668616687166881668916690166911669216693166941669516696166971669816699167001670116702167031670416705167061670716708167091671016711167121671316714167151671616717167181671916720167211672216723167241672516726167271672816729167301673116732167331673416735167361673716738167391674016741167421674316744167451674616747167481674916750167511675216753167541675516756167571675816759167601676116762167631676416765167661676716768167691677016771167721677316774167751677616777167781677916780167811678216783167841678516786167871678816789167901679116792167931679416795167961679716798167991680016801168021680316804168051680616807168081680916810168111681216813168141681516816168171681816819168201682116822168231682416825168261682716828168291683016831168321683316834168351683616837168381683916840168411684216843168441684516846168471684816849168501685116852168531685416855168561685716858168591686016861168621686316864168651686616867168681686916870168711687216873168741687516876168771687816879168801688116882168831688416885168861688716888168891689016891168921689316894168951689616897168981689916900169011690216903169041690516906169071690816909169101691116912169131691416915169161691716918169191692016921169221692316924169251692616927169281692916930169311693216933169341693516936169371693816939169401694116942169431694416945169461694716948169491695016951169521695316954169551695616957169581695916960169611696216963169641696516966169671696816969169701697116972169731697416975169761697716978169791698016981169821698316984169851698616987169881698916990169911699216993169941699516996169971699816999170001700117002170031700417005170061700717008170091701017011170121701317014170151701617017170181701917020170211702217023170241702517026170271702817029170301703117032170331703417035170361703717038170391704017041170421704317044170451704617047170481704917050170511705217053170541705517056170571705817059170601706117062170631706417065170661706717068170691707017071170721707317074170751707617077170781707917080170811708217083170841708517086170871708817089170901709117092170931709417095170961709717098170991710017101171021710317104171051710617107171081710917110171111711217113171141711517116171171711817119171201712117122171231712417125171261712717128171291713017131171321713317134171351713617137171381713917140171411714217143171441714517146171471714817149171501715117152171531715417155171561715717158171591716017161171621716317164171651716617167171681716917170171711717217173171741717517176171771717817179171801718117182171831718417185171861718717188171891719017191171921719317194171951719617197171981719917200172011720217203172041720517206172071720817209172101721117212172131721417215172161721717218172191722017221172221722317224172251722617227172281722917230172311723217233172341723517236172371723817239172401724117242172431724417245172461724717248172491725017251172521725317254172551725617257172581725917260172611726217263172641726517266172671726817269172701727117272172731727417275172761727717278172791728017281172821728317284172851728617287172881728917290172911729217293172941729517296172971729817299173001730117302173031730417305173061730717308173091731017311173121731317314173151731617317173181731917320173211732217323173241732517326173271732817329173301733117332173331733417335173361733717338173391734017341173421734317344173451734617347173481734917350173511735217353173541735517356173571735817359173601736117362173631736417365173661736717368173691737017371173721737317374173751737617377173781737917380173811738217383173841738517386173871738817389173901739117392173931739417395173961739717398173991740017401174021740317404174051740617407174081740917410174111741217413174141741517416174171741817419174201742117422174231742417425174261742717428174291743017431174321743317434174351743617437174381743917440174411744217443174441744517446174471744817449174501745117452174531745417455174561745717458174591746017461174621746317464174651746617467174681746917470174711747217473174741747517476174771747817479174801748117482174831748417485174861748717488174891749017491174921749317494174951749617497174981749917500175011750217503175041750517506175071750817509175101751117512175131751417515175161751717518175191752017521175221752317524175251752617527175281752917530175311753217533175341753517536175371753817539175401754117542175431754417545175461754717548175491755017551175521755317554175551755617557175581755917560175611756217563175641756517566175671756817569175701757117572175731757417575175761757717578175791758017581175821758317584175851758617587175881758917590175911759217593175941759517596175971759817599176001760117602176031760417605176061760717608176091761017611176121761317614176151761617617176181761917620176211762217623176241762517626176271762817629176301763117632176331763417635176361763717638176391764017641176421764317644176451764617647176481764917650176511765217653176541765517656176571765817659176601766117662176631766417665176661766717668176691767017671176721767317674176751767617677176781767917680176811768217683176841768517686176871768817689176901769117692176931769417695176961769717698176991770017701177021770317704177051770617707177081770917710177111771217713177141771517716177171771817719177201772117722177231772417725177261772717728177291773017731177321773317734177351773617737177381773917740177411774217743177441774517746177471774817749177501775117752177531775417755177561775717758177591776017761177621776317764177651776617767177681776917770177711777217773177741777517776177771777817779177801778117782177831778417785177861778717788177891779017791177921779317794177951779617797177981779917800178011780217803178041780517806178071780817809178101781117812178131781417815178161781717818178191782017821178221782317824178251782617827178281782917830178311783217833178341783517836178371783817839178401784117842178431784417845178461784717848178491785017851178521785317854178551785617857178581785917860178611786217863178641786517866178671786817869178701787117872178731787417875178761787717878178791788017881178821788317884178851788617887178881788917890178911789217893178941789517896178971789817899179001790117902179031790417905179061790717908179091791017911179121791317914179151791617917179181791917920179211792217923179241792517926179271792817929179301793117932179331793417935179361793717938179391794017941179421794317944179451794617947179481794917950179511795217953179541795517956179571795817959179601796117962179631796417965179661796717968179691797017971179721797317974179751797617977179781797917980179811798217983179841798517986179871798817989179901799117992179931799417995179961799717998179991800018001180021800318004180051800618007180081800918010180111801218013180141801518016180171801818019180201802118022180231802418025180261802718028180291803018031180321803318034180351803618037180381803918040180411804218043180441804518046180471804818049180501805118052180531805418055180561805718058180591806018061180621806318064180651806618067180681806918070180711807218073180741807518076180771807818079180801808118082180831808418085180861808718088180891809018091180921809318094180951809618097180981809918100181011810218103181041810518106181071810818109181101811118112181131811418115181161811718118181191812018121181221812318124181251812618127181281812918130181311813218133181341813518136181371813818139181401814118142181431814418145181461814718148181491815018151181521815318154181551815618157181581815918160181611816218163181641816518166181671816818169181701817118172181731817418175181761817718178181791818018181181821818318184181851818618187181881818918190181911819218193181941819518196181971819818199182001820118202182031820418205182061820718208182091821018211182121821318214182151821618217182181821918220182211822218223182241822518226182271822818229182301823118232182331823418235182361823718238182391824018241182421824318244182451824618247182481824918250182511825218253182541825518256182571825818259182601826118262182631826418265182661826718268182691827018271182721827318274182751827618277182781827918280182811828218283182841828518286182871828818289182901829118292182931829418295182961829718298182991830018301183021830318304183051830618307183081830918310183111831218313183141831518316183171831818319183201832118322183231832418325183261832718328183291833018331183321833318334183351833618337183381833918340183411834218343183441834518346183471834818349183501835118352183531835418355183561835718358183591836018361183621836318364183651836618367183681836918370183711837218373183741837518376183771837818379183801838118382183831838418385183861838718388183891839018391183921839318394183951839618397183981839918400184011840218403184041840518406184071840818409184101841118412184131841418415184161841718418184191842018421184221842318424184251842618427184281842918430184311843218433184341843518436184371843818439184401844118442184431844418445184461844718448184491845018451184521845318454184551845618457184581845918460184611846218463184641846518466184671846818469184701847118472184731847418475184761847718478184791848018481184821848318484184851848618487184881848918490184911849218493184941849518496184971849818499185001850118502185031850418505185061850718508185091851018511185121851318514185151851618517185181851918520185211852218523185241852518526185271852818529185301853118532185331853418535185361853718538185391854018541185421854318544185451854618547185481854918550185511855218553185541855518556185571855818559185601856118562185631856418565185661856718568185691857018571185721857318574185751857618577185781857918580185811858218583185841858518586185871858818589185901859118592185931859418595185961859718598185991860018601186021860318604186051860618607186081860918610186111861218613186141861518616186171861818619186201862118622186231862418625186261862718628186291863018631186321863318634186351863618637186381863918640186411864218643186441864518646186471864818649186501865118652186531865418655186561865718658186591866018661186621866318664186651866618667186681866918670186711867218673186741867518676186771867818679186801868118682186831868418685186861868718688186891869018691186921869318694186951869618697186981869918700187011870218703187041870518706187071870818709187101871118712187131871418715187161871718718187191872018721187221872318724187251872618727187281872918730187311873218733187341873518736187371873818739187401874118742187431874418745187461874718748187491875018751187521875318754187551875618757187581875918760187611876218763187641876518766187671876818769187701877118772187731877418775187761877718778187791878018781187821878318784187851878618787187881878918790187911879218793187941879518796187971879818799188001880118802188031880418805188061880718808188091881018811188121881318814188151881618817188181881918820188211882218823188241882518826188271882818829188301883118832188331883418835188361883718838188391884018841188421884318844188451884618847188481884918850188511885218853188541885518856188571885818859188601886118862188631886418865188661886718868188691887018871188721887318874188751887618877188781887918880188811888218883188841888518886188871888818889188901889118892188931889418895188961889718898188991890018901189021890318904189051890618907189081890918910189111891218913189141891518916189171891818919189201892118922189231892418925189261892718928189291893018931189321893318934189351893618937189381893918940189411894218943189441894518946189471894818949189501895118952189531895418955189561895718958189591896018961189621896318964189651896618967189681896918970189711897218973189741897518976189771897818979189801898118982189831898418985189861898718988189891899018991189921899318994189951899618997189981899919000190011900219003190041900519006190071900819009190101901119012190131901419015190161901719018190191902019021190221902319024190251902619027190281902919030190311903219033190341903519036190371903819039190401904119042190431904419045190461904719048190491905019051190521905319054190551905619057190581905919060190611906219063190641906519066190671906819069190701907119072190731907419075190761907719078190791908019081190821908319084190851908619087190881908919090190911909219093190941909519096190971909819099191001910119102191031910419105191061910719108191091911019111191121911319114191151911619117191181911919120191211912219123191241912519126191271912819129191301913119132191331913419135191361913719138191391914019141191421914319144191451914619147191481914919150191511915219153191541915519156191571915819159191601916119162191631916419165191661916719168191691917019171191721917319174191751917619177191781917919180191811918219183191841918519186191871918819189191901919119192191931919419195191961919719198191991920019201192021920319204192051920619207192081920919210192111921219213192141921519216192171921819219192201922119222192231922419225192261922719228192291923019231192321923319234192351923619237192381923919240192411924219243192441924519246192471924819249192501925119252192531925419255192561925719258192591926019261192621926319264192651926619267192681926919270192711927219273192741927519276192771927819279192801928119282192831928419285192861928719288192891929019291192921929319294192951929619297192981929919300193011930219303193041930519306193071930819309193101931119312193131931419315193161931719318193191932019321193221932319324193251932619327193281932919330193311933219333193341933519336193371933819339193401934119342193431934419345193461934719348193491935019351193521935319354193551935619357193581935919360193611936219363193641936519366193671936819369193701937119372193731937419375193761937719378193791938019381193821938319384193851938619387193881938919390193911939219393193941939519396193971939819399194001940119402194031940419405194061940719408194091941019411194121941319414194151941619417194181941919420194211942219423194241942519426194271942819429194301943119432194331943419435194361943719438194391944019441194421944319444194451944619447194481944919450194511945219453194541945519456194571945819459194601946119462194631946419465194661946719468194691947019471194721947319474194751947619477194781947919480194811948219483194841948519486194871948819489194901949119492194931949419495194961949719498194991950019501195021950319504195051950619507195081950919510195111951219513195141951519516195171951819519195201952119522195231952419525195261952719528195291953019531195321953319534195351953619537195381953919540195411954219543195441954519546195471954819549195501955119552195531955419555195561955719558195591956019561195621956319564195651956619567195681956919570195711957219573195741957519576195771957819579195801958119582195831958419585195861958719588195891959019591195921959319594195951959619597195981959919600196011960219603196041960519606196071960819609196101961119612196131961419615196161961719618196191962019621196221962319624196251962619627196281962919630196311963219633196341963519636196371963819639196401964119642196431964419645196461964719648196491965019651196521965319654196551965619657196581965919660196611966219663196641966519666196671966819669196701967119672196731967419675196761967719678196791968019681196821968319684196851968619687196881968919690196911969219693196941969519696196971969819699197001970119702197031970419705197061970719708197091971019711197121971319714197151971619717197181971919720197211972219723197241972519726197271972819729197301973119732197331973419735197361973719738197391974019741197421974319744197451974619747197481974919750197511975219753197541975519756197571975819759197601976119762197631976419765197661976719768197691977019771197721977319774197751977619777197781977919780197811978219783197841978519786197871978819789197901979119792197931979419795197961979719798197991980019801198021980319804198051980619807198081980919810198111981219813198141981519816198171981819819198201982119822198231982419825198261982719828198291983019831198321983319834198351983619837198381983919840198411984219843198441984519846198471984819849198501985119852198531985419855198561985719858198591986019861198621986319864198651986619867198681986919870198711987219873198741987519876198771987819879198801988119882198831988419885198861988719888198891989019891198921989319894198951989619897198981989919900199011990219903199041990519906199071990819909199101991119912199131991419915199161991719918199191992019921199221992319924199251992619927199281992919930199311993219933199341993519936199371993819939199401994119942199431994419945199461994719948199491995019951199521995319954199551995619957199581995919960199611996219963199641996519966199671996819969199701997119972199731997419975199761997719978199791998019981199821998319984199851998619987199881998919990199911999219993199941999519996199971999819999200002000120002200032000420005200062000720008200092001020011200122001320014200152001620017200182001920020200212002220023200242002520026200272002820029200302003120032200332003420035200362003720038200392004020041200422004320044200452004620047200482004920050200512005220053200542005520056200572005820059200602006120062200632006420065200662006720068200692007020071200722007320074200752007620077200782007920080200812008220083200842008520086200872008820089200902009120092200932009420095200962009720098200992010020101201022010320104201052010620107201082010920110201112011220113201142011520116201172011820119201202012120122201232012420125201262012720128201292013020131201322013320134201352013620137201382013920140201412014220143201442014520146201472014820149201502015120152201532015420155201562015720158201592016020161201622016320164201652016620167201682016920170201712017220173201742017520176201772017820179201802018120182201832018420185201862018720188201892019020191201922019320194201952019620197201982019920200202012020220203202042020520206202072020820209202102021120212202132021420215202162021720218202192022020221202222022320224202252022620227202282022920230202312023220233202342023520236202372023820239202402024120242202432024420245202462024720248202492025020251202522025320254202552025620257202582025920260202612026220263202642026520266202672026820269202702027120272202732027420275202762027720278202792028020281202822028320284202852028620287202882028920290202912029220293202942029520296202972029820299203002030120302203032030420305203062030720308203092031020311203122031320314203152031620317203182031920320203212032220323203242032520326203272032820329203302033120332203332033420335203362033720338203392034020341203422034320344203452034620347203482034920350203512035220353203542035520356203572035820359203602036120362203632036420365203662036720368203692037020371203722037320374203752037620377203782037920380203812038220383203842038520386203872038820389203902039120392203932039420395203962039720398203992040020401204022040320404204052040620407204082040920410204112041220413204142041520416204172041820419204202042120422204232042420425204262042720428204292043020431204322043320434204352043620437204382043920440204412044220443204442044520446204472044820449204502045120452204532045420455204562045720458204592046020461204622046320464204652046620467204682046920470204712047220473204742047520476204772047820479204802048120482204832048420485204862048720488204892049020491204922049320494204952049620497204982049920500205012050220503205042050520506205072050820509205102051120512205132051420515205162051720518205192052020521205222052320524205252052620527205282052920530205312053220533205342053520536205372053820539205402054120542205432054420545205462054720548205492055020551205522055320554205552055620557205582055920560205612056220563205642056520566205672056820569205702057120572205732057420575205762057720578205792058020581205822058320584205852058620587205882058920590205912059220593205942059520596205972059820599206002060120602206032060420605206062060720608206092061020611206122061320614206152061620617206182061920620206212062220623206242062520626206272062820629206302063120632206332063420635206362063720638206392064020641206422064320644206452064620647206482064920650206512065220653206542065520656206572065820659206602066120662206632066420665206662066720668206692067020671206722067320674206752067620677206782067920680206812068220683206842068520686206872068820689206902069120692206932069420695206962069720698206992070020701207022070320704207052070620707207082070920710207112071220713207142071520716207172071820719207202072120722207232072420725207262072720728207292073020731207322073320734207352073620737207382073920740207412074220743207442074520746207472074820749207502075120752207532075420755207562075720758207592076020761207622076320764207652076620767207682076920770207712077220773207742077520776207772077820779207802078120782207832078420785207862078720788207892079020791207922079320794207952079620797207982079920800208012080220803208042080520806208072080820809208102081120812208132081420815208162081720818208192082020821208222082320824208252082620827208282082920830208312083220833208342083520836208372083820839208402084120842208432084420845208462084720848208492085020851208522085320854208552085620857208582085920860208612086220863208642086520866208672086820869208702087120872208732087420875208762087720878208792088020881208822088320884208852088620887208882088920890208912089220893208942089520896208972089820899209002090120902209032090420905209062090720908209092091020911209122091320914209152091620917209182091920920209212092220923209242092520926209272092820929209302093120932209332093420935209362093720938209392094020941209422094320944209452094620947209482094920950209512095220953209542095520956209572095820959209602096120962209632096420965209662096720968209692097020971209722097320974209752097620977209782097920980209812098220983209842098520986209872098820989209902099120992209932099420995209962099720998209992100021001210022100321004210052100621007210082100921010210112101221013210142101521016210172101821019210202102121022210232102421025210262102721028210292103021031210322103321034210352103621037210382103921040210412104221043210442104521046210472104821049210502105121052210532105421055210562105721058210592106021061210622106321064210652106621067210682106921070210712107221073210742107521076210772107821079210802108121082210832108421085210862108721088210892109021091210922109321094210952109621097210982109921100211012110221103211042110521106211072110821109211102111121112211132111421115211162111721118211192112021121211222112321124211252112621127211282112921130211312113221133211342113521136211372113821139211402114121142211432114421145211462114721148211492115021151211522115321154211552115621157211582115921160211612116221163211642116521166211672116821169211702117121172211732117421175211762117721178211792118021181211822118321184211852118621187211882118921190211912119221193211942119521196211972119821199212002120121202212032120421205212062120721208212092121021211212122121321214212152121621217212182121921220212212122221223212242122521226212272122821229212302123121232212332123421235212362123721238212392124021241212422124321244212452124621247212482124921250212512125221253212542125521256212572125821259212602126121262212632126421265212662126721268212692127021271212722127321274212752127621277212782127921280212812128221283212842128521286212872128821289212902129121292212932129421295212962129721298212992130021301213022130321304213052130621307213082130921310213112131221313213142131521316213172131821319213202132121322213232132421325213262132721328213292133021331213322133321334213352133621337213382133921340213412134221343213442134521346213472134821349213502135121352213532135421355213562135721358213592136021361213622136321364213652136621367213682136921370213712137221373213742137521376213772137821379213802138121382213832138421385213862138721388213892139021391213922139321394213952139621397213982139921400214012140221403214042140521406214072140821409214102141121412214132141421415214162141721418214192142021421214222142321424214252142621427214282142921430214312143221433214342143521436214372143821439214402144121442214432144421445214462144721448214492145021451214522145321454214552145621457214582145921460214612146221463214642146521466214672146821469214702147121472214732147421475214762147721478214792148021481214822148321484214852148621487214882148921490214912149221493214942149521496214972149821499215002150121502215032150421505215062150721508215092151021511215122151321514215152151621517215182151921520215212152221523215242152521526215272152821529215302153121532215332153421535215362153721538215392154021541215422154321544215452154621547215482154921550215512155221553215542155521556215572155821559215602156121562215632156421565215662156721568215692157021571215722157321574215752157621577215782157921580215812158221583215842158521586215872158821589215902159121592215932159421595215962159721598215992160021601216022160321604216052160621607216082160921610216112161221613216142161521616216172161821619216202162121622216232162421625216262162721628216292163021631216322163321634216352163621637216382163921640216412164221643216442164521646216472164821649216502165121652216532165421655216562165721658216592166021661216622166321664216652166621667216682166921670216712167221673216742167521676216772167821679216802168121682216832168421685216862168721688216892169021691216922169321694216952169621697216982169921700217012170221703217042170521706217072170821709217102171121712217132171421715217162171721718217192172021721217222172321724217252172621727217282172921730217312173221733217342173521736217372173821739217402174121742217432174421745217462174721748217492175021751217522175321754217552175621757217582175921760217612176221763217642176521766217672176821769217702177121772217732177421775217762177721778217792178021781217822178321784217852178621787217882178921790217912179221793217942179521796217972179821799218002180121802218032180421805218062180721808218092181021811218122181321814218152181621817218182181921820218212182221823218242182521826218272182821829218302183121832218332183421835218362183721838218392184021841218422184321844218452184621847218482184921850218512185221853218542185521856218572185821859218602186121862218632186421865218662186721868218692187021871218722187321874218752187621877218782187921880218812188221883218842188521886218872188821889218902189121892218932189421895218962189721898218992190021901219022190321904219052190621907219082190921910219112191221913219142191521916219172191821919219202192121922219232192421925219262192721928219292193021931219322193321934219352193621937219382193921940219412194221943219442194521946219472194821949219502195121952219532195421955219562195721958219592196021961219622196321964219652196621967219682196921970219712197221973219742197521976219772197821979219802198121982219832198421985219862198721988219892199021991219922199321994219952199621997219982199922000220012200222003220042200522006220072200822009220102201122012220132201422015220162201722018220192202022021220222202322024220252202622027220282202922030220312203222033220342203522036220372203822039220402204122042220432204422045220462204722048220492205022051220522205322054220552205622057220582205922060220612206222063220642206522066220672206822069220702207122072220732207422075220762207722078220792208022081220822208322084220852208622087220882208922090220912209222093220942209522096220972209822099221002210122102221032210422105221062210722108221092211022111221122211322114221152211622117221182211922120221212212222123221242212522126221272212822129221302213122132221332213422135221362213722138221392214022141221422214322144221452214622147221482214922150221512215222153221542215522156221572215822159221602216122162221632216422165221662216722168221692217022171221722217322174221752217622177221782217922180221812218222183221842218522186221872218822189221902219122192221932219422195221962219722198221992220022201222022220322204222052220622207222082220922210222112221222213222142221522216222172221822219222202222122222222232222422225222262222722228222292223022231222322223322234222352223622237222382223922240222412224222243222442224522246222472224822249222502225122252222532225422255222562225722258222592226022261222622226322264222652226622267222682226922270222712227222273222742227522276222772227822279222802228122282222832228422285222862228722288222892229022291222922229322294222952229622297222982229922300223012230222303223042230522306223072230822309223102231122312223132231422315223162231722318223192232022321223222232322324223252232622327223282232922330223312233222333223342233522336223372233822339223402234122342223432234422345223462234722348223492235022351223522235322354223552235622357223582235922360223612236222363223642236522366223672236822369223702237122372223732237422375223762237722378223792238022381223822238322384223852238622387223882238922390223912239222393223942239522396223972239822399224002240122402224032240422405224062240722408224092241022411224122241322414224152241622417224182241922420224212242222423224242242522426224272242822429224302243122432224332243422435224362243722438224392244022441224422244322444224452244622447224482244922450224512245222453224542245522456224572245822459224602246122462224632246422465224662246722468224692247022471224722247322474224752247622477224782247922480224812248222483224842248522486224872248822489224902249122492224932249422495224962249722498224992250022501225022250322504225052250622507225082250922510225112251222513225142251522516225172251822519225202252122522225232252422525225262252722528225292253022531225322253322534225352253622537225382253922540225412254222543225442254522546225472254822549225502255122552225532255422555225562255722558225592256022561225622256322564225652256622567225682256922570225712257222573225742257522576225772257822579225802258122582225832258422585225862258722588225892259022591225922259322594225952259622597225982259922600226012260222603226042260522606226072260822609226102261122612226132261422615226162261722618226192262022621226222262322624226252262622627226282262922630226312263222633226342263522636226372263822639226402264122642226432264422645226462264722648226492265022651226522265322654226552265622657226582265922660226612266222663226642266522666226672266822669226702267122672226732267422675226762267722678226792268022681226822268322684226852268622687226882268922690226912269222693226942269522696226972269822699227002270122702227032270422705227062270722708227092271022711227122271322714227152271622717227182271922720227212272222723227242272522726227272272822729227302273122732227332273422735227362273722738227392274022741227422274322744227452274622747227482274922750227512275222753227542275522756227572275822759227602276122762227632276422765227662276722768227692277022771227722277322774227752277622777227782277922780227812278222783227842278522786227872278822789227902279122792227932279422795227962279722798227992280022801228022280322804228052280622807228082280922810228112281222813228142281522816228172281822819228202282122822228232282422825228262282722828228292283022831228322283322834228352283622837228382283922840228412284222843228442284522846228472284822849228502285122852228532285422855228562285722858228592286022861228622286322864228652286622867228682286922870228712287222873228742287522876228772287822879228802288122882228832288422885228862288722888228892289022891228922289322894228952289622897228982289922900229012290222903229042290522906229072290822909229102291122912229132291422915229162291722918229192292022921229222292322924229252292622927229282292922930229312293222933229342293522936229372293822939229402294122942229432294422945229462294722948229492295022951229522295322954229552295622957229582295922960229612296222963229642296522966229672296822969229702297122972229732297422975229762297722978229792298022981229822298322984229852298622987229882298922990229912299222993229942299522996229972299822999230002300123002230032300423005230062300723008230092301023011230122301323014230152301623017230182301923020230212302223023230242302523026230272302823029230302303123032230332303423035230362303723038230392304023041230422304323044230452304623047230482304923050230512305223053230542305523056230572305823059230602306123062230632306423065230662306723068230692307023071230722307323074230752307623077230782307923080230812308223083230842308523086230872308823089230902309123092230932309423095230962309723098230992310023101231022310323104231052310623107231082310923110231112311223113231142311523116231172311823119231202312123122231232312423125231262312723128231292313023131231322313323134231352313623137231382313923140231412314223143231442314523146231472314823149231502315123152231532315423155231562315723158231592316023161231622316323164231652316623167231682316923170231712317223173231742317523176231772317823179231802318123182231832318423185231862318723188231892319023191231922319323194231952319623197231982319923200232012320223203232042320523206232072320823209232102321123212232132321423215232162321723218232192322023221232222322323224232252322623227232282322923230232312323223233232342323523236232372323823239232402324123242232432324423245232462324723248232492325023251232522325323254232552325623257232582325923260232612326223263232642326523266232672326823269232702327123272232732327423275232762327723278232792328023281232822328323284232852328623287232882328923290232912329223293232942329523296232972329823299233002330123302233032330423305233062330723308233092331023311233122331323314233152331623317233182331923320233212332223323233242332523326233272332823329233302333123332233332333423335233362333723338233392334023341233422334323344233452334623347233482334923350233512335223353233542335523356233572335823359233602336123362233632336423365233662336723368233692337023371233722337323374233752337623377233782337923380233812338223383233842338523386233872338823389233902339123392233932339423395233962339723398233992340023401234022340323404234052340623407234082340923410234112341223413234142341523416234172341823419234202342123422234232342423425234262342723428234292343023431234322343323434234352343623437234382343923440234412344223443234442344523446234472344823449234502345123452234532345423455234562345723458234592346023461234622346323464234652346623467234682346923470234712347223473234742347523476234772347823479234802348123482234832348423485234862348723488234892349023491234922349323494234952349623497234982349923500235012350223503235042350523506235072350823509235102351123512235132351423515235162351723518235192352023521235222352323524235252352623527235282352923530235312353223533235342353523536235372353823539235402354123542235432354423545235462354723548235492355023551235522355323554235552355623557235582355923560235612356223563235642356523566235672356823569235702357123572235732357423575235762357723578235792358023581235822358323584235852358623587235882358923590235912359223593235942359523596235972359823599236002360123602236032360423605236062360723608236092361023611236122361323614236152361623617236182361923620236212362223623236242362523626236272362823629236302363123632236332363423635236362363723638236392364023641236422364323644236452364623647236482364923650236512365223653236542365523656236572365823659236602366123662236632366423665236662366723668236692367023671236722367323674236752367623677236782367923680236812368223683236842368523686236872368823689236902369123692236932369423695236962369723698236992370023701237022370323704237052370623707237082370923710237112371223713237142371523716237172371823719237202372123722237232372423725237262372723728237292373023731237322373323734237352373623737237382373923740237412374223743237442374523746237472374823749237502375123752237532375423755237562375723758237592376023761237622376323764237652376623767237682376923770237712377223773237742377523776237772377823779237802378123782237832378423785237862378723788237892379023791237922379323794237952379623797237982379923800238012380223803238042380523806238072380823809238102381123812238132381423815238162381723818238192382023821238222382323824238252382623827238282382923830238312383223833238342383523836238372383823839238402384123842238432384423845238462384723848238492385023851238522385323854238552385623857238582385923860238612386223863238642386523866238672386823869238702387123872238732387423875238762387723878238792388023881238822388323884238852388623887238882388923890238912389223893238942389523896238972389823899239002390123902239032390423905239062390723908239092391023911239122391323914239152391623917239182391923920239212392223923239242392523926239272392823929239302393123932239332393423935239362393723938239392394023941239422394323944239452394623947239482394923950239512395223953239542395523956239572395823959239602396123962239632396423965239662396723968239692397023971239722397323974239752397623977239782397923980239812398223983239842398523986239872398823989239902399123992239932399423995239962399723998239992400024001240022400324004240052400624007240082400924010240112401224013240142401524016240172401824019240202402124022240232402424025240262402724028240292403024031240322403324034240352403624037240382403924040240412404224043240442404524046240472404824049240502405124052240532405424055240562405724058240592406024061240622406324064240652406624067240682406924070240712407224073240742407524076240772407824079240802408124082240832408424085240862408724088240892409024091240922409324094240952409624097240982409924100241012410224103241042410524106241072410824109241102411124112241132411424115241162411724118241192412024121241222412324124241252412624127241282412924130241312413224133241342413524136241372413824139241402414124142241432414424145241462414724148241492415024151241522415324154241552415624157241582415924160241612416224163241642416524166241672416824169241702417124172241732417424175241762417724178241792418024181241822418324184241852418624187241882418924190241912419224193241942419524196241972419824199242002420124202242032420424205242062420724208242092421024211242122421324214242152421624217242182421924220242212422224223242242422524226242272422824229242302423124232242332423424235242362423724238242392424024241242422424324244242452424624247242482424924250242512425224253242542425524256242572425824259242602426124262242632426424265242662426724268242692427024271242722427324274242752427624277242782427924280242812428224283242842428524286242872428824289242902429124292242932429424295242962429724298242992430024301243022430324304243052430624307243082430924310243112431224313243142431524316243172431824319243202432124322243232432424325243262432724328243292433024331243322433324334243352433624337243382433924340243412434224343243442434524346243472434824349243502435124352243532435424355243562435724358243592436024361243622436324364243652436624367243682436924370243712437224373243742437524376243772437824379243802438124382243832438424385243862438724388243892439024391243922439324394243952439624397243982439924400244012440224403244042440524406244072440824409244102441124412244132441424415244162441724418244192442024421244222442324424244252442624427244282442924430244312443224433244342443524436244372443824439244402444124442244432444424445244462444724448244492445024451244522445324454244552445624457244582445924460244612446224463244642446524466244672446824469244702447124472244732447424475244762447724478244792448024481244822448324484244852448624487244882448924490244912449224493244942449524496244972449824499245002450124502245032450424505245062450724508245092451024511245122451324514245152451624517245182451924520245212452224523245242452524526245272452824529245302453124532245332453424535245362453724538245392454024541245422454324544245452454624547245482454924550245512455224553245542455524556245572455824559245602456124562245632456424565245662456724568245692457024571245722457324574245752457624577245782457924580245812458224583245842458524586245872458824589245902459124592245932459424595245962459724598245992460024601246022460324604246052460624607246082460924610246112461224613246142461524616246172461824619246202462124622246232462424625246262462724628246292463024631246322463324634246352463624637246382463924640246412464224643246442464524646246472464824649246502465124652246532465424655246562465724658246592466024661246622466324664246652466624667246682466924670246712467224673246742467524676246772467824679246802468124682246832468424685246862468724688246892469024691246922469324694246952469624697246982469924700247012470224703247042470524706247072470824709247102471124712247132471424715247162471724718247192472024721247222472324724247252472624727247282472924730247312473224733247342473524736247372473824739247402474124742247432474424745247462474724748247492475024751247522475324754247552475624757247582475924760247612476224763247642476524766247672476824769247702477124772247732477424775247762477724778247792478024781247822478324784247852478624787247882478924790247912479224793247942479524796247972479824799248002480124802248032480424805248062480724808248092481024811248122481324814248152481624817248182481924820248212482224823248242482524826248272482824829248302483124832248332483424835248362483724838248392484024841248422484324844248452484624847248482484924850248512485224853248542485524856248572485824859248602486124862248632486424865248662486724868248692487024871248722487324874248752487624877248782487924880248812488224883248842488524886248872488824889248902489124892248932489424895248962489724898248992490024901249022490324904249052490624907249082490924910249112491224913249142491524916249172491824919249202492124922249232492424925249262492724928249292493024931249322493324934249352493624937249382493924940249412494224943249442494524946249472494824949249502495124952249532495424955249562495724958249592496024961249622496324964249652496624967249682496924970249712497224973249742497524976249772497824979249802498124982249832498424985249862498724988249892499024991249922499324994249952499624997249982499925000250012500225003250042500525006250072500825009250102501125012250132501425015250162501725018250192502025021250222502325024250252502625027250282502925030250312503225033250342503525036250372503825039250402504125042250432504425045250462504725048250492505025051250522505325054250552505625057250582505925060250612506225063250642506525066250672506825069250702507125072250732507425075250762507725078250792508025081250822508325084250852508625087250882508925090250912509225093250942509525096250972509825099251002510125102251032510425105251062510725108251092511025111251122511325114251152511625117251182511925120251212512225123251242512525126251272512825129251302513125132251332513425135251362513725138251392514025141251422514325144251452514625147251482514925150251512515225153251542515525156251572515825159251602516125162251632516425165251662516725168251692517025171251722517325174251752517625177251782517925180251812518225183251842518525186251872518825189251902519125192251932519425195251962519725198251992520025201252022520325204252052520625207252082520925210252112521225213252142521525216252172521825219252202522125222252232522425225252262522725228252292523025231252322523325234252352523625237252382523925240252412524225243252442524525246252472524825249252502525125252252532525425255252562525725258252592526025261252622526325264252652526625267252682526925270252712527225273252742527525276252772527825279252802528125282252832528425285252862528725288252892529025291252922529325294252952529625297252982529925300253012530225303253042530525306253072530825309253102531125312253132531425315253162531725318253192532025321253222532325324253252532625327253282532925330253312533225333253342533525336253372533825339253402534125342253432534425345253462534725348253492535025351253522535325354253552535625357253582535925360253612536225363253642536525366253672536825369253702537125372253732537425375253762537725378253792538025381253822538325384253852538625387253882538925390253912539225393253942539525396253972539825399254002540125402254032540425405254062540725408254092541025411254122541325414254152541625417254182541925420254212542225423254242542525426254272542825429254302543125432254332543425435254362543725438254392544025441254422544325444254452544625447254482544925450254512545225453254542545525456254572545825459254602546125462254632546425465254662546725468254692547025471254722547325474254752547625477254782547925480254812548225483254842548525486254872548825489254902549125492254932549425495254962549725498254992550025501255022550325504255052550625507255082550925510255112551225513255142551525516255172551825519255202552125522255232552425525255262552725528255292553025531255322553325534255352553625537255382553925540255412554225543255442554525546255472554825549255502555125552255532555425555255562555725558255592556025561255622556325564255652556625567255682556925570255712557225573255742557525576255772557825579255802558125582255832558425585255862558725588255892559025591255922559325594255952559625597255982559925600256012560225603256042560525606256072560825609256102561125612256132561425615256162561725618256192562025621256222562325624256252562625627256282562925630256312563225633256342563525636256372563825639256402564125642256432564425645256462564725648256492565025651256522565325654256552565625657256582565925660256612566225663256642566525666256672566825669256702567125672256732567425675256762567725678256792568025681256822568325684256852568625687256882568925690256912569225693256942569525696256972569825699257002570125702257032570425705257062570725708257092571025711257122571325714257152571625717257182571925720257212572225723257242572525726257272572825729257302573125732257332573425735257362573725738257392574025741257422574325744257452574625747257482574925750257512575225753257542575525756257572575825759257602576125762257632576425765257662576725768257692577025771257722577325774257752577625777257782577925780257812578225783257842578525786257872578825789257902579125792257932579425795257962579725798257992580025801258022580325804258052580625807258082580925810258112581225813258142581525816258172581825819258202582125822258232582425825258262582725828258292583025831258322583325834258352583625837258382583925840258412584225843258442584525846258472584825849258502585125852258532585425855258562585725858258592586025861258622586325864258652586625867258682586925870258712587225873258742587525876258772587825879258802588125882258832588425885258862588725888258892589025891258922589325894258952589625897258982589925900259012590225903259042590525906259072590825909259102591125912259132591425915259162591725918259192592025921259222592325924259252592625927259282592925930259312593225933259342593525936259372593825939259402594125942259432594425945259462594725948259492595025951259522595325954259552595625957259582595925960259612596225963259642596525966259672596825969259702597125972259732597425975259762597725978259792598025981259822598325984259852598625987259882598925990259912599225993259942599525996259972599825999260002600126002260032600426005260062600726008260092601026011260122601326014260152601626017260182601926020260212602226023260242602526026260272602826029260302603126032260332603426035260362603726038260392604026041260422604326044260452604626047260482604926050260512605226053260542605526056260572605826059260602606126062260632606426065260662606726068260692607026071260722607326074260752607626077260782607926080260812608226083260842608526086260872608826089260902609126092260932609426095260962609726098260992610026101261022610326104261052610626107261082610926110261112611226113261142611526116261172611826119261202612126122261232612426125261262612726128261292613026131261322613326134261352613626137261382613926140261412614226143261442614526146261472614826149261502615126152261532615426155261562615726158261592616026161261622616326164261652616626167261682616926170261712617226173261742617526176261772617826179261802618126182261832618426185261862618726188261892619026191261922619326194261952619626197261982619926200262012620226203262042620526206262072620826209262102621126212262132621426215262162621726218262192622026221262222622326224262252622626227262282622926230262312623226233262342623526236262372623826239262402624126242262432624426245262462624726248262492625026251262522625326254262552625626257262582625926260262612626226263262642626526266262672626826269262702627126272262732627426275262762627726278262792628026281262822628326284262852628626287262882628926290262912629226293262942629526296262972629826299263002630126302263032630426305263062630726308263092631026311263122631326314263152631626317263182631926320263212632226323263242632526326263272632826329263302633126332263332633426335263362633726338263392634026341263422634326344263452634626347263482634926350263512635226353263542635526356263572635826359263602636126362263632636426365263662636726368263692637026371263722637326374263752637626377263782637926380263812638226383263842638526386263872638826389263902639126392263932639426395263962639726398263992640026401264022640326404264052640626407264082640926410264112641226413264142641526416264172641826419264202642126422264232642426425264262642726428264292643026431264322643326434264352643626437264382643926440264412644226443264442644526446264472644826449264502645126452264532645426455264562645726458264592646026461264622646326464264652646626467264682646926470264712647226473264742647526476264772647826479264802648126482264832648426485264862648726488264892649026491264922649326494264952649626497264982649926500265012650226503265042650526506265072650826509265102651126512265132651426515265162651726518265192652026521265222652326524265252652626527265282652926530265312653226533265342653526536265372653826539265402654126542265432654426545265462654726548265492655026551265522655326554265552655626557265582655926560265612656226563265642656526566265672656826569265702657126572265732657426575265762657726578265792658026581265822658326584265852658626587265882658926590265912659226593265942659526596265972659826599266002660126602266032660426605266062660726608266092661026611266122661326614266152661626617266182661926620266212662226623266242662526626266272662826629266302663126632266332663426635266362663726638266392664026641266422664326644266452664626647266482664926650266512665226653266542665526656266572665826659266602666126662266632666426665266662666726668266692667026671266722667326674266752667626677266782667926680266812668226683266842668526686266872668826689266902669126692266932669426695266962669726698266992670026701267022670326704267052670626707267082670926710267112671226713267142671526716267172671826719267202672126722267232672426725267262672726728267292673026731267322673326734267352673626737267382673926740267412674226743267442674526746267472674826749267502675126752267532675426755267562675726758267592676026761267622676326764267652676626767267682676926770267712677226773267742677526776267772677826779267802678126782267832678426785267862678726788267892679026791267922679326794267952679626797267982679926800268012680226803268042680526806268072680826809268102681126812268132681426815268162681726818268192682026821268222682326824268252682626827268282682926830268312683226833268342683526836268372683826839268402684126842268432684426845268462684726848268492685026851268522685326854268552685626857268582685926860268612686226863268642686526866268672686826869268702687126872268732687426875268762687726878268792688026881268822688326884268852688626887268882688926890268912689226893268942689526896268972689826899269002690126902269032690426905269062690726908269092691026911269122691326914269152691626917269182691926920269212692226923269242692526926269272692826929269302693126932269332693426935269362693726938269392694026941269422694326944269452694626947269482694926950269512695226953269542695526956269572695826959269602696126962269632696426965269662696726968269692697026971269722697326974269752697626977269782697926980269812698226983269842698526986269872698826989269902699126992269932699426995269962699726998269992700027001270022700327004270052700627007270082700927010270112701227013270142701527016270172701827019270202702127022270232702427025270262702727028270292703027031270322703327034270352703627037270382703927040270412704227043270442704527046270472704827049270502705127052270532705427055270562705727058270592706027061270622706327064270652706627067270682706927070270712707227073270742707527076270772707827079270802708127082270832708427085270862708727088270892709027091270922709327094270952709627097270982709927100271012710227103271042710527106271072710827109271102711127112271132711427115271162711727118271192712027121271222712327124271252712627127271282712927130271312713227133271342713527136271372713827139271402714127142271432714427145271462714727148271492715027151271522715327154271552715627157271582715927160271612716227163271642716527166271672716827169271702717127172271732717427175271762717727178271792718027181271822718327184271852718627187271882718927190271912719227193271942719527196271972719827199272002720127202272032720427205272062720727208272092721027211272122721327214272152721627217272182721927220272212722227223272242722527226272272722827229272302723127232272332723427235272362723727238272392724027241272422724327244272452724627247272482724927250272512725227253272542725527256272572725827259272602726127262272632726427265272662726727268272692727027271272722727327274272752727627277272782727927280272812728227283272842728527286272872728827289272902729127292272932729427295272962729727298272992730027301273022730327304273052730627307273082730927310273112731227313273142731527316273172731827319273202732127322273232732427325273262732727328273292733027331273322733327334273352733627337273382733927340273412734227343273442734527346273472734827349273502735127352273532735427355273562735727358273592736027361273622736327364273652736627367273682736927370273712737227373273742737527376273772737827379273802738127382273832738427385273862738727388273892739027391273922739327394273952739627397273982739927400274012740227403274042740527406274072740827409274102741127412274132741427415274162741727418274192742027421274222742327424274252742627427274282742927430274312743227433274342743527436274372743827439274402744127442274432744427445274462744727448274492745027451274522745327454274552745627457274582745927460274612746227463274642746527466274672746827469274702747127472274732747427475274762747727478274792748027481274822748327484274852748627487274882748927490274912749227493274942749527496274972749827499275002750127502275032750427505275062750727508275092751027511275122751327514275152751627517275182751927520275212752227523275242752527526275272752827529275302753127532275332753427535275362753727538275392754027541275422754327544275452754627547275482754927550275512755227553275542755527556275572755827559275602756127562275632756427565275662756727568275692757027571275722757327574275752757627577275782757927580275812758227583275842758527586275872758827589275902759127592275932759427595275962759727598275992760027601276022760327604276052760627607276082760927610276112761227613276142761527616276172761827619276202762127622276232762427625276262762727628276292763027631276322763327634276352763627637276382763927640276412764227643276442764527646276472764827649276502765127652276532765427655276562765727658276592766027661276622766327664276652766627667276682766927670276712767227673276742767527676276772767827679276802768127682276832768427685276862768727688276892769027691276922769327694276952769627697276982769927700277012770227703277042770527706277072770827709277102771127712277132771427715277162771727718277192772027721277222772327724277252772627727277282772927730277312773227733277342773527736277372773827739277402774127742277432774427745277462774727748277492775027751277522775327754277552775627757277582775927760277612776227763277642776527766277672776827769277702777127772277732777427775277762777727778277792778027781277822778327784277852778627787277882778927790277912779227793277942779527796277972779827799278002780127802278032780427805278062780727808278092781027811278122781327814278152781627817278182781927820278212782227823278242782527826278272782827829278302783127832278332783427835278362783727838278392784027841278422784327844278452784627847278482784927850278512785227853278542785527856278572785827859278602786127862278632786427865278662786727868278692787027871278722787327874278752787627877278782787927880278812788227883278842788527886278872788827889278902789127892278932789427895278962789727898278992790027901279022790327904279052790627907279082790927910279112791227913279142791527916279172791827919279202792127922279232792427925279262792727928279292793027931279322793327934279352793627937279382793927940279412794227943279442794527946279472794827949279502795127952279532795427955279562795727958279592796027961279622796327964279652796627967279682796927970279712797227973279742797527976279772797827979279802798127982279832798427985279862798727988279892799027991279922799327994279952799627997279982799928000280012800228003280042800528006280072800828009280102801128012280132801428015280162801728018280192802028021280222802328024280252802628027280282802928030280312803228033280342803528036280372803828039280402804128042280432804428045280462804728048280492805028051280522805328054280552805628057280582805928060280612806228063280642806528066280672806828069280702807128072280732807428075280762807728078280792808028081280822808328084280852808628087280882808928090280912809228093280942809528096280972809828099281002810128102281032810428105281062810728108281092811028111281122811328114281152811628117281182811928120281212812228123281242812528126281272812828129281302813128132281332813428135281362813728138281392814028141281422814328144281452814628147281482814928150281512815228153281542815528156281572815828159281602816128162281632816428165281662816728168281692817028171281722817328174281752817628177281782817928180281812818228183281842818528186281872818828189281902819128192281932819428195281962819728198281992820028201282022820328204282052820628207282082820928210282112821228213282142821528216282172821828219282202822128222282232822428225282262822728228282292823028231282322823328234282352823628237282382823928240282412824228243282442824528246282472824828249282502825128252282532825428255282562825728258282592826028261282622826328264282652826628267282682826928270282712827228273282742827528276282772827828279282802828128282282832828428285282862828728288282892829028291282922829328294282952829628297282982829928300283012830228303283042830528306283072830828309283102831128312283132831428315283162831728318283192832028321283222832328324283252832628327283282832928330283312833228333283342833528336283372833828339283402834128342283432834428345283462834728348283492835028351283522835328354283552835628357283582835928360283612836228363283642836528366283672836828369283702837128372283732837428375283762837728378283792838028381283822838328384283852838628387283882838928390283912839228393283942839528396283972839828399284002840128402284032840428405284062840728408284092841028411284122841328414284152841628417284182841928420284212842228423284242842528426284272842828429284302843128432284332843428435284362843728438284392844028441284422844328444284452844628447284482844928450284512845228453284542845528456284572845828459284602846128462284632846428465284662846728468284692847028471284722847328474284752847628477284782847928480284812848228483284842848528486284872848828489284902849128492284932849428495284962849728498284992850028501285022850328504285052850628507285082850928510285112851228513285142851528516285172851828519285202852128522285232852428525285262852728528285292853028531285322853328534285352853628537285382853928540285412854228543285442854528546285472854828549285502855128552285532855428555285562855728558285592856028561285622856328564285652856628567285682856928570285712857228573285742857528576285772857828579285802858128582285832858428585285862858728588285892859028591285922859328594285952859628597285982859928600286012860228603286042860528606286072860828609286102861128612286132861428615286162861728618286192862028621286222862328624286252862628627286282862928630286312863228633286342863528636286372863828639286402864128642286432864428645286462864728648286492865028651286522865328654286552865628657286582865928660286612866228663286642866528666286672866828669286702867128672286732867428675286762867728678286792868028681286822868328684286852868628687286882868928690286912869228693286942869528696286972869828699287002870128702287032870428705287062870728708287092871028711287122871328714287152871628717287182871928720287212872228723287242872528726287272872828729287302873128732287332873428735287362873728738287392874028741287422874328744287452874628747287482874928750287512875228753287542875528756287572875828759287602876128762287632876428765287662876728768287692877028771287722877328774287752877628777287782877928780287812878228783287842878528786287872878828789287902879128792287932879428795287962879728798287992880028801288022880328804288052880628807288082880928810288112881228813288142881528816288172881828819288202882128822288232882428825288262882728828288292883028831288322883328834288352883628837288382883928840288412884228843288442884528846288472884828849288502885128852288532885428855288562885728858288592886028861288622886328864288652886628867288682886928870288712887228873288742887528876288772887828879288802888128882288832888428885288862888728888288892889028891288922889328894288952889628897288982889928900289012890228903289042890528906289072890828909289102891128912289132891428915289162891728918289192892028921289222892328924289252892628927289282892928930289312893228933289342893528936289372893828939289402894128942289432894428945289462894728948289492895028951289522895328954289552895628957289582895928960289612896228963289642896528966289672896828969289702897128972289732897428975289762897728978289792898028981289822898328984289852898628987289882898928990289912899228993289942899528996289972899828999290002900129002290032900429005290062900729008290092901029011290122901329014290152901629017290182901929020290212902229023290242902529026290272902829029290302903129032290332903429035290362903729038290392904029041290422904329044290452904629047290482904929050290512905229053290542905529056290572905829059290602906129062290632906429065290662906729068290692907029071290722907329074290752907629077290782907929080290812908229083290842908529086290872908829089290902909129092290932909429095290962909729098290992910029101291022910329104291052910629107291082910929110291112911229113291142911529116291172911829119291202912129122291232912429125291262912729128291292913029131291322913329134291352913629137291382913929140291412914229143291442914529146291472914829149291502915129152291532915429155291562915729158291592916029161291622916329164291652916629167291682916929170291712917229173291742917529176291772917829179291802918129182291832918429185291862918729188291892919029191291922919329194291952919629197291982919929200292012920229203292042920529206292072920829209292102921129212292132921429215292162921729218292192922029221292222922329224292252922629227292282922929230292312923229233292342923529236292372923829239292402924129242292432924429245292462924729248292492925029251292522925329254292552925629257292582925929260292612926229263292642926529266292672926829269292702927129272292732927429275292762927729278292792928029281292822928329284292852928629287292882928929290292912929229293292942929529296292972929829299293002930129302293032930429305293062930729308293092931029311293122931329314293152931629317293182931929320293212932229323293242932529326293272932829329293302933129332293332933429335293362933729338293392934029341293422934329344293452934629347293482934929350293512935229353293542935529356293572935829359293602936129362293632936429365293662936729368293692937029371293722937329374293752937629377293782937929380293812938229383293842938529386293872938829389293902939129392293932939429395293962939729398293992940029401294022940329404294052940629407294082940929410294112941229413294142941529416294172941829419294202942129422294232942429425294262942729428294292943029431294322943329434294352943629437294382943929440294412944229443294442944529446294472944829449294502945129452294532945429455294562945729458294592946029461294622946329464294652946629467294682946929470294712947229473294742947529476294772947829479294802948129482294832948429485294862948729488294892949029491294922949329494294952949629497294982949929500295012950229503295042950529506295072950829509295102951129512295132951429515295162951729518295192952029521295222952329524295252952629527295282952929530295312953229533295342953529536295372953829539295402954129542295432954429545295462954729548295492955029551295522955329554295552955629557295582955929560295612956229563295642956529566295672956829569295702957129572295732957429575295762957729578295792958029581295822958329584295852958629587295882958929590295912959229593295942959529596295972959829599296002960129602296032960429605296062960729608296092961029611296122961329614296152961629617296182961929620296212962229623296242962529626296272962829629296302963129632296332963429635296362963729638296392964029641296422964329644296452964629647296482964929650296512965229653296542965529656296572965829659296602966129662296632966429665296662966729668296692967029671296722967329674296752967629677296782967929680296812968229683296842968529686296872968829689296902969129692296932969429695296962969729698296992970029701297022970329704297052970629707297082970929710297112971229713297142971529716297172971829719297202972129722297232972429725297262972729728297292973029731297322973329734297352973629737297382973929740297412974229743297442974529746297472974829749297502975129752297532975429755297562975729758297592976029761297622976329764297652976629767297682976929770297712977229773297742977529776297772977829779297802978129782297832978429785297862978729788297892979029791297922979329794297952979629797297982979929800298012980229803298042980529806298072980829809298102981129812298132981429815298162981729818298192982029821298222982329824298252982629827298282982929830298312983229833298342983529836298372983829839298402984129842298432984429845298462984729848298492985029851298522985329854298552985629857298582985929860298612986229863298642986529866298672986829869298702987129872298732987429875298762987729878298792988029881298822988329884298852988629887298882988929890298912989229893298942989529896298972989829899299002990129902299032990429905299062990729908299092991029911299122991329914299152991629917299182991929920299212992229923299242992529926299272992829929299302993129932299332993429935299362993729938299392994029941299422994329944299452994629947299482994929950299512995229953299542995529956299572995829959299602996129962299632996429965299662996729968299692997029971299722997329974299752997629977299782997929980299812998229983299842998529986299872998829989299902999129992299932999429995299962999729998299993000030001300023000330004300053000630007300083000930010300113001230013300143001530016300173001830019300203002130022300233002430025300263002730028300293003030031300323003330034300353003630037300383003930040300413004230043300443004530046300473004830049300503005130052300533005430055300563005730058300593006030061300623006330064300653006630067300683006930070300713007230073300743007530076300773007830079300803008130082300833008430085300863008730088300893009030091300923009330094300953009630097300983009930100301013010230103301043010530106301073010830109301103011130112301133011430115301163011730118301193012030121301223012330124301253012630127301283012930130301313013230133301343013530136301373013830139301403014130142301433014430145301463014730148301493015030151301523015330154301553015630157301583015930160301613016230163301643016530166301673016830169301703017130172301733017430175301763017730178301793018030181301823018330184301853018630187
  1. !#######################################################################
  2. !
  3. ! MDF - Multiple Data Format
  4. !
  5. ! NAME
  6. ! MDF - generic interface to a number of scientific data formats
  7. !
  8. !
  9. ! BACKGROUND
  10. !
  11. ! Single interface to multipe file formats.
  12. ! From 'multiple' it should evolve into 'many' and preferably 'most'.
  13. !
  14. ! This module is intended to replace an older f90 interface to HDF4
  15. ! called 'file_hdf'.
  16. !
  17. ! Creation of file follows the steps similar to writing a NetCDF file:
  18. ! o opening of the file
  19. ! o (global attributes)
  20. ! o definition of dimensions (plus attributes)
  21. ! o definition of variables (plus attributes)
  22. ! o end of definition phase
  23. ! o write one or more time records
  24. ! o close file
  25. !
  26. !
  27. ! PROCEDURES
  28. !
  29. ! !
  30. ! ! module initialisation
  31. ! !
  32. !
  33. ! subroutine MDF_Init( status )
  34. ! integer, intent(out) :: status
  35. !
  36. ! !
  37. ! ! write data
  38. ! !
  39. !
  40. ! ! create a new file for output:
  41. ! subroutine MDF_Create( filename, ftype, cmode, hid, status )
  42. ! character(len=*), intent(in) :: filename
  43. ! integer, intent(in) :: ftype
  44. ! integer, intent(in) :: cmode
  45. ! integer, intent(out) :: hid
  46. ! integer, intent(out) :: status
  47. !
  48. ! ! ... or create more than one with different formats;
  49. ! ! specify a single base name and an equal number of extensions and type:
  50. ! subroutine MDF_Create( basename, exts, ftypes, cmode, hid, status )
  51. ! character(len=*), intent(in) :: basename
  52. ! character(len=*), intent(in) :: exts(:)
  53. ! integer, intent(in) :: ftypes(:)
  54. ! integer, intent(in) :: cmode
  55. ! integer, intent(out) :: hid
  56. ! integer, intent(out) :: status
  57. !
  58. ! subroutine MDF_Def_Dim( hid, name, length, dimid, status )
  59. ! integer, intent(in) :: hid
  60. ! character(len=*), intent(in) :: name
  61. ! integer, intent(in) :: length
  62. ! integer, intent(out) :: dimid
  63. ! integer, intent(out) :: status
  64. !
  65. ! subroutine MDF_Def_Var( hid, name, xtype, dimids, varid, status, &
  66. ! compression, deflate_level )
  67. ! integer, intent(in) :: hid
  68. ! character(len=*), intent(in) :: name
  69. ! integer, intent(in) :: xtype
  70. ! integer, intent(in) :: dimids(:)
  71. ! integer, intent(out) :: varid
  72. ! integer, intent(out) :: status
  73. ! integer, intent(in), optional :: compression
  74. ! integer, intent(in), optional :: deflate_level ! 0-9
  75. !
  76. ! subroutine MDF_Put_Att( hid, varid, name, values, status )
  77. ! integer, intent(in) :: hid
  78. ! integer, intent(in) :: varid
  79. ! character(len=*), intent(in) :: name
  80. ! <type>, intent(in) :: value(s)
  81. ! integer, intent(out) :: status
  82. !
  83. ! subroutine MDF_EndDef( hid, status )
  84. ! integer, intent(in) :: hid
  85. ! integer, intent(out) :: status
  86. !
  87. ! ! put variable:
  88. ! subroutine MDF_Put_Var( hid, varid, values, status, &
  89. ! start, count, stride, map )
  90. ! integer, intent(in) :: hid
  91. ! integer, intent(in) :: varid
  92. ! <type>, intent(in) :: values(<shape>)
  93. ! integer, intent(out) :: status
  94. ! integer, intent(in), optional :: start(:) ! (/1,1,..,1/)
  95. ! integer, intent(in), optional :: count(:)
  96. ! integer, intent(in), optional :: stride(:)
  97. ! integer, intent(in), optional :: map(:)
  98. !
  99. ! ! close file(s):
  100. ! subroutine MDF_Close( hid, status )
  101. ! integer, intent(out) :: hid
  102. ! integer, intent(out) :: status
  103. !
  104. ! !
  105. ! ! read file
  106. ! !
  107. !
  108. ! ! open single file:
  109. ! subroutine MDF_Open( filename, ftype, mode, hid, status )
  110. ! character(len=*), intent(in) :: filename
  111. ! integer, intent(in) :: ftype
  112. ! integer, intent(in) :: mode
  113. ! integer, intent(out) :: hid
  114. ! integer, intent(out) :: status
  115. !
  116. ! subroutine MDF_Inquire( hid, status, &
  117. ! nDimensions, nVariables, nAttributes )
  118. ! integer, intent(in) :: hid
  119. ! integer, intent(out) :: status
  120. ! integer, intent(out), optional :: nDimensions
  121. ! integer, intent(out), optional :: nVariables
  122. ! integer, intent(out), optional :: nAttributes
  123. !
  124. ! subroutine MDF_Inq_DimID( hid, name, dimid, status )
  125. ! integer, intent(in) :: hid
  126. ! character(len=*), intent(in) :: name
  127. ! integer, intent(out) :: dimid
  128. ! integer, intent(out) :: status
  129. !
  130. ! subroutine MDF_Inquire_Dimension( hid, dimid, status, name, length, unlimited )
  131. ! integer, intent(in) :: hid
  132. ! integer, intent(in) :: dimid
  133. ! integer, intent(out) :: status
  134. ! character(len=*), intent(out), optional :: name
  135. ! integer, intent(out), optional :: length
  136. ! logical, intent(out), optional :: unlimited
  137. !
  138. ! subroutine MDF_Inq_VarID( hid, name, varid, status )
  139. ! integer, intent(in) :: hid
  140. ! character(len=*), intent(in) :: name
  141. ! integer, intent(out) :: varid
  142. ! integer, intent(out) :: status
  143. !
  144. ! subroutine MDF_Inquire_Variable( hid, varid, status, &
  145. ! name, xtype, ndims, dimids, natts )
  146. ! integer, intent(in) :: hid
  147. ! integer, intent(in) :: varid
  148. ! integer, intent(out) :: status
  149. ! character(len=*), intent(out), optional :: name
  150. ! integer, intent(out), optional :: xtype
  151. ! integer, intent(out), optional :: ndims
  152. ! integer, intent(out), optional :: dimids(:)
  153. ! integer, intent(out), optional :: natts
  154. !
  155. ! subroutine MDF_Get_Var( hid, varid, values, status, &
  156. ! start, count, stride, map )
  157. ! integer, intent(in) :: hid
  158. ! integer, intent(in) :: varid
  159. ! <type>, intent(out) :: values(<shape>)
  160. ! integer, intent(out) :: status
  161. ! integer, intent(in), optional :: start (:)
  162. ! integer, intent(in), optional :: count (:)
  163. ! integer, intent(in), optional :: stride(:)
  164. ! integer, intent(in), optional :: map (:)
  165. !
  166. ! subroutine MDF_Inq_AttName( hid, varid, attnum, name, status )
  167. ! integer, intent(in) :: hid
  168. ! integer, intent(in) :: varid
  169. ! integer, intent(in) :: attnum
  170. ! character(len=*), intent(out) :: name
  171. ! integer, intent(out) :: status
  172. !
  173. ! subroutine MDF_Inquire_Attribute( hid, varid, name, status, xtype, length )
  174. ! integer, intent(in) :: hid
  175. ! integer, intent(in) :: varid
  176. ! character(len=*), intent(out) :: name
  177. ! integer, intent(out) :: status
  178. ! integer, intent(out), optional :: xtype
  179. ! integer, intent(out), optional :: length
  180. !
  181. ! subroutine MDF_Get_Att( hid, varid, name, values, status )
  182. ! integer, intent(in) :: hid
  183. ! integer, intent(in) :: varid
  184. ! character(len=*), intent(in) :: name
  185. ! <type>, intent(out) :: value(s)
  186. ! integer, intent(out) :: status
  187. !
  188. ! ! close file:
  189. ! subroutine MDF_Close( hid, status )
  190. ! integer, intent(out) :: hid
  191. ! integer, intent(out) :: status
  192. !
  193. ! !
  194. ! ! parallel access
  195. ! !
  196. !
  197. ! ! create a new file for output:
  198. ! subroutine MDF_Create( filename, ftype, cmode, hid, status, &
  199. ! mpi_comm=comm, mpi_info=MPI_INFO_NULL )
  200. ! character(len=*), intent(in) :: filename
  201. ! integer, intent(in) :: cmode
  202. ! integer, intent(out) :: hid
  203. ! integer, intent(out) :: status
  204. ! integer, intent(in), optional :: mpi_comm
  205. ! integer, intent(in), optional :: mpi_info
  206. !
  207. ! ! ... or create more than one with different formats;
  208. ! ! specify a single base name and an equal number of extensions and type:
  209. ! subroutine MDF_Create( basename, exts, ftypes, cmode, hid, status, &
  210. ! mpi_comm=comm, mpi_info=MPI_INFO_NULL )
  211. ! character(len=*), intent(in) :: basename
  212. ! character(len=*), intent(in) :: exts(:)
  213. ! integer, intent(in) :: ftypes(:)
  214. ! integer, intent(in) :: cmode
  215. ! integer, intent(out) :: hid
  216. ! integer, intent(out) :: status
  217. ! integer, intent(in), optional :: mpi_comm
  218. ! integer, intent(in), optional :: mpi_info
  219. !
  220. ! ! open single file:
  221. ! subroutine MDF_Open( filename, ftype, mode, hid, status, &
  222. ! mpi_comm=comm, mpi_info=MPI_INFO_NULL )
  223. ! character(len=*), intent(in) :: filename
  224. ! integer, intent(in) :: ftype
  225. ! integer, intent(in) :: mode
  226. ! integer, intent(out) :: hid
  227. ! integer, intent(out) :: status
  228. ! integer, intent(in), optional :: mpi_comm
  229. ! integer, intent(in), optional :: mpi_info
  230. !
  231. ! ! parallel access mode (see NetCDF4 manual):
  232. ! subroutine MDF_Var_Par_Access( hid, varid, par_access_mode, status )
  233. ! integer, intent(in) :: hid
  234. ! integer, intent(out) :: varid
  235. ! integer, intent(in) :: par_access_mode
  236. ! integer, intent(out) :: status
  237. !
  238. ! !
  239. ! ! show file content
  240. ! !
  241. !
  242. ! ! show file headers similar to 'ncdump -h' ;
  243. ! ! file type is guessed from extension if not specified directly:
  244. ! subroutine MDF_Show( filename, status [,filetype=MDF_NETCDF4|MDF_HDF|...] )
  245. ! character(len=*), intent(in) :: filename
  246. ! integer, intent(out) :: status
  247. ! integer, intent(in), optional :: filetype
  248. ! integer, intent(out) :: status
  249. !
  250. ! !
  251. ! ! end module access
  252. ! !
  253. !
  254. ! ! done with module:
  255. ! subroutine MDF_Done( status )
  256. ! integer, intent(out) :: status
  257. !
  258. !
  259. ! CREATION AND OPEN MODES
  260. !
  261. ! MDF_NEW : new file, error if already present
  262. ! MDF_REPLACE : new file, overwrite older file if necessary
  263. ! MDF_READ : open existing file for reading
  264. ! MDF_WRITE : open existing file for writing
  265. !
  266. !
  267. ! FILE TYPES
  268. !
  269. ! MDF_HDF4 : HDF4
  270. ! MDF_NETCDF : NetCDF (clasical format ; via NetCDF-3 or NetCDF-4 library)
  271. ! MDF_NETCDF4 : NetCDF4 (HDF5 format ; via NetCDF-4 library with NetCDF-4 features enabled;
  272. ! requires linking with HDF5 library too)
  273. !
  274. !
  275. ! GLOBAL ATTRIBUTES
  276. !
  277. ! To write global attributes, use the constant 'MDF_GLOBAL' as variable id.
  278. !
  279. !
  280. ! UNLIMITED DIMENSION
  281. !
  282. ! To define an unlimited dimension, use the constant 'MDF_UNLIMITED'
  283. ! as dimension length.
  284. !
  285. !
  286. ! DATA TYPES
  287. !
  288. ! MDF_CHAR
  289. ! MDF_BYTE
  290. ! MDF_SHORT
  291. ! MDF_INT
  292. ! MDF_FLOAT
  293. ! MDF_DOUBLE
  294. !
  295. !
  296. ! PARALLEL ACCESS MODES
  297. !
  298. ! MDF_INDEPENDENT ! independent data mode (one processor at a time can read/write)
  299. ! MDF_COLLECTIVE ! collective data mode (several processors can do I/O simultaneously )
  300. !
  301. !
  302. ! FPP MACRO'S
  303. !
  304. ! The following fpp macro's might be defined to compile only certain parts of the code:
  305. !
  306. ! with_hdf4 : compile with calls to HDF (=HDF4) library
  307. ! with_netcdf : compile with calls to NetCDF library
  308. ! with_netcdf4 : compile with calls to NetCDF-4 library with NetCDF-4 features enabled;
  309. ! automatically defines 'with_netcdf'
  310. ! with_netcdf4_par : compile with calls to NetCDF-4 library with NetCDF-4 and parallel
  311. ! features enabled; automatically defines 'with_netcdf4'
  312. !
  313. ! with_go : GO module is availble.
  314. ! If this macro is not set, the required parts of GO are simulated.
  315. !
  316. !
  317. ! PARALLEL I/O FOR DIFFERENT NETCDF4 VERSIONS
  318. !
  319. ! From NetCDF version 4.1 onwards it seems necessary to use a special creation mode
  320. ! named 'MPIIO' to open a file for parallel I/O :
  321. !
  322. ! status = NF90_Create( 'test.nc', NF90_NETCDF4+NF90_MPIIO, ncid,&
  323. ! comm=MPI_COMM_WORLD, info=MPI_INFO_NULL )
  324. !
  325. ! The following errors are related to this creation mode:
  326. ! o In version 4.0.1, there is no parameter 'NF90_MPIIO' yet.
  327. ! o In version 4.1.2, when 'NF90_MPIIO' is not used then the first call to a
  328. ! parallel i/o routine will raise:
  329. ! "Parallel operation on file opened for non-parallel acces"
  330. ! o In version 4.1.3, when 'NF90_Create' is called with 'comm' and 'info' arguments
  331. ! but not with creation mode 'NF90_MPIIO' :
  332. ! "Invalid argument" on create if opened with comm/info but not with creation mode NF90_MPIIO
  333. !
  334. ! To handle the 'NF90_MPIIO' behaviour correctly, the MDF module checks the NetCDF library
  335. ! version and uses hardcoded values to set the creation mode. If a version is not supported yet,
  336. ! an error message is raised and the user is suggested to add a new line to the code to support
  337. ! the new version.
  338. !
  339. !### macro's ###########################################################
  340. !
  341. #define TRACEBACK write (gol,'("in ",a," (",a,i6,")")') rname, __FILE__, __LINE__ ; call goErr
  342. !
  343. #define IF_NOT_OK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if
  344. #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if
  345. !
  346. #define IF_NF90_NOT_OK_RETURN(action) if (status/=NF90_NOERR) then; gol=NF90_StrError(status); call goErr; TRACEBACK; action; return; end if
  347. !
  348. ! macro's:
  349. #include "mdf.inc"
  350. !
  351. !#######################################################################
  352. ! netcdf4_par interface includes netcdf4 ...
  353. #ifdef with_netcdf4_par
  354. #define with_netcdf4
  355. #endif
  356. ! netcdf4 interface includes netcdf3 ...
  357. #ifdef with_netcdf4
  358. #define with_netcdf
  359. #endif
  360. module MDF
  361. #ifdef with_go
  362. use GO, only : gol, goPr, goErr
  363. #endif
  364. #ifdef with_hdf5_beta
  365. use HDF5, only : HID_T, HSIZE_T
  366. #endif
  367. #ifdef with_netcdf
  368. use NETCDF, only : NF90_NOERR, NF90_StrError
  369. #endif
  370. implicit none
  371. ! --- in/out ---------------------------------------
  372. private
  373. public :: MDF_Init, MDF_Done
  374. public :: MDF_Create, MDF_Open, MDF_Close
  375. public :: MDF_EndDef
  376. public :: MDF_Inquire
  377. public :: MDF_Def_Dim
  378. public :: MDF_Inq_DimID
  379. public :: MDF_Inquire_Dimension
  380. public :: MDF_Def_Var
  381. public :: MDF_Var_Par_Access
  382. public :: MDF_Inq_VarID
  383. public :: MDF_Inquire_Variable
  384. public :: MDF_Put_Var
  385. public :: MDF_Get_Var
  386. public :: MDF_Put_Att
  387. public :: MDF_Get_Att
  388. public :: MDF_Show
  389. public :: MDF_NONE
  390. public :: MDF_NEW
  391. public :: MDF_REPLACE
  392. public :: MDF_READ
  393. public :: MDF_WRITE
  394. public :: MDF_HDF4
  395. public :: MDF_HDF5
  396. public :: MDF_NETCDF
  397. public :: MDF_NETCDF4
  398. public :: MDF_CHAR
  399. public :: MDF_BYTE
  400. public :: MDF_SHORT
  401. public :: MDF_INT
  402. public :: MDF_FLOAT
  403. public :: MDF_DOUBLE
  404. public :: MDF_DATATYPE_NAME
  405. public :: MDF_DEFLATE
  406. public :: MDF_INDEPENDENT, MDF_COLLECTIVE
  407. public :: MDF_GLOBAL
  408. public :: MDF_UNLIMITED
  409. ! --- const ----------------------------------------
  410. character(len=*), parameter :: mname = 'MDF'
  411. !
  412. ! creation modes
  413. !
  414. integer, parameter :: MDF_NEW = 1
  415. integer, parameter :: MDF_REPLACE = 2
  416. integer, parameter :: MDF_READ = 3
  417. integer, parameter :: MDF_WRITE = 4
  418. !
  419. integer, parameter :: MDF_CMODE_MAX = MDF_WRITE
  420. character(len=*), parameter :: MDF_CMODE_NAME(1:MDF_CMODE_MAX) = &
  421. (/ 'new ', 'replace', 'read ', 'write ' /)
  422. !
  423. ! file types
  424. !
  425. integer, parameter :: MDF_HDF4 = 1
  426. integer, parameter :: MDF_HDF5 = 2
  427. integer, parameter :: MDF_NETCDF = 3
  428. integer, parameter :: MDF_NETCDF4 = 4
  429. !
  430. integer, parameter :: MDF_FILETYPE_MAX = MDF_NETCDF4
  431. character(len=*), parameter :: MDF_FILETYPE_NAME(1:MDF_FILETYPE_MAX) = &
  432. (/ 'HDF4 ', 'HDF5 ', 'NetCDF ', 'NetCDF4' /)
  433. !
  434. ! data types
  435. !
  436. integer, parameter :: MDF_CHAR = 1 ! character
  437. integer, parameter :: MDF_BYTE = 2 ! integer(1)
  438. integer, parameter :: MDF_SHORT = 3 ! integer(2)
  439. integer, parameter :: MDF_INT = 4 ! integer(4)
  440. integer, parameter :: MDF_FLOAT = 5 ! real(4)
  441. integer, parameter :: MDF_DOUBLE = 6 ! real(8)
  442. !
  443. integer, parameter :: MDF_DATATYPE_MAX = MDF_DOUBLE
  444. character(len=*), parameter :: MDF_DATATYPE_NAME(1:MDF_DATATYPE_MAX) = &
  445. (/ 'char ','byte ','short ','int ','float ', 'double' /)
  446. !
  447. ! compression
  448. !
  449. integer, parameter :: MDF_DEFLATE = 1
  450. !
  451. integer, parameter :: MDF_COMPRESSION_MAX = MDF_DEFLATE
  452. character(len=*), parameter :: MDF_COMPRESSION_NAME(1:MDF_COMPRESSION_MAX) = &
  453. (/ 'deflate' /)
  454. !
  455. ! parallel access
  456. !
  457. integer, parameter :: MDF_INDEPENDENT = 1
  458. integer, parameter :: MDF_COLLECTIVE = 2
  459. !
  460. integer, parameter :: MDF_PARALLEL_ACCESS_MAX = MDF_INDEPENDENT
  461. character(len=*), parameter :: MDF_PARALLEL_ACCESS_NAME(1:MDF_PARALLEL_ACCESS_MAX) = &
  462. (/ 'independent' /)
  463. !
  464. ! special parameters
  465. !
  466. ! dummy ...
  467. integer, parameter :: MDF_NONE = -100
  468. ! special 'variable id' to add global attributes:
  469. integer, parameter :: MDF_GLOBAL = -101
  470. ! special dimension 'length' to denote unlimited dimension:
  471. integer, parameter :: MDF_UNLIMITED = -102
  472. #ifdef with_hdf4
  473. !
  474. ! hdf4 parameters
  475. !
  476. ! library constants constants
  477. include "hdf.f90"
  478. ! working precision of hdf library, used for handles:
  479. integer, parameter :: hdf4_wpi = 4
  480. #endif
  481. !
  482. ! internal
  483. !
  484. ! maximum rank of Fortran arrays:
  485. integer, parameter :: MAX_RANK = 7
  486. ! maximum length for variable names etc:
  487. integer, parameter :: LEN_NAME = 64
  488. integer, parameter :: LEN_FILE = 512
  489. integer, parameter :: LEN_LINE = 4000
  490. ! --- types ----------------------------------------
  491. ! interface to MDF dimension
  492. type MDF_Dim
  493. ! standard fields:
  494. character(len=LEN_NAME) :: name
  495. integer :: length
  496. logical :: unlimited
  497. logical :: named
  498. ! dimension id's
  499. #ifdef with_netcdf
  500. integer :: netcdf_dimid
  501. #endif
  502. end type MDF_Dim
  503. ! Define a structure with a pointer to the type;
  504. ! this is necessary to create a list of pointers:
  505. type P_MDF_Dim
  506. type(MDF_Dim), pointer :: p
  507. end type P_MDF_Dim
  508. ! define storage type for list with pointers:
  509. type MDF_Dim_List
  510. ! array of pointers; flexible size, increased if necessary
  511. type(P_MDF_Dim), pointer :: item(:)
  512. ! maximum number of filled items:
  513. integer :: maxitem
  514. ! actual number of filled items:
  515. integer :: nitem
  516. end type MDF_Dim_List
  517. ! interface to MDF variable
  518. type MDF_Var
  519. ! standard fields:
  520. character(len=LEN_NAME) :: name
  521. integer :: xtype
  522. integer :: xkind
  523. integer :: ndim
  524. integer :: dimids(MAX_RANK)
  525. integer :: shp(MAX_RANK)
  526. integer :: natt
  527. #ifdef with_hdf4
  528. integer :: hdf4_sdid
  529. integer :: hdf4_xtype
  530. #endif
  531. #ifdef with_hdf5_beta
  532. integer(HID_T) :: hdf5_dataset_id
  533. character(len=LEN_NAME) :: hdf5_name
  534. integer(HSIZE_T) :: hdf5_dims (MAX_RANK)
  535. integer(HSIZE_T) :: hdf5_maxdims (MAX_RANK)
  536. integer(HSIZE_T) :: hdf5_chunkdims(MAX_RANK)
  537. logical :: hdf5_chunked
  538. #endif
  539. #ifdef with_netcdf
  540. integer :: netcdf_varid
  541. #endif
  542. end type MDF_Var
  543. ! Define a structure with a pointer to the type;
  544. ! this is necessary to create a list of pointers:
  545. type P_MDF_Var
  546. type(MDF_Var), pointer :: p
  547. end type P_MDF_Var
  548. ! define storage type for list with pointers:
  549. type MDF_Var_List
  550. ! array of pointers; flexible size, increased if necessary
  551. type(P_MDF_Var), pointer :: item(:)
  552. ! maximum number of filled items:
  553. integer :: maxitem
  554. ! actual number of filled items:
  555. integer :: nitem
  556. end type MDF_Var_List
  557. ! interface to io file
  558. type MDF_File
  559. ! name of the file or basename of multiple files:
  560. character(len=LEN_FILE) :: filename
  561. ! creation mode:
  562. integer :: cmode
  563. ! parallel i/o ?
  564. logical :: parallel
  565. ! dimensions:
  566. type(MDF_Dim_List) :: Dim_List
  567. ! variables:
  568. type(MDF_Var_List) :: Var_List
  569. ! number of global attributes:
  570. integer :: natt
  571. ! file types:
  572. integer :: nftype
  573. integer :: ftypes(1:MDF_FILETYPE_MAX)
  574. ! access to file types:
  575. #ifdef with_hdf4
  576. character(len=LEN_FILE) :: hdf4_fname
  577. integer :: hdf4_id
  578. #endif
  579. #ifdef with_hdf5_beta
  580. character(len=LEN_FILE) :: hdf5_fname
  581. integer(HID_T) :: hdf5_file_id
  582. #endif
  583. #ifdef with_netcdf
  584. character(len=LEN_FILE) :: netcdf_fname
  585. integer :: netcdf_id
  586. #endif
  587. end type MDF_File
  588. ! Define a structure with a pointer to the type;
  589. ! this is necessary to create a list of pointers:
  590. type P_MDF_File
  591. type(MDF_File), pointer :: p
  592. end type P_MDF_File
  593. ! define storage type for list with pointers:
  594. type MDF_File_List
  595. ! array of pointers; flexible size, increased if necessary
  596. type(P_MDF_File), pointer :: item(:)
  597. ! maximum number of filled items:
  598. integer :: maxitem
  599. ! actual number of filled items:
  600. integer :: nitem
  601. end type MDF_File_List
  602. ! --- interfaces -----------------------------------
  603. interface MDF_Create
  604. module procedure MDF_Create_one
  605. module procedure MDF_Create_more
  606. end interface MDF_Create
  607. interface MDF_Put_Var
  608. module procedure MDF_Put_Var_c1_1d
  609. module procedure MDF_Put_Var_c1_2d
  610. module procedure MDF_Put_Var_c1_3d
  611. module procedure MDF_Put_Var_c1_4d
  612. module procedure MDF_Put_Var_c1_5d
  613. module procedure MDF_Put_Var_c1_6d
  614. module procedure MDF_Put_Var_c1_7d
  615. !
  616. module procedure MDF_Put_Var_i1_1d
  617. module procedure MDF_Put_Var_i1_2d
  618. module procedure MDF_Put_Var_i1_3d
  619. module procedure MDF_Put_Var_i1_4d
  620. module procedure MDF_Put_Var_i1_5d
  621. module procedure MDF_Put_Var_i1_6d
  622. module procedure MDF_Put_Var_i1_7d
  623. !
  624. module procedure MDF_Put_Var_i2_1d
  625. module procedure MDF_Put_Var_i2_2d
  626. module procedure MDF_Put_Var_i2_3d
  627. module procedure MDF_Put_Var_i2_4d
  628. module procedure MDF_Put_Var_i2_5d
  629. module procedure MDF_Put_Var_i2_6d
  630. module procedure MDF_Put_Var_i2_7d
  631. !
  632. module procedure MDF_Put_Var_i4_1d
  633. module procedure MDF_Put_Var_i4_2d
  634. module procedure MDF_Put_Var_i4_3d
  635. module procedure MDF_Put_Var_i4_4d
  636. module procedure MDF_Put_Var_i4_5d
  637. module procedure MDF_Put_Var_i4_6d
  638. module procedure MDF_Put_Var_i4_7d
  639. !
  640. module procedure MDF_Put_Var_r4_1d
  641. module procedure MDF_Put_Var_r4_2d
  642. module procedure MDF_Put_Var_r4_3d
  643. module procedure MDF_Put_Var_r4_4d
  644. module procedure MDF_Put_Var_r4_5d
  645. module procedure MDF_Put_Var_r4_6d
  646. module procedure MDF_Put_Var_r4_7d
  647. !
  648. module procedure MDF_Put_Var_r8_1d
  649. module procedure MDF_Put_Var_r8_2d
  650. module procedure MDF_Put_Var_r8_3d
  651. module procedure MDF_Put_Var_r8_4d
  652. module procedure MDF_Put_Var_r8_5d
  653. module procedure MDF_Put_Var_r8_6d
  654. module procedure MDF_Put_Var_r8_7d
  655. end interface
  656. interface MDF_Get_Var
  657. module procedure MDF_Get_Var_c1_1d
  658. module procedure MDF_Get_Var_c1_2d
  659. module procedure MDF_Get_Var_c1_3d
  660. module procedure MDF_Get_Var_c1_4d
  661. module procedure MDF_Get_Var_c1_5d
  662. module procedure MDF_Get_Var_c1_6d
  663. module procedure MDF_Get_Var_c1_7d
  664. !
  665. module procedure MDF_Get_Var_i1_1d
  666. module procedure MDF_Get_Var_i1_2d
  667. module procedure MDF_Get_Var_i1_3d
  668. module procedure MDF_Get_Var_i1_4d
  669. module procedure MDF_Get_Var_i1_5d
  670. module procedure MDF_Get_Var_i1_6d
  671. module procedure MDF_Get_Var_i1_7d
  672. !
  673. module procedure MDF_Get_Var_i2_1d
  674. module procedure MDF_Get_Var_i2_2d
  675. module procedure MDF_Get_Var_i2_3d
  676. module procedure MDF_Get_Var_i2_4d
  677. module procedure MDF_Get_Var_i2_5d
  678. module procedure MDF_Get_Var_i2_6d
  679. module procedure MDF_Get_Var_i2_7d
  680. !
  681. module procedure MDF_Get_Var_i4_1d
  682. module procedure MDF_Get_Var_i4_2d
  683. module procedure MDF_Get_Var_i4_3d
  684. module procedure MDF_Get_Var_i4_4d
  685. module procedure MDF_Get_Var_i4_5d
  686. module procedure MDF_Get_Var_i4_6d
  687. module procedure MDF_Get_Var_i4_7d
  688. !
  689. module procedure MDF_Get_Var_r4_1d
  690. module procedure MDF_Get_Var_r4_2d
  691. module procedure MDF_Get_Var_r4_3d
  692. module procedure MDF_Get_Var_r4_4d
  693. module procedure MDF_Get_Var_r4_5d
  694. module procedure MDF_Get_Var_r4_6d
  695. module procedure MDF_Get_Var_r4_7d
  696. !
  697. module procedure MDF_Get_Var_r8_1d
  698. module procedure MDF_Get_Var_r8_2d
  699. module procedure MDF_Get_Var_r8_3d
  700. module procedure MDF_Get_Var_r8_4d
  701. module procedure MDF_Get_Var_r8_5d
  702. module procedure MDF_Get_Var_r8_6d
  703. module procedure MDF_Get_Var_r8_7d
  704. end interface
  705. interface MDF_Put_Att
  706. module procedure MDF_Put_Att_c1_0d
  707. module procedure MDF_Put_Att_i1_0d
  708. module procedure MDF_Put_Att_i1_1d
  709. module procedure MDF_Put_Att_i2_0d
  710. module procedure MDF_Put_Att_i2_1d
  711. module procedure MDF_Put_Att_i4_0d
  712. module procedure MDF_Put_Att_i4_1d
  713. module procedure MDF_Put_Att_r4_0d
  714. module procedure MDF_Put_Att_r4_1d
  715. module procedure MDF_Put_Att_r8_0d
  716. module procedure MDF_Put_Att_r8_1d
  717. end interface
  718. interface MDF_Get_Att
  719. module procedure MDF_Get_Att_c1_0d
  720. module procedure MDF_Get_Att_i1_0d
  721. module procedure MDF_Get_Att_i1_1d
  722. module procedure MDF_Get_Att_i2_0d
  723. module procedure MDF_Get_Att_i2_1d
  724. module procedure MDF_Get_Att_i4_0d
  725. module procedure MDF_Get_Att_i4_1d
  726. module procedure MDF_Get_Att_r4_0d
  727. module procedure MDF_Get_Att_r4_1d
  728. module procedure MDF_Get_Att_r8_0d
  729. module procedure MDF_Get_Att_r8_1d
  730. end interface
  731. ! --- var ------------------------------------------
  732. #ifndef with_go
  733. ! message line:
  734. character(len=1024) :: gol
  735. #endif
  736. ! define lists:
  737. type(MDF_File_List) :: File_List
  738. contains
  739. #ifndef with_go
  740. ! ********************************************************************
  741. ! ***
  742. ! *** GO surrogate
  743. ! ***
  744. ! ********************************************************************
  745. ! substitutes for message routines from GO modules
  746. ! display message:
  747. subroutine goPr
  748. write (*,'(a)') trim(gol)
  749. end subroutine goPr
  750. ! display error message:
  751. subroutine goErr
  752. write (*,'("ERROR - ",a)') trim(gol)
  753. end subroutine goErr
  754. ! free file unit:
  755. subroutine goGetFU( fu, status )
  756. integer, intent(out) :: fu
  757. integer, intent(out) :: status
  758. logical :: opened
  759. fu = 456
  760. do
  761. inquire( unit=fu, opened=opened )
  762. if ( .not. opened ) exit
  763. fu = fu + 1
  764. end do
  765. status = 0
  766. end subroutine goGetFU
  767. #endif
  768. ! ********************************************************************
  769. ! ***
  770. ! *** MDF_Dim procedures
  771. ! ***
  772. ! ********************************************************************
  773. !
  774. ! Initialise a list.
  775. !
  776. subroutine MDF_Dim_List_Init( list, status )
  777. ! --- in/out -------------------------------------
  778. type(MDF_Dim_List), intent(out) :: list
  779. integer, intent(out) :: status
  780. ! --- const --------------------------------------
  781. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Init'
  782. ! --- begin --------------------------------------
  783. ! empty list:
  784. nullify( list%item )
  785. ! set counters:
  786. list%maxitem = 0
  787. list%nitem = 0
  788. ! ok
  789. status = 0
  790. end subroutine MDF_Dim_List_Init
  791. ! ***
  792. !
  793. ! Clear list, deallocate content.
  794. !
  795. subroutine MDF_Dim_List_Done( list, status )
  796. ! --- in/out -------------------------------------
  797. type(MDF_Dim_List), intent(inout) :: list
  798. integer, intent(out) :: status
  799. ! --- const --------------------------------------
  800. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Done'
  801. ! --- local --------------------------------------
  802. integer :: i
  803. ! --- begin --------------------------------------
  804. ! list defined ?
  805. if ( associated(list%item) ) then
  806. ! loop over all possible indices:
  807. do i = 1, list%maxitem
  808. ! filled ?
  809. if ( associated(list%item(i)%p) ) then
  810. ! remove structure, reset to save value:
  811. deallocate( list%item(i)%p )
  812. nullify( list%item(i)%p )
  813. end if
  814. end do
  815. ! clear, reset to save value:
  816. deallocate( list%item )
  817. nullify( list%item )
  818. end if
  819. ! set counters:
  820. list%maxitem = 0
  821. list%nitem = 0
  822. ! ok
  823. status = 0
  824. end subroutine MDF_Dim_List_Done
  825. ! ***
  826. !
  827. ! Add new item to list, return id number.
  828. !
  829. subroutine MDF_Dim_List_New_Item( list, hid, status )
  830. ! --- in/out -------------------------------------
  831. type(MDF_Dim_List), intent(inout) :: list
  832. integer, intent(out) :: hid
  833. integer, intent(out) :: status
  834. ! --- const --------------------------------------
  835. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_New_Item'
  836. ! --- local --------------------------------------
  837. integer :: i
  838. type(P_MDF_Dim), pointer :: item_new(:)
  839. ! --- begin --------------------------------------
  840. ! free item available ?
  841. if ( list%nitem < list%maxitem ) then
  842. ! search first empty item:
  843. hid = -1
  844. do i = 1, list%maxitem
  845. if ( .not. associated(list%item(i)%p) ) then
  846. hid = i
  847. exit
  848. end if
  849. end do
  850. ! not found ?
  851. if ( hid < 0 ) then
  852. write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr
  853. write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr
  854. write (gol,'(" nitem : ",i6)') list%nitem; call goErr
  855. TRACEBACK; status=1; return
  856. end if
  857. else
  858. ! allocate extra space:
  859. allocate( item_new(1:list%maxitem+100) )
  860. ! copy old pointers:
  861. do i = 1, list%maxitem
  862. item_new(i)%p => list%item(i)%p
  863. end do
  864. ! init new pointers:
  865. do i = list%maxitem+1, size(item_new)
  866. nullify(item_new(i)%p)
  867. end do
  868. ! first empty item:
  869. hid = list%maxitem+1
  870. ! clear old list if necessary:
  871. if ( associated(list%item) ) deallocate( list%item )
  872. ! point to new list:
  873. list%item => item_new
  874. ! reset size counter:
  875. list%maxitem = size(list%item)
  876. ! clear:
  877. nullify( item_new )
  878. end if
  879. ! allocate structure:
  880. allocate( list%item(hid)%p )
  881. ! increase counter:
  882. list%nitem = list%nitem + 1
  883. ! ok
  884. status = 0
  885. end subroutine MDF_Dim_List_New_Item
  886. ! ***
  887. !
  888. ! Remove item with given id from list.
  889. !
  890. subroutine MDF_Dim_List_Clear_Item( list, hid, status )
  891. ! --- in/out -------------------------------------
  892. type(MDF_Dim_List), intent(inout) :: list
  893. integer, intent(inout) :: hid
  894. integer, intent(out) :: status
  895. ! --- const --------------------------------------
  896. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Clear_Item'
  897. ! --- local --------------------------------------
  898. ! --- begin --------------------------------------
  899. ! check index in list ...
  900. if ( (hid < 0) .or. (hid > list%maxitem) ) then
  901. write (gol,'("handle outside range:")'); call goErr
  902. write (gol,'(" handle : ",i6)') hid; call goErr
  903. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  904. TRACEBACK; status=1; return
  905. end if
  906. ! check ...
  907. if ( .not. associated(list%item(hid)%p) ) then
  908. write (gol,'("handle not in use: ",i6)') hid; call goErr
  909. TRACEBACK; status=1; return
  910. end if
  911. ! clear structure:
  912. deallocate( list%item(hid)%p )
  913. ! reset pointer to save value:
  914. nullify( list%item(hid)%p )
  915. ! reset counter:
  916. list%nitem = list%nitem - 1
  917. ! ok
  918. status = 0
  919. end subroutine MDF_Dim_List_Clear_Item
  920. ! ***
  921. !
  922. ! Return pointer to user type given id.
  923. ! Status -1 if id is not in use.
  924. !
  925. subroutine MDF_Dim_List_Get_Pointer( list, hid, p, status, silent )
  926. ! --- in/out -------------------------------------
  927. type(MDF_Dim_List), intent(inout) :: list
  928. integer, intent(in) :: hid
  929. type(MDF_Dim), pointer :: p
  930. integer, intent(out) :: status
  931. logical, intent(in), optional :: silent
  932. ! --- const --------------------------------------
  933. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Get_Pointer'
  934. ! --- local --------------------------------------
  935. logical :: shout
  936. ! --- begin --------------------------------------
  937. ! messages ?
  938. shout = .true.
  939. if ( present(silent) ) shout = .not. silent
  940. ! check index in list ...
  941. if ( (hid < 1) .or. (hid > list%maxitem) ) then
  942. write (gol,'("handle outside range:")'); call goErr
  943. write (gol,'(" handle : ",i6)') hid; call goErr
  944. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  945. TRACEBACK; status=1; return
  946. end if
  947. ! check if handle is in use ...
  948. if ( .not. associated(list%item(hid)%p) ) then
  949. ! error or warning ?
  950. if ( shout ) then
  951. ! error status:
  952. write (gol,'("handle not in use: ",i6)') hid; call goErr
  953. TRACEBACK; status=1; return
  954. else
  955. ! warning status; this routine is used to test if a handle is in use:
  956. nullify( p )
  957. status = -1 ; return
  958. end if
  959. end if
  960. ! set shorthand:
  961. p => list%item(hid)%p
  962. ! ok
  963. status = 0
  964. end subroutine MDF_Dim_List_Get_Pointer
  965. ! ***
  966. !
  967. ! Return information:
  968. ! n
  969. ! Number of elements in use.
  970. ! maxid
  971. ! Current possible upper value for id's.
  972. ! Not all id's in {1,..,maxid} are in use.
  973. ! Usefull to implement a loop over all possible items.
  974. !
  975. subroutine MDF_Dim_List_Inquire( list, status, &
  976. n, maxid )
  977. ! --- in/out -------------------------------------
  978. type(MDF_Dim_List), intent(inout) :: list
  979. integer, intent(out) :: status
  980. integer, intent(out), optional :: n
  981. integer, intent(out), optional :: maxid
  982. ! --- const --------------------------------------
  983. character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Inquire'
  984. ! --- begin --------------------------------------
  985. ! set values ?
  986. if ( present(n ) ) n = list%nitem
  987. if ( present(maxid) ) maxid = list%maxitem
  988. ! ok
  989. status = 0
  990. end subroutine MDF_Dim_List_Inquire
  991. ! ********************************************************************
  992. ! ***
  993. ! *** MDF_Var procedures
  994. ! ***
  995. ! ********************************************************************
  996. !
  997. ! Initialise a list.
  998. !
  999. subroutine MDF_Var_List_Init( list, status )
  1000. ! --- in/out -------------------------------------
  1001. type(MDF_Var_List), intent(out) :: list
  1002. integer, intent(out) :: status
  1003. ! --- const --------------------------------------
  1004. character(len=*), parameter :: rname = mname//'/MDF_Var_List_Init'
  1005. ! --- begin --------------------------------------
  1006. ! empty list:
  1007. nullify( list%item )
  1008. ! set counters:
  1009. list%maxitem = 0
  1010. list%nitem = 0
  1011. ! ok
  1012. status = 0
  1013. end subroutine MDF_Var_List_Init
  1014. ! ***
  1015. !
  1016. ! Clear list, deallocate content.
  1017. !
  1018. subroutine MDF_Var_List_Done( list, status )
  1019. ! --- in/out -------------------------------------
  1020. type(MDF_Var_List), intent(inout) :: list
  1021. integer, intent(out) :: status
  1022. ! --- const --------------------------------------
  1023. character(len=*), parameter :: rname = mname//'/MDF_Var_List_Done'
  1024. ! --- local --------------------------------------
  1025. integer :: i
  1026. ! --- begin --------------------------------------
  1027. ! list defined ?
  1028. if ( associated(list%item) ) then
  1029. ! loop over all possible indices:
  1030. do i = 1, list%maxitem
  1031. ! filled ?
  1032. if ( associated(list%item(i)%p) ) then
  1033. ! remove structure, reset to save value:
  1034. deallocate( list%item(i)%p )
  1035. nullify( list%item(i)%p )
  1036. end if
  1037. end do
  1038. ! clear, reset to save value:
  1039. deallocate( list%item )
  1040. nullify( list%item )
  1041. end if
  1042. ! set counters:
  1043. list%maxitem = 0
  1044. list%nitem = 0
  1045. ! ok
  1046. status = 0
  1047. end subroutine MDF_Var_List_Done
  1048. ! ***
  1049. !
  1050. ! Add new item to list, return id number.
  1051. !
  1052. subroutine MDF_Var_List_New_Item( list, hid, status )
  1053. ! --- in/out -------------------------------------
  1054. type(MDF_Var_List), intent(inout) :: list
  1055. integer, intent(out) :: hid
  1056. integer, intent(out) :: status
  1057. ! --- const --------------------------------------
  1058. character(len=*), parameter :: rname = mname//'/MDF_Var_List_New_Item'
  1059. ! --- local --------------------------------------
  1060. integer :: i
  1061. type(P_MDF_Var), pointer :: item_new(:)
  1062. ! --- begin --------------------------------------
  1063. ! free item available ?
  1064. if ( list%nitem < list%maxitem ) then
  1065. ! search first empty item:
  1066. hid = -1
  1067. do i = 1, list%maxitem
  1068. if ( .not. associated(list%item(i)%p) ) then
  1069. hid = i
  1070. exit
  1071. end if
  1072. end do
  1073. ! not found ?
  1074. if ( hid < 0 ) then
  1075. write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr
  1076. write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr
  1077. write (gol,'(" nitem : ",i6)') list%nitem; call goErr
  1078. TRACEBACK; status=1; return
  1079. end if
  1080. else
  1081. ! allocate extra space:
  1082. allocate( item_new(1:list%maxitem+100) )
  1083. ! copy old pointers:
  1084. do i = 1, list%maxitem
  1085. item_new(i)%p => list%item(i)%p
  1086. end do
  1087. ! init new pointers:
  1088. do i = list%maxitem+1, size(item_new)
  1089. nullify(item_new(i)%p)
  1090. end do
  1091. ! first empty item:
  1092. hid = list%maxitem+1
  1093. ! clear old list if necessary:
  1094. if ( associated(list%item) ) deallocate( list%item )
  1095. ! point to new list:
  1096. list%item => item_new
  1097. ! reset size counter:
  1098. list%maxitem = size(list%item)
  1099. ! clear:
  1100. nullify( item_new )
  1101. end if
  1102. ! allocate structure:
  1103. allocate( list%item(hid)%p )
  1104. ! increase counter:
  1105. list%nitem = list%nitem + 1
  1106. ! ok
  1107. status = 0
  1108. end subroutine MDF_Var_List_New_Item
  1109. ! ***
  1110. !
  1111. ! Remove item with given id from list.
  1112. !
  1113. subroutine MDF_Var_List_Clear_Item( list, hid, status )
  1114. ! --- in/out -------------------------------------
  1115. type(MDF_Var_List), intent(inout) :: list
  1116. integer, intent(inout) :: hid
  1117. integer, intent(out) :: status
  1118. ! --- const --------------------------------------
  1119. character(len=*), parameter :: rname = mname//'/MDF_Var_List_Clear_Item'
  1120. ! --- local --------------------------------------
  1121. ! --- begin --------------------------------------
  1122. ! check index in list ...
  1123. if ( (hid < 0) .or. (hid > list%maxitem) ) then
  1124. write (gol,'("handle outside range:")'); call goErr
  1125. write (gol,'(" handle : ",i6)') hid; call goErr
  1126. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  1127. TRACEBACK; status=1; return
  1128. end if
  1129. ! check ...
  1130. if ( .not. associated(list%item(hid)%p) ) then
  1131. write (gol,'("handle not in use: ",i6)') hid; call goErr
  1132. TRACEBACK; status=1; return
  1133. end if
  1134. ! clear structure:
  1135. deallocate( list%item(hid)%p )
  1136. ! reset pointer to save value:
  1137. nullify( list%item(hid)%p )
  1138. ! reset counter:
  1139. list%nitem = list%nitem - 1
  1140. ! ok
  1141. status = 0
  1142. end subroutine MDF_Var_List_Clear_Item
  1143. ! ***
  1144. !
  1145. ! Return pointer to user type given id.
  1146. ! Status -1 if id is not in use.
  1147. !
  1148. subroutine MDF_Var_List_Get_Pointer( list, hid, p, status, silent )
  1149. ! --- in/out -------------------------------------
  1150. type(MDF_Var_List), intent(inout) :: list
  1151. integer, intent(in) :: hid
  1152. type(MDF_Var), pointer :: p
  1153. integer, intent(out) :: status
  1154. logical, intent(in), optional :: silent
  1155. ! --- const --------------------------------------
  1156. character(len=*), parameter :: rname = mname//'/MDF_Var_List_Get_Pointer'
  1157. ! --- local --------------------------------------
  1158. logical :: shout
  1159. ! --- begin --------------------------------------
  1160. ! messages ?
  1161. shout = .true.
  1162. if ( present(silent) ) shout = .not. silent
  1163. ! check index in list ...
  1164. if ( (hid < 1) .or. (hid > list%maxitem) ) then
  1165. write (gol,'("handle outside range:")'); call goErr
  1166. write (gol,'(" handle : ",i6)') hid; call goErr
  1167. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  1168. TRACEBACK; status=1; return
  1169. end if
  1170. ! check if handle is in use ...
  1171. if ( .not. associated(list%item(hid)%p) ) then
  1172. ! error or warning ?
  1173. if ( shout ) then
  1174. ! error status:
  1175. write (gol,'("handle not in use: ",i6)') hid; call goErr
  1176. TRACEBACK; status=1; return
  1177. else
  1178. ! warning status; this routine is used to test if a handle is in use:
  1179. nullify( p )
  1180. status = -1 ; return
  1181. end if
  1182. end if
  1183. ! set shorthand:
  1184. p => list%item(hid)%p
  1185. ! ok
  1186. status = 0
  1187. end subroutine MDF_Var_List_Get_Pointer
  1188. ! ***
  1189. !
  1190. ! Return information:
  1191. ! n
  1192. ! Number of elements in use.
  1193. ! maxid
  1194. ! Current possible upper value for id's.
  1195. ! Not all id's in {1,..,maxid} are in use.
  1196. ! Usefull to implement a loop over all possible items.
  1197. !
  1198. subroutine MDF_Var_List_Inquire( list, status, &
  1199. n, maxid )
  1200. ! --- in/out -------------------------------------
  1201. type(MDF_Var_List), intent(inout) :: list
  1202. integer, intent(out) :: status
  1203. integer, intent(out), optional :: n
  1204. integer, intent(out), optional :: maxid
  1205. ! --- const --------------------------------------
  1206. character(len=*), parameter :: rname = mname//'/MDF_Var_List_Inquire'
  1207. ! --- begin --------------------------------------
  1208. ! set values ?
  1209. if ( present(n ) ) n = list%nitem
  1210. if ( present(maxid) ) maxid = list%maxitem
  1211. ! ok
  1212. status = 0
  1213. end subroutine MDF_Var_List_Inquire
  1214. ! ********************************************************************
  1215. ! ***
  1216. ! *** MDF procedures
  1217. ! ***
  1218. ! ********************************************************************
  1219. !
  1220. ! Initialise a list.
  1221. !
  1222. subroutine MDF_File_List_Init( list, status )
  1223. ! --- in/out -------------------------------------
  1224. type(MDF_File_List), intent(out) :: list
  1225. integer, intent(out) :: status
  1226. ! --- const --------------------------------------
  1227. character(len=*), parameter :: rname = mname//'/MDF_File_List_Init'
  1228. ! --- begin --------------------------------------
  1229. ! empty list:
  1230. nullify( list%item )
  1231. ! set counters:
  1232. list%maxitem = 0
  1233. list%nitem = 0
  1234. ! ok
  1235. status = 0
  1236. end subroutine MDF_File_List_Init
  1237. ! ***
  1238. !
  1239. ! Clear list, deallocate content.
  1240. !
  1241. subroutine MDF_File_List_Done( list, status )
  1242. ! --- in/out -------------------------------------
  1243. type(MDF_File_List), intent(inout) :: list
  1244. integer, intent(out) :: status
  1245. ! --- const --------------------------------------
  1246. character(len=*), parameter :: rname = mname//'/MDF_File_List_Done'
  1247. ! --- local --------------------------------------
  1248. integer :: i
  1249. ! --- begin --------------------------------------
  1250. ! list defined ?
  1251. if ( associated(list%item) ) then
  1252. ! loop over all possible indices:
  1253. do i = 1, list%maxitem
  1254. ! filled ?
  1255. if ( associated(list%item(i)%p) ) then
  1256. ! remove structure, reset to save value:
  1257. deallocate( list%item(i)%p )
  1258. nullify( list%item(i)%p )
  1259. end if
  1260. end do
  1261. ! clear, reset to save value:
  1262. deallocate( list%item )
  1263. nullify( list%item )
  1264. end if
  1265. ! set counters:
  1266. list%maxitem = 0
  1267. list%nitem = 0
  1268. ! ok
  1269. status = 0
  1270. end subroutine MDF_File_List_Done
  1271. ! ***
  1272. !
  1273. ! Add new item to list, return id number.
  1274. !
  1275. subroutine MDF_File_List_New_Item( list, hid, status )
  1276. ! --- in/out -------------------------------------
  1277. type(MDF_File_List), intent(inout) :: list
  1278. integer, intent(out) :: hid
  1279. integer, intent(out) :: status
  1280. ! --- const --------------------------------------
  1281. character(len=*), parameter :: rname = mname//'/MDF_File_List_New_Item'
  1282. ! --- local --------------------------------------
  1283. integer :: i
  1284. type(P_MDF_File), pointer :: item_new(:)
  1285. ! --- begin --------------------------------------
  1286. ! free item available ?
  1287. if ( list%nitem < list%maxitem ) then
  1288. ! search first empty item:
  1289. hid = -1
  1290. do i = 1, list%maxitem
  1291. if ( .not. associated(list%item(i)%p) ) then
  1292. hid = i
  1293. exit
  1294. end if
  1295. end do
  1296. ! not found ?
  1297. if ( hid < 0 ) then
  1298. write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr
  1299. write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr
  1300. write (gol,'(" nitem : ",i6)') list%nitem; call goErr
  1301. TRACEBACK; status=1; return
  1302. end if
  1303. else
  1304. ! allocate extra space:
  1305. allocate( item_new(1:list%maxitem+100) )
  1306. ! copy old pointers:
  1307. do i = 1, list%maxitem
  1308. item_new(i)%p => list%item(i)%p
  1309. end do
  1310. ! init new pointers:
  1311. do i = list%maxitem+1, size(item_new)
  1312. nullify(item_new(i)%p)
  1313. end do
  1314. ! first empty item:
  1315. hid = list%maxitem+1
  1316. ! clear old list if necessary:
  1317. if ( associated(list%item) ) deallocate( list%item )
  1318. ! point to new list:
  1319. list%item => item_new
  1320. ! reset size counter:
  1321. list%maxitem = size(list%item)
  1322. ! clear:
  1323. nullify( item_new )
  1324. end if
  1325. ! allocate structure:
  1326. allocate( list%item(hid)%p )
  1327. ! increase counter:
  1328. list%nitem = list%nitem + 1
  1329. ! ok
  1330. status = 0
  1331. end subroutine MDF_File_List_New_Item
  1332. ! ***
  1333. !
  1334. ! Remove item with given id from list.
  1335. !
  1336. subroutine MDF_File_List_Clear_Item( list, hid, status )
  1337. ! --- in/out -------------------------------------
  1338. type(MDF_File_List), intent(inout) :: list
  1339. integer, intent(inout) :: hid
  1340. integer, intent(out) :: status
  1341. ! --- const --------------------------------------
  1342. character(len=*), parameter :: rname = mname//'/MDF_File_List_Clear_Item'
  1343. ! --- local --------------------------------------
  1344. ! --- begin --------------------------------------
  1345. ! check index in list ...
  1346. if ( (hid < 0) .or. (hid > list%maxitem) ) then
  1347. write (gol,'("handle outside range:")'); call goErr
  1348. write (gol,'(" handle : ",i6)') hid; call goErr
  1349. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  1350. TRACEBACK; status=1; return
  1351. end if
  1352. ! check ...
  1353. if ( .not. associated(list%item(hid)%p) ) then
  1354. write (gol,'("handle not in use: ",i6)') hid; call goErr
  1355. TRACEBACK; status=1; return
  1356. end if
  1357. ! clear structure:
  1358. deallocate( list%item(hid)%p )
  1359. ! reset pointer to save value:
  1360. nullify( list%item(hid)%p )
  1361. ! reset counter:
  1362. list%nitem = list%nitem - 1
  1363. ! ok
  1364. status = 0
  1365. end subroutine MDF_File_List_Clear_Item
  1366. ! ***
  1367. !
  1368. ! Return pointer to user type given id.
  1369. ! Status -1 if id is not in use.
  1370. !
  1371. subroutine MDF_File_List_Get_Pointer( list, hid, p, status, silent )
  1372. ! --- in/out -------------------------------------
  1373. type(MDF_File_List), intent(inout) :: list
  1374. integer, intent(in) :: hid
  1375. type(MDF_File), pointer :: p
  1376. integer, intent(out) :: status
  1377. logical, intent(in), optional :: silent
  1378. ! --- const --------------------------------------
  1379. character(len=*), parameter :: rname = mname//'/MDF_File_List_Get_Pointer'
  1380. ! --- local --------------------------------------
  1381. logical :: shout
  1382. ! --- begin --------------------------------------
  1383. ! messages ?
  1384. shout = .true.
  1385. if ( present(silent) ) shout = .not. silent
  1386. ! check index in list ...
  1387. if ( (hid < 1) .or. (hid > list%maxitem) ) then
  1388. write (gol,'("handle outside range:")'); call goErr
  1389. write (gol,'(" handle : ",i6)') hid; call goErr
  1390. write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr
  1391. TRACEBACK; status=1; return
  1392. end if
  1393. ! check if handle is in use ...
  1394. if ( .not. associated(list%item(hid)%p) ) then
  1395. ! error or warning ?
  1396. if ( shout ) then
  1397. ! error status:
  1398. write (gol,'("handle not in use: ",i6)') hid; call goErr
  1399. TRACEBACK; status=1; return
  1400. else
  1401. ! warning status; this routine is used to test if a handle is in use:
  1402. nullify( p )
  1403. status = -1 ; return
  1404. end if
  1405. end if
  1406. ! set shorthand:
  1407. p => list%item(hid)%p
  1408. ! ok
  1409. status = 0
  1410. end subroutine MDF_File_List_Get_Pointer
  1411. ! ***
  1412. !
  1413. ! Return information:
  1414. ! n
  1415. ! Number of elements in use.
  1416. ! maxid
  1417. ! Current possible upper value for id's.
  1418. ! Not all id's in {1,..,maxid} are in use.
  1419. ! Usefull to implement a loop over all possible items.
  1420. !
  1421. subroutine MDF_File_List_Inquire( list, status, &
  1422. n, maxid )
  1423. ! --- in/out -------------------------------------
  1424. type(MDF_File_List), intent(inout) :: list
  1425. integer, intent(out) :: status
  1426. integer, intent(out), optional :: n
  1427. integer, intent(out), optional :: maxid
  1428. ! --- const --------------------------------------
  1429. character(len=*), parameter :: rname = mname//'/MDF_File_List_Inquire'
  1430. ! --- begin --------------------------------------
  1431. ! set values ?
  1432. if ( present(n ) ) n = list%nitem
  1433. if ( present(maxid) ) maxid = list%maxitem
  1434. ! ok
  1435. status = 0
  1436. end subroutine MDF_File_List_Inquire
  1437. ! ********************************************************************
  1438. ! ***
  1439. ! *** tools
  1440. ! ***
  1441. ! ********************************************************************
  1442. subroutine MDF_Get_Kind( xtype, xkind, status )
  1443. ! --- in/out -------------------------------------
  1444. integer, intent(in) :: xtype
  1445. integer, intent(out) :: xkind
  1446. integer, intent(out) :: status
  1447. ! --- const --------------------------------------
  1448. character(len=*), parameter :: rname = mname//'/MDF_Get_Kind'
  1449. ! --- begin --------------------------------------
  1450. ! set kind value given type:
  1451. select case ( xtype )
  1452. case ( MDF_CHAR ) ; xkind = 1
  1453. case ( MDF_BYTE ) ; xkind = 1
  1454. case ( MDF_SHORT ) ; xkind = 2
  1455. case ( MDF_INT ) ; xkind = 4
  1456. case ( MDF_FLOAT ) ; xkind = 4
  1457. case ( MDF_DOUBLE ) ; xkind = 8
  1458. case default
  1459. write (gol,'("do not know kind for variable type : ",i6)') xtype; call goPr
  1460. TRACEBACK; status=1; return
  1461. end select
  1462. ! ok
  1463. status = 0
  1464. end subroutine MDF_Get_Kind
  1465. ! ***
  1466. #ifdef with_hdf5_beta
  1467. subroutine HDF5_Get_MDF_Type( hdf5_type_id, mdf_type, status )
  1468. use HDF5, only : HID_T
  1469. use HDF5, only : H5TGet_Class_f, H5TGet_Size_f, H5TClose_f
  1470. use HDF5, only : H5T_STRING_F, H5T_INTEGER_F, H5T_FLOAT_F
  1471. ! --- in/out -------------------------------------
  1472. integer(HID_T), intent(in) :: hdf5_type_id
  1473. integer, intent(out) :: mdf_type
  1474. integer, intent(out) :: status
  1475. ! --- const --------------------------------------
  1476. character(len=*), parameter :: rname = mname//'/HDF5_Get_MDF_Type'
  1477. ! --- local --------------------------------------
  1478. integer :: hdf5_typeclass, hdf5_typesize
  1479. ! --- begin --------------------------------------
  1480. ! get class:
  1481. call H5TGet_Class_f( hdf5_type_id, hdf5_typeclass, status )
  1482. IF_NOT_OK_RETURN(status=1)
  1483. ! split:
  1484. if ( hdf5_typeclass == H5T_STRING_F ) then
  1485. mdf_type = MDF_CHAR
  1486. else if ( hdf5_typeclass == H5T_INTEGER_F ) then
  1487. call H5TGet_Size_f( hdf5_type_id, hdf5_typesize, status )
  1488. IF_NOT_OK_RETURN(status=1)
  1489. select case ( hdf5_typesize )
  1490. case ( 1 ) ; mdf_type = MDF_BYTE
  1491. case ( 2 ) ; mdf_type = MDF_SHORT
  1492. case ( 4 ) ; mdf_type = MDF_INT
  1493. case default
  1494. write (gol,'("unsupported hdf5 type integer class size : ",i6)') hdf5_typesize; call goErr
  1495. TRACEBACK; status=1; return
  1496. end select
  1497. else if ( hdf5_typeclass == H5T_FLOAT_F ) then
  1498. call H5TGet_Size_f( hdf5_type_id, hdf5_typesize, status )
  1499. IF_NOT_OK_RETURN(status=1)
  1500. select case ( hdf5_typesize )
  1501. case ( 4 ) ; mdf_type = MDF_FLOAT
  1502. case ( 8 ) ; mdf_type = MDF_DOUBLE
  1503. case default
  1504. write (gol,'("unsupported hdf5 type float class size : ",i6)') hdf5_typesize; call goErr
  1505. TRACEBACK; status=1; return
  1506. end select
  1507. else
  1508. write (gol,'("unsupported hdf5 type class : ",i6)') hdf5_typeclass; call goErr
  1509. TRACEBACK; status=1; return
  1510. end if
  1511. ! ok
  1512. status = 0
  1513. end subroutine HDF5_Get_MDF_Type
  1514. #endif
  1515. #ifdef with_netcdf
  1516. subroutine NetCDF_Get_FileType( fname, ncformat, status )
  1517. use NetCDF, only : NF90_Open, NF90_Close, NF90_Inquire
  1518. use NetCDF, only : NF90_NOWRITE
  1519. use NetCDF, only : NF90_FORMAT_CLASSIC, NF90_FORMAT_64BIT, NF90_FORMAT_NETCDF4, NF90_FORMAT_NETCDF4_CLASSIC
  1520. ! --- in/out ---------------------------------
  1521. character(len=*), intent(in) :: fname
  1522. character(len=*), intent(out) :: ncformat
  1523. integer, intent(out) :: status
  1524. ! --- const --------------------------------------
  1525. character(len=*), parameter :: rname = mname//'/NetCDF_Get_FileType'
  1526. ! --- local ----------------------------------
  1527. logical :: exist
  1528. integer :: ncid
  1529. integer :: formatNum
  1530. ! --- begin ----------------------------------
  1531. ! check ...
  1532. inquire( file=trim(fname), exist=exist )
  1533. if ( .not. exist ) then
  1534. write (gol,'("file to be opened not found : ",a)') trim(fname); call goErr
  1535. TRACEBACK; status=1; return
  1536. end if
  1537. ! open file for reading:
  1538. status = NF90_Open( trim(fname), NF90_NOWRITE, ncid )
  1539. IF_NF90_NOT_OK_RETURN(status=1)
  1540. ! get format number:
  1541. status = NF90_Inquire( ncid, formatNum=formatNum )
  1542. IF_NF90_NOT_OK_RETURN(status=1)
  1543. ! translate ...
  1544. select case ( formatNum )
  1545. case ( NF90_FORMAT_CLASSIC ) ; ncformat = 'netcdf_classic'
  1546. case ( NF90_FORMAT_64BIT ) ; ncformat = 'netcdf_64bit'
  1547. case ( NF90_FORMAT_NETCDF4 ) ; ncformat = 'netcdf4'
  1548. case ( NF90_FORMAT_NETCDF4_CLASSIC ) ; ncformat = 'netcdf4_classic'
  1549. case default ; ncformat = 'netcdf_unknown'
  1550. end select
  1551. ! close file:
  1552. status = NF90_Close( ncid )
  1553. IF_NF90_NOT_OK_RETURN(status=1)
  1554. ! ok
  1555. status = 0
  1556. end subroutine NetCDF_Get_FileType
  1557. #endif
  1558. ! ********************************************************************
  1559. ! ***
  1560. ! *** module init/done
  1561. ! ***
  1562. ! ********************************************************************
  1563. subroutine MDF_Init( status, loglevel )
  1564. #ifdef with_hdf5_beta
  1565. use HDF5, only : H5Open_f
  1566. #endif
  1567. ! --- in/out -------------------------------------
  1568. integer, intent(out) :: status
  1569. integer, intent(in), optional :: loglevel
  1570. ! --- const --------------------------------------
  1571. character(len=*), parameter :: rname = mname//'/MDF_Init'
  1572. ! --- local --------------------------------------
  1573. integer :: loglev
  1574. ! --- begin --------------------------------------
  1575. ! log level ...
  1576. loglev = 0 ! no messages
  1577. if ( present(loglevel) ) loglev = loglevel
  1578. ! info ...
  1579. if (loglev>0) then; write (gol,'("initialize MDF module ...")'); call goPr; end if
  1580. #ifdef with_hdf4
  1581. ! info ...
  1582. if (loglev>0) then; write (gol,'(" HDF4 interface enabled ...")'); call goPr; end if
  1583. #else
  1584. ! info ...
  1585. if (loglev>0) then; write (gol,'(" HDF4 interface disabled ...")'); call goPr; end if
  1586. #endif
  1587. #ifdef with_hdf5_beta
  1588. ! initialize Fortran interface:
  1589. call H5Open_f( status )
  1590. IF_NOT_OK_RETURN(status=1)
  1591. ! info ...
  1592. if (loglev>0) then; write (gol,'(" HDF5 interface enabled ...")'); call goPr; end if
  1593. #endif
  1594. #ifdef with_netcdf
  1595. ! info ...
  1596. if (loglev>0) then; write (gol,'(" NetCDF interface enabled ...")'); call goPr; end if
  1597. #ifdef with_netcdf4
  1598. if (loglev>0) then; write (gol,'(" NetCDF4 interface enabled ...")'); call goPr; end if
  1599. #else
  1600. if (loglev>0) then; write (gol,'(" NetCDF4 interface disabled ...")'); call goPr; end if
  1601. #endif
  1602. #else
  1603. ! info ...
  1604. if (loglev>0) then; write (gol,'(" NetCDF interface disabled ...")'); call goPr; end if
  1605. #endif
  1606. ! setup empty list:
  1607. call MDF_File_List_Init( File_List, status )
  1608. IF_NOT_OK_RETURN(status=1)
  1609. ! ok
  1610. status = 0
  1611. end subroutine MDF_Init
  1612. ! ***
  1613. subroutine MDF_Done( status )
  1614. #ifdef with_hdf5_beta
  1615. use HDF5, only : H5Close_f
  1616. #endif
  1617. ! --- in/out -------------------------------------
  1618. integer, intent(out) :: status
  1619. ! --- const --------------------------------------
  1620. character(len=*), parameter :: rname = mname//'/MDF_Done'
  1621. ! --- local --------------------------------------
  1622. integer :: maxid
  1623. integer :: id
  1624. type(MDF_File), pointer :: filep
  1625. integer :: nerror
  1626. ! --- begin --------------------------------------
  1627. ! no errors yet ...
  1628. nerror = 0
  1629. ! get maximum id number:
  1630. call MDF_File_List_Inquire( File_List, status, maxid=maxid )
  1631. IF_NOT_OK_RETURN(status=1)
  1632. ! loop over all possible id's:
  1633. do id = 1, maxid
  1634. ! get pointer to file structure; status -1 if not in use:
  1635. call MDF_File_List_Get_Pointer( File_List, id, filep, status, silent=.true. )
  1636. if ( status == -1 ) cycle
  1637. IF_NOT_OK_RETURN(status=1)
  1638. ! error ...
  1639. write (gol,'("Called MDF_Done but file still in use: ",a)') trim(filep%filename); call goErr
  1640. nerror = nerror + 1
  1641. !! done with variables:
  1642. !call MDF_Var_List_Done( filep%Var_List, status )
  1643. !IF_NOT_OK_RETURN(status=1)
  1644. !! done with dimensions:
  1645. !call MDF_Dim_List_Done( filep%Dim_List, status )
  1646. !IF_NOT_OK_RETURN(status=1)
  1647. end do
  1648. ! clear list:
  1649. call MDF_File_List_Done( File_List, status )
  1650. IF_NOT_OK_RETURN(status=1)
  1651. #ifdef with_hdf5_beta
  1652. ! done with Fortran interface:
  1653. call H5Close_f( status )
  1654. IF_NOT_OK_RETURN(status=1)
  1655. #endif
  1656. ! ok
  1657. status = nerror
  1658. end subroutine MDF_Done
  1659. ! ********************************************************************
  1660. ! ***
  1661. ! *** file create/close
  1662. ! ***
  1663. ! ********************************************************************
  1664. subroutine MDF_Create_one( filename, ftype, cmode, hid, status, mpi_comm, mpi_info )
  1665. ! --- in/out -------------------------------------
  1666. character(len=*), intent(in) :: filename
  1667. integer, intent(in) :: ftype
  1668. integer, intent(in) :: cmode
  1669. integer, intent(out) :: hid
  1670. integer, intent(out) :: status
  1671. integer, intent(in), optional :: mpi_comm
  1672. integer, intent(in), optional :: mpi_info
  1673. ! --- const --------------------------------------
  1674. character(len=*), parameter :: rname = mname//'/MDF_Create_one'
  1675. ! --- local --------------------------------------
  1676. ! --- begin --------------------------------------
  1677. ! special case of more than one ....
  1678. call MDF_Create_more( filename, (/''/), (/ftype/), cmode, hid, status, &
  1679. mpi_comm, mpi_info )
  1680. IF_NOT_OK_RETURN(status=1)
  1681. ! ok
  1682. status = 0
  1683. end subroutine MDF_Create_one
  1684. ! ***
  1685. subroutine MDF_Create_more( basename, exts, ftypes, cmode, hid, status, &
  1686. mpi_comm, mpi_info )
  1687. #ifdef with_hdf5_beta
  1688. use HDF5, only : H5F_ACC_EXCL_F, H5F_ACC_TRUNC_F
  1689. use HDF5, only : H5FCreate_f
  1690. #endif
  1691. #ifdef with_netcdf
  1692. use NetCDF, only : NF90_CLOBBER, NF90_NOCLOBBER
  1693. use NetCDF, only : NF90_Create
  1694. #ifdef with_netcdf4
  1695. use NetCDF, only : NF90_CLASSIC_MODEL, NF90_NETCDF4
  1696. use NetCDF, only : NF90_Inq_LibVers
  1697. ! This parameter does not exist for library versions prior to 4.1 ;
  1698. ! Uncomment only ot get its value for your lib version, so you can hardcode it
  1699. ! The correct creation mode for parallel i/o :
  1700. !use NetCDF, only : NF90_MPIIO
  1701. #endif
  1702. #endif
  1703. ! --- in/out -------------------------------------
  1704. character(len=*), intent(in) :: basename
  1705. character(len=*), intent(in) :: exts(:)
  1706. integer, intent(in) :: ftypes(:)
  1707. integer, intent(in) :: cmode
  1708. integer, intent(out) :: hid
  1709. integer, intent(out) :: status
  1710. integer, intent(in), optional :: mpi_comm
  1711. integer, intent(in), optional :: mpi_info
  1712. ! --- const --------------------------------------
  1713. character(len=*), parameter :: rname = mname//'/MDF_Create_more'
  1714. ! --- external ----------------------------
  1715. #ifdef with_hdf4
  1716. integer(hdf4_wpi), external :: sfStart
  1717. #endif
  1718. ! --- local --------------------------------------
  1719. type(MDF_File), pointer :: filep
  1720. integer :: iftype
  1721. integer :: ftype
  1722. #ifdef with_hdf4
  1723. integer :: hdf4_amode
  1724. #endif
  1725. #ifdef with_hdf5_beta
  1726. integer :: hdf5_amode
  1727. #endif
  1728. #ifdef with_netcdf
  1729. integer :: netcdf_cmode
  1730. character(len=80) :: netcdf_version
  1731. #endif
  1732. ! --- begin --------------------------------------
  1733. ! new file:
  1734. call MDF_File_List_New_Item( File_List, hid, status )
  1735. IF_NOT_OK_RETURN(status=1)
  1736. ! pointer to file structure:
  1737. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  1738. IF_NOT_OK_RETURN(status=1)
  1739. ! store filename stuff:
  1740. filep%filename = trim(basename)
  1741. ! store creation mode:
  1742. filep%cmode = cmode
  1743. ! parallel i/o ?
  1744. filep%parallel = present(mpi_comm) .or. present(mpi_info)
  1745. ! check ...
  1746. if ( filep%parallel ) then
  1747. if ( .not. all((/present(mpi_comm),present(mpi_info)/)) ) then
  1748. write (gol,'("Only one of the arguments `mpi_comm` or `mpi_info` provided, that is not enough!")'); call goErr
  1749. TRACEBACK; status=1; return
  1750. end if
  1751. end if
  1752. ! check ...
  1753. if ( size(exts) /= size(ftypes) ) then
  1754. write (gol,'("number of specified extensions should equal number of specfied file types:")'); call goErr
  1755. write (gol,'(" number of specified extensions : ",i6)') size(exts); call goErr
  1756. write (gol,'(" number of specified file types : ",i6)') size(ftypes); call goErr
  1757. TRACEBACK; status=1; return
  1758. end if
  1759. ! check ...
  1760. if ( size(ftypes) > MDF_FILETYPE_MAX ) then
  1761. write (gol,'("more file types specified than supported")'); call goErr
  1762. write (gol,'(" maximum number : ",i6)') MDF_FILETYPE_MAX; call goErr
  1763. write (gol,'(" specified : ",i6)') size(ftypes); call goErr
  1764. TRACEBACK; status=1; return
  1765. end if
  1766. ! store file types:
  1767. filep%nftype = size(ftypes)
  1768. filep%ftypes(1:filep%nftype) = ftypes
  1769. ! loop over file types:
  1770. do iftype = 1, filep%nftype
  1771. ! current type:
  1772. ftype = filep%ftypes(iftype)
  1773. ! select appropriate routine for each type:
  1774. select case ( ftype )
  1775. #ifdef with_hdf4
  1776. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1777. case ( MDF_HDF4 )
  1778. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1779. ! check ...
  1780. if ( filep%parallel ) then
  1781. write (gol,'("HDF4 files could not be created in parallel")'); call goErr
  1782. TRACEBACK; status=1; return
  1783. end if
  1784. ! full file name:
  1785. filep%hdf4_fname = trim(filep%filename)//trim(exts(iftype))
  1786. ! write to an new file (remove if exist)
  1787. hdf4_amode = DFACC_CREATE
  1788. ! open file:
  1789. filep%hdf4_id = sfStart( trim(filep%hdf4_fname), hdf4_amode )
  1790. if ( filep%hdf4_id == FAIL ) then
  1791. write (gol,'("from creating hdf4 file:")'); call goErr
  1792. write (gol,'(" ",a)') trim(filep%hdf4_fname); call goErr
  1793. write (gol,'(" does directory exist ?")'); call goErr
  1794. TRACEBACK; status=1; return
  1795. end if
  1796. #endif
  1797. #ifdef with_hdf5_beta
  1798. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1799. case ( MDF_HDF5 )
  1800. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1801. ! check ...
  1802. if ( filep%parallel ) then
  1803. write (gol,'("MDF/HDF5 not implemented for parallel creation yet")'); call goErr
  1804. TRACEBACK; status=1; return
  1805. end if
  1806. ! full file name:
  1807. filep%hdf5_fname = trim(filep%filename)//trim(exts(iftype))
  1808. ! initial access mode:
  1809. hdf5_amode = 0
  1810. ! set access mode:
  1811. select case ( cmode )
  1812. case ( MDF_NEW )
  1813. hdf5_amode = hdf5_amode + H5F_ACC_EXCL_F ! complain if already present
  1814. case ( MDF_REPLACE )
  1815. hdf5_amode = hdf5_amode + H5F_ACC_TRUNC_F ! overwrite if necessary
  1816. case default
  1817. write (gol,'("unsupported creation mode : ",i6)') cmode; call goErr
  1818. TRACEBACK; status=1; return
  1819. end select
  1820. ! open file:
  1821. call H5FCreate_f( trim(filep%hdf5_fname), hdf5_amode, filep%hdf5_file_id, status )
  1822. if (status/=0) then
  1823. write (gol,'("from creating hdf5 file:")'); call goErr
  1824. write (gol,'(" ",a)') trim(filep%hdf5_fname); call goErr
  1825. write (gol,'(" does directory exist ?")'); call goErr
  1826. TRACEBACK; status=1; return
  1827. end if
  1828. #endif
  1829. #ifdef with_netcdf
  1830. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1831. case ( MDF_NETCDF, MDF_NETCDF4 )
  1832. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1833. ! full file name:
  1834. filep%netcdf_fname = trim(filep%filename)//trim(exts(iftype))
  1835. ! initial creation mode:
  1836. netcdf_cmode = 0
  1837. ! set creation mode:
  1838. select case ( cmode )
  1839. case ( MDF_NEW )
  1840. netcdf_cmode = netcdf_cmode + NF90_NOCLOBBER ! complain if already present
  1841. case ( MDF_REPLACE )
  1842. netcdf_cmode = netcdf_cmode + NF90_CLOBBER ! overwrite if necessary
  1843. case default
  1844. write (gol,'("unsupported creation mode : ",i6)') cmode; call goErr
  1845. TRACEBACK; status=1; return
  1846. end select
  1847. ! latest format ?
  1848. #ifdef with_netcdf4
  1849. if ( ftype == MDF_NETCDF4 ) then
  1850. !netcdf_cmode = netcdf_cmode + NF90_HDF5
  1851. netcdf_cmode = netcdf_cmode + NF90_NETCDF4
  1852. else
  1853. netcdf_cmode = netcdf_cmode + NF90_CLASSIC_MODEL
  1854. end if
  1855. #else
  1856. if ( ftype == MDF_NETCDF4 ) then
  1857. write (gol,'("could not write NetCDF-4 file without `with_netcdf4` defined ...")'); call goErr
  1858. TRACEBACK; status=1; return
  1859. end if
  1860. #endif
  1861. ! create in parallel ?
  1862. if ( filep%parallel ) then
  1863. ! check ...
  1864. if ( ftype /= MDF_NETCDF4 ) then
  1865. write (gol,'("Creation of NetCDF file in parallel requires NETCDF4 file type.")'); call goErr
  1866. TRACEBACK; status=1; return
  1867. end if
  1868. #ifdef with_netcdf4_par
  1869. ! Creation mode MPIIO is needed for parallel i/o for NetCDF library 4.1 onwards.
  1870. ! But since the parameter is not available for older versions, it can not used
  1871. ! permantently to avoid errors about undevined variables.
  1872. ! Instead, the value of MPIIO is hardcoded here for a number of library versions;
  1873. ! please extend for your version if the error traceback has brought you here.
  1874. ! First get library version:
  1875. netcdf_version = trim(NF90_Inq_LibVers())
  1876. ! switch:
  1877. if ( (netcdf_version(1:5) == '4.0.1') ) then
  1878. ! no NF90_MPIIO needed for this version ...
  1879. else if ( (netcdf_version(1:5) == '4.1.1') .or. &
  1880. (netcdf_version(1:5) == '4.1.2') .or. &
  1881. (netcdf_version(1:5) == '4.1.3') .or. &
  1882. (netcdf_version(1:3) == '4.2' ) .or. &
  1883. (netcdf_version(1:3) == '4.3' ) .or. &
  1884. (netcdf_version(1:3) == '4.4') ) then
  1885. ! add value of NF90_MPIIO to creation mode:
  1886. netcdf_cmode = netcdf_cmode + 8192
  1887. !else if ( netcdf_version(1:7) == '4.x.x.x' ) then
  1888. ! ! show value ; need to uncomment the 'use' statement in the top of this routine:
  1889. ! write (gol,'("Value of NF90_MPIIO : ",i6)') NF90_MPIIO; call goErr
  1890. ! ! add value of NF90_MPIIO to creation mode:
  1891. ! netcdf_cmode = netcdf_cmode + NF90_MPIIO
  1892. else
  1893. write (gol,'("Please implement NF90_MPIIO behaviour for your NetCDF library version:")'); call goErr
  1894. write (gol,'(" ",a)') trim(netcdf_version); call goErr
  1895. TRACEBACK; status=1; return
  1896. end if
  1897. ! create file, provide communicator and info:
  1898. status = NF90_Create( trim(filep%netcdf_fname), netcdf_cmode, filep%netcdf_id, &
  1899. comm=mpi_comm, info=mpi_info )
  1900. if (status/=NF90_NOERR) then
  1901. gol = trim(NF90_StrError(status)); call goErr
  1902. write (gol,'("from creating netcdf4 file :")'); call goErr
  1903. write (gol,'(" ",a)') trim(filep%netcdf_fname); call goErr
  1904. write (gol,'(" does directory exist ?")'); call goErr
  1905. TRACEBACK; status=1; return
  1906. end if
  1907. #else
  1908. write (gol,'("Parallel creation of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr
  1909. TRACEBACK; status=1; return
  1910. #endif
  1911. else
  1912. ! create file:
  1913. status = NF90_Create( trim(filep%netcdf_fname), netcdf_cmode, filep%netcdf_id )
  1914. if (status/=NF90_NOERR) then
  1915. gol = trim(NF90_StrError(status)); call goErr
  1916. write (gol,'("from creating netcdf4 file :")'); call goErr
  1917. write (gol,'(" ",a)') trim(filep%netcdf_fname); call goErr
  1918. write (gol,'(" ",a)') netcdf_cmode; call goErr
  1919. write (gol,'(" does directory exist ?")'); call goErr
  1920. TRACEBACK; status=1; return
  1921. end if
  1922. end if
  1923. #endif
  1924. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1925. case default
  1926. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  1927. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  1928. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  1929. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  1930. TRACEBACK; status=1; return
  1931. end select
  1932. end do ! file types
  1933. ! init dimension list:
  1934. call MDF_Dim_List_Init( filep%Dim_List, status )
  1935. IF_NOT_OK_RETURN(status=1)
  1936. ! init variable list:
  1937. call MDF_Var_List_Init( filep%Var_List, status )
  1938. IF_NOT_OK_RETURN(status=1)
  1939. ! no global attributes yet:
  1940. filep%natt = 0
  1941. ! ok
  1942. status = 0
  1943. end subroutine MDF_Create_more
  1944. ! ***
  1945. subroutine MDF_Open( filename, ftype, mode, hid, status, &
  1946. mpi_comm, mpi_info )
  1947. #ifdef with_hdf5_beta
  1948. use HDF5, only : SIZE_T, HSIZE_T
  1949. use HDF5, only : H5FOpen_f
  1950. use HDF5, only : H5F_ACC_RDONLY_F
  1951. use HDF5, only : H5AGet_Num_Attrs_f
  1952. use HDF5, only : H5GOpen_f, H5GClose_f, H5GN_Members_f, H5GGet_Obj_Info_Idx_f
  1953. use HDF5, only : H5G_DATASET_F, H5G_LINK_F, H5G_GROUP_F, H5G_TYPE_F
  1954. use HDF5, only : H5DOpen_f, H5DGet_Type_f, H5DGet_Space_f
  1955. use HDF5, only : H5TClose_f
  1956. use HDF5, only : H5SClose_f, H5SGet_Simple_Extent_Dims_f
  1957. use HDF5, only : H5S_UNLIMITED_F
  1958. #endif
  1959. #ifdef with_netcdf
  1960. use NetCDF, only : NF90_WRITE, NF90_NOWRITE
  1961. use NetCDF, only : NF90_Open
  1962. use NetCDF, only : NF90_Inquire
  1963. use NetCDF, only : NF90_Inquire_Dimension
  1964. use NetCDF, only : NF90_Inquire_Variable
  1965. use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE
  1966. #ifdef with_netcdf4_par
  1967. use NetCDF, only : NF90_Open_Par,NF90_Inq_LibVers
  1968. ! This parameter does not exist for library versions prior to 4.1 ;
  1969. ! Uncomment only to get its value in your version so you can hardcode it.
  1970. ! The correct creation mode for parallel i/o :
  1971. !use NetCDF, only : NF90_MPIIO
  1972. #endif
  1973. #endif
  1974. ! --- in/out -------------------------------------
  1975. character(len=*), intent(in) :: filename
  1976. integer, intent(in) :: ftype
  1977. integer, intent(in) :: mode
  1978. integer, intent(out) :: hid
  1979. integer, intent(out) :: status
  1980. integer, intent(in), optional :: mpi_comm
  1981. integer, intent(in), optional :: mpi_info
  1982. ! --- const --------------------------------------
  1983. character(len=*), parameter :: rname = mname//'/MDF_Open'
  1984. ! --- external ----------------------------
  1985. #ifdef with_hdf4
  1986. integer(hdf4_wpi), external :: sfStart
  1987. integer(hdf4_wpi), external :: sfFInfo
  1988. integer(hdf4_wpi), external :: sfGInfo
  1989. integer(hdf4_wpi), external :: sfGDInfo
  1990. integer(hdf4_wpi), external :: sfSelect
  1991. integer(hdf4_wpi), external :: sfDimID
  1992. #endif
  1993. ! --- local --------------------------------------
  1994. type(MDF_File), pointer :: filep
  1995. type(MDF_Dim), pointer :: dimp
  1996. type(MDF_Var), pointer :: varp
  1997. logical :: exist
  1998. #ifdef with_hdf4
  1999. integer :: hdf4_amode
  2000. integer :: hdf4_varind
  2001. integer :: hdf4_xtype
  2002. integer :: hdf4_dimind
  2003. integer :: hdf4_dimid
  2004. #endif
  2005. #ifdef with_hdf5_beta
  2006. integer :: hdf5_amode
  2007. integer(HID_T) :: hdf5_grp_id
  2008. character(len=LEN_NAME) :: hdf5_obj_name
  2009. integer :: hdf5_obj_type
  2010. integer(HID_T) :: hdf5_type_id
  2011. integer(HID_T) :: hdf5_space_id
  2012. character(len=6) :: snr
  2013. #endif
  2014. #ifdef with_netcdf
  2015. integer :: netcdf_mode
  2016. integer :: netcdf_xtype
  2017. integer :: unlimid
  2018. #endif
  2019. integer :: ndim, idim, dimid
  2020. integer :: nvar, ivar, varid
  2021. integer :: natt
  2022. character(len=LEN_NAME) :: name
  2023. integer :: length
  2024. integer :: dimids(MAX_RANK)
  2025. integer :: shp(MAX_RANK)
  2026. integer :: k, n
  2027. character(len=80) :: netcdf_version
  2028. ! --- begin --------------------------------------
  2029. ! new file:
  2030. call MDF_File_List_New_Item( File_List, hid, status )
  2031. IF_NOT_OK_RETURN(status=1)
  2032. ! pointer to file structure:
  2033. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  2034. IF_NOT_OK_RETURN(status=1)
  2035. ! init dimension list:
  2036. call MDF_Dim_List_Init( filep%Dim_List, status )
  2037. IF_NOT_OK_RETURN(status=1)
  2038. ! init variable list:
  2039. call MDF_Var_List_Init( filep%Var_List, status )
  2040. IF_NOT_OK_RETURN(status=1)
  2041. ! store filename stuff:
  2042. filep%filename = trim(filename)
  2043. ! store dummy creation mode:
  2044. filep%cmode = -1
  2045. ! parallel i/o ?
  2046. filep%parallel = present(mpi_comm) .or. present(mpi_info)
  2047. ! check ...
  2048. if ( filep%parallel ) then
  2049. if ( .not. all((/present(mpi_comm),present(mpi_info)/)) ) then
  2050. write (gol,'("Only one of the arguments `mpi_comm` or `mpi_info` provided, that is not enough!")'); call goErr
  2051. TRACEBACK; status=1; return
  2052. end if
  2053. end if
  2054. ! store file type:
  2055. filep%nftype = 1
  2056. filep%ftypes(1) = ftype
  2057. ! select appropriate routine for each type:
  2058. select case ( ftype )
  2059. #ifdef with_hdf4
  2060. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2061. case ( MDF_HDF4 )
  2062. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2063. ! check ...
  2064. if ( filep%parallel ) then
  2065. write (gol,'("HDF4 files could not be opened in parallel")'); call goErr
  2066. TRACEBACK; status=1; return
  2067. end if
  2068. ! full file name:
  2069. filep%hdf4_fname = trim(filep%filename)
  2070. ! check ...
  2071. inquire( file=trim(filep%hdf4_fname), exist=exist )
  2072. if ( .not. exist ) then
  2073. write (gol,'("file to be opened not found : ",a)') trim(filep%hdf4_fname); call goErr
  2074. TRACEBACK; status=1; return
  2075. end if
  2076. ! set access mode:
  2077. select case ( mode )
  2078. case ( MDF_READ )
  2079. hdf4_amode = DFACC_READ
  2080. case ( MDF_WRITE )
  2081. hdf4_amode = DFACC_WRITE
  2082. case default
  2083. write (gol,'("unsupported open mode : ",i6)') mode; call goErr
  2084. TRACEBACK; status=1; return
  2085. end select
  2086. ! open file:
  2087. filep%hdf4_id = sfStart( trim(filep%hdf4_fname), hdf4_amode )
  2088. if ( filep%hdf4_id == FAIL ) then
  2089. write (gol,'("from starting access to hdf file:")'); call goErr
  2090. write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr
  2091. write (gol,'(" access mode : CREATE")'); call goErr
  2092. TRACEBACK; status=1; return
  2093. end if
  2094. ! get number of data sets and number of global attributes:
  2095. status = sfFInfo( filep%hdf4_id, nvar, filep%natt )
  2096. if ( status == FAIL ) then
  2097. write (gol,'("from sfFInfo :")'); call goErr
  2098. write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr
  2099. TRACEBACK; status=1; return
  2100. end if
  2101. ! loop over variables:
  2102. do ivar = 1, nvar
  2103. ! new variable:
  2104. call MDF_Var_List_New_Item( filep%Var_List, varid, status )
  2105. IF_NOT_OK_RETURN(status=1)
  2106. ! pointer to variable structure:
  2107. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  2108. IF_NOT_OK_RETURN(status=1)
  2109. ! hdf variable index in 0,..,nvar-1
  2110. hdf4_varind = ivar - 1
  2111. ! get variable id:
  2112. varp%hdf4_sdid = sfSelect( filep%hdf4_id, hdf4_varind )
  2113. if ( varp%hdf4_sdid == FAIL ) then
  2114. write (gol,'("unable to locate data set with index ",i6)') hdf4_varind; call goErr
  2115. write (gol,'(" hdf file name : ",a)') trim(filep%hdf4_fname); call goErr
  2116. TRACEBACK; status=1; return
  2117. end if
  2118. ! get info:
  2119. status = sfGInfo( varp%hdf4_sdid, name, ndim, shp, varp%hdf4_xtype, varp%natt )
  2120. if ( status /= SUCCEED ) then
  2121. write (gol,'("getting info")'); call goErr
  2122. TRACEBACK; status=1; return
  2123. end if
  2124. ! store name:
  2125. varp%name = trim(name)
  2126. ! convert type:
  2127. select case ( varp%hdf4_xtype )
  2128. case ( DFNT_CHAR ) ; varp%xtype = MDF_CHAR
  2129. case ( DFNT_INT8 ) ; varp%xtype = MDF_BYTE
  2130. case ( DFNT_INT16 ) ; varp%xtype = MDF_SHORT
  2131. case ( DFNT_INT32 ) ; varp%xtype = MDF_INT
  2132. case ( DFNT_FLOAT32 ) ; varp%xtype = MDF_FLOAT
  2133. case ( DFNT_FLOAT64 ) ; varp%xtype = MDF_DOUBLE
  2134. case default
  2135. write (gol,'("unsupported data type : ",i6)') varp%hdf4_xtype; call goErr
  2136. TRACEBACK; status=1; return
  2137. end select
  2138. ! set kind given type:
  2139. call MDF_Get_Kind( varp%xtype, varp%xkind, status )
  2140. IF_NOT_OK_RETURN(status=1)
  2141. ! store number of dimensions:
  2142. varp%ndim = ndim
  2143. ! init arrays:
  2144. varp%dimids = -1
  2145. varp%shp = -1
  2146. ! loop over dimensions:
  2147. do idim = 1, ndim
  2148. ! hdf4 dimension index in 0,..,ndim-1
  2149. hdf4_dimind = idim - 1
  2150. ! get hdf4 dimension id:
  2151. hdf4_dimid = sfDimID( varp%hdf4_sdid, hdf4_dimind )
  2152. if ( hdf4_dimid == FAIL ) then
  2153. write (gol,'("error selecting dimension id :")'); call goErr
  2154. write (gol,'(" index : ",i6)') hdf4_dimind; call goErr
  2155. write (gol,'(" variable name : ",a)') trim(varp%name); call goErr
  2156. write (gol,'(" hdf name : ",a)') trim(filep%hdf4_fname); call goErr
  2157. TRACEBACK; status=1; return
  2158. end if
  2159. ! extract dimension info;
  2160. ! data type is only usefull if a 'scale' is assigned to the dimension
  2161. ! length might be SD_UNLIMITED, so use shp from sfGInfo for actual length
  2162. status = sfGDInfo( hdf4_dimid, name, length, hdf4_xtype, natt )
  2163. if ( hdf4_dimid == FAIL ) then
  2164. write (gol,'("error getting dimension info :")'); call goErr
  2165. write (gol,'(" index : ",i6)') hdf4_dimind; call goErr
  2166. write (gol,'(" variable name : ",a)') trim(varp%name); call goErr
  2167. write (gol,'(" hdf name : ",a)') trim(filep%hdf4_fname); call goErr
  2168. TRACEBACK; status=1; return
  2169. end if
  2170. ! check if dimension is already defined ...;
  2171. ! current number of defined dimensions:
  2172. call MDF_Dim_List_Inquire( filep%Dim_List, status, n=n )
  2173. IF_NOT_OK_RETURN(status=1)
  2174. ! loop over current dimensions:
  2175. dimid = -1
  2176. do k = 1, n
  2177. ! pointer to dimension structure:
  2178. call MDF_Dim_List_Get_Pointer( filep%Dim_List, k, dimp, status )
  2179. IF_NOT_OK_RETURN(status=1)
  2180. ! compare:
  2181. if ( trim(dimp%name) == trim(name) ) then
  2182. ! check ...
  2183. if ( dimp%length /= shp(idim) ) then
  2184. write (gol,'("length of dimension is different from previous defined length:")'); call goErr
  2185. write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr
  2186. write (gol,'(" variable name : ",a)') trim(varp%name); call goErr
  2187. write (gol,'(" dimension name : ",a)') trim(name); call goErr
  2188. write (gol,'(" length : ",i6)') shp(idim); call goErr
  2189. write (gol,'(" defined length : ",i6)') dimp%length; call goErr
  2190. TRACEBACK; status=1; return
  2191. end if
  2192. ! ok; stop searching:
  2193. dimid = k
  2194. exit
  2195. end if
  2196. end do
  2197. ! not found ? then new dimension should be defined:
  2198. if ( dimid < 0 ) then
  2199. ! new dimension:
  2200. call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status )
  2201. IF_NOT_OK_RETURN(status=1)
  2202. ! pointer to dimension structure:
  2203. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  2204. IF_NOT_OK_RETURN(status=1)
  2205. ! fill mdf dimension info:
  2206. dimp%named = name(1:7) /= 'fakeDim'
  2207. dimp%name = trim(name)
  2208. dimp%unlimited = length == SD_UNLIMITED
  2209. dimp%length = shp(idim) ! shp extraced via sfGInfo
  2210. end if
  2211. ! fill variable dimension info:
  2212. varp%dimids(idim) = dimid
  2213. varp%shp (idim) = dimp%length
  2214. end do ! dimensions
  2215. end do ! variables
  2216. #endif
  2217. #ifdef with_hdf5_beta
  2218. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2219. case ( MDF_HDF5 )
  2220. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2221. ! check ...
  2222. if ( filep%parallel ) then
  2223. write (gol,'("MDF/HDF5 not implemented for parallel open yet")'); call goErr
  2224. TRACEBACK; status=1; return
  2225. end if
  2226. ! full file name:
  2227. filep%hdf5_fname = trim(filep%filename)
  2228. ! check ...
  2229. inquire( file=trim(filep%hdf5_fname), exist=exist )
  2230. if ( .not. exist ) then
  2231. write (gol,'("file to be opened not found : ",a)') trim(filep%hdf5_fname); call goErr
  2232. TRACEBACK; status=1; return
  2233. end if
  2234. ! set access mode:
  2235. select case ( mode )
  2236. case ( MDF_READ )
  2237. hdf5_amode = H5F_ACC_RDONLY_F ! read-only
  2238. case default
  2239. write (gol,'("unsupported open mode : ",i6)') mode; call goErr
  2240. TRACEBACK; status=1; return
  2241. end select
  2242. ! open file:
  2243. call H5FOpen_f( trim(filep%hdf5_fname), hdf5_amode, filep%hdf5_file_id, status )
  2244. IF_NOT_OK_RETURN(status=1)
  2245. ! get number of global attributes:
  2246. call H5AGet_Num_Attrs_f( filep%hdf5_file_id, filep%natt, status )
  2247. IF_NOT_OK_RETURN(status=1)
  2248. ! open group:
  2249. call H5GOpen_f( filep%hdf5_file_id, '/', hdf5_grp_id, status )
  2250. IF_NOT_OK_RETURN(status=1)
  2251. ! get number of members:
  2252. call H5GN_Members_f( hdf5_grp_id, '.', nvar, status )
  2253. IF_NOT_OK_RETURN(status=1)
  2254. ! loop over group members:
  2255. do ivar = 1, nvar
  2256. ! get group info:
  2257. call H5GGet_Obj_Info_Idx_f( hdf5_grp_id, '.', ivar-1, hdf5_obj_name, hdf5_obj_type, status )
  2258. IF_NOT_OK_RETURN(status=1)
  2259. ! what ?
  2260. if ( hdf5_obj_type == H5G_DATASET_F ) then
  2261. ! new variable:
  2262. call MDF_Var_List_New_Item( filep%Var_List, varid, status )
  2263. IF_NOT_OK_RETURN(status=1)
  2264. ! pointer to variable structure:
  2265. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  2266. IF_NOT_OK_RETURN(status=1)
  2267. ! store full hdf5 name:
  2268. varp%hdf5_name = trim(hdf5_obj_name)
  2269. ! store variable name:
  2270. varp%name = trim(hdf5_obj_name)
  2271. ! open data set:
  2272. call H5DOpen_f( hdf5_grp_id, trim(hdf5_obj_name), varp%hdf5_dataset_id, status )
  2273. IF_NOT_OK_RETURN(status=1)
  2274. ! get type id:
  2275. call H5DGet_Type_f( varp%hdf5_dataset_id, hdf5_type_id, status )
  2276. IF_NOT_OK_RETURN(status=1)
  2277. ! convert to mdf type code:
  2278. call HDF5_Get_MDF_Type( hdf5_type_id, varp%xtype, status )
  2279. IF_NOT_OK_RETURN(status=1)
  2280. ! release:
  2281. call H5TClose_f( hdf5_type_id, status )
  2282. IF_NOT_OK_RETURN(status=1)
  2283. ! get data space id:
  2284. call H5DGet_Space_f( varp%hdf5_dataset_id, hdf5_space_id, status )
  2285. IF_NOT_OK_RETURN(status=1)
  2286. ! get dimensions:
  2287. call H5SGet_Simple_Extent_Dims_f( hdf5_space_id, varp%hdf5_dims, varp%hdf5_maxdims, status )
  2288. if ( status < 0 ) then
  2289. ! something went wrong ...
  2290. write (gol,'("could not extract dimensions for attribute : ",a)') trim(name); call goErr
  2291. TRACEBACK; status=1; return
  2292. else
  2293. ! number of dimensions:
  2294. ndim = status
  2295. end if
  2296. ! store number of dimensions in variable structure:
  2297. varp%ndim = status
  2298. ! init arrays:
  2299. varp%dimids = -1
  2300. varp%shp = -1
  2301. ! loop over dimensions:
  2302. do idim = 1, ndim
  2303. ! current length:
  2304. length = varp%hdf5_dims(idim)
  2305. ! new dimension:
  2306. call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status )
  2307. IF_NOT_OK_RETURN(status=1)
  2308. ! pointer to dimension structure:
  2309. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  2310. IF_NOT_OK_RETURN(status=1)
  2311. ! store current length:
  2312. dimp%length = length
  2313. ! unlimitted ?
  2314. dimp%unlimited = varp%hdf5_maxdims(idim) == H5S_UNLIMITED_F
  2315. ! dummy name ...
  2316. dimp%named = .false.
  2317. write (snr,'(i6)') length
  2318. dimp%name = 'fakeDime'//adjustl(snr)
  2319. ! fill variable dimension info:
  2320. varp%dimids(idim) = dimid
  2321. varp%shp (idim) = dimp%length
  2322. end do ! dimensions
  2323. ! release:
  2324. call H5SClose_f( hdf5_space_id, status )
  2325. IF_NOT_OK_RETURN(status=1)
  2326. ! get number of global attributes:
  2327. call H5AGet_Num_Attrs_f( varp%hdf5_dataset_id, varp%natt, status )
  2328. IF_NOT_OK_RETURN(status=1)
  2329. else if ( hdf5_obj_type == H5G_LINK_F ) then
  2330. write (gol,'("WARNING - HDF5 links not supported yet: ",a)') trim(hdf5_obj_name); call goPr
  2331. else if ( hdf5_obj_type == H5G_GROUP_F ) then
  2332. write (gol,'("WARNING - HDF5 groups not supported yet: ",a)') trim(hdf5_obj_name); call goPr
  2333. else if ( hdf5_obj_type == H5G_TYPE_F ) then
  2334. write (gol,'("WARNING - HDF5 types not supported yet: ",a)') trim(hdf5_obj_name); call goPr
  2335. else
  2336. write (gol,'("unsupported hdf5_obj_type ",i6)') hdf5_obj_type; call goErr
  2337. TRACEBACK; status=1; return
  2338. end if
  2339. end do ! group members
  2340. ! release group:
  2341. call H5GClose_f( hdf5_grp_id, status )
  2342. IF_NOT_OK_RETURN(status=1)
  2343. #endif
  2344. #ifdef with_netcdf
  2345. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2346. case ( MDF_NETCDF, MDF_NETCDF4 )
  2347. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2348. ! full file name:
  2349. filep%netcdf_fname = trim(filep%filename)
  2350. ! check ...
  2351. inquire( file=trim(filep%netcdf_fname), exist=exist )
  2352. if ( .not. exist ) then
  2353. write (gol,'("file to be opened not found : ",a)') trim(filep%netcdf_fname); call goErr
  2354. TRACEBACK; status=1; return
  2355. end if
  2356. ! set open mode:
  2357. select case ( mode )
  2358. case ( MDF_READ )
  2359. netcdf_mode = NF90_NOWRITE
  2360. case ( MDF_WRITE )
  2361. netcdf_mode = NF90_WRITE
  2362. case default
  2363. write (gol,'("unsupported creation mode : ",i6)') mode; call goErr
  2364. TRACEBACK; status=1; return
  2365. end select
  2366. ! open in parallel ?
  2367. if ( filep%parallel ) then
  2368. ! open file in parallel:
  2369. #ifdef with_netcdf4_par
  2370. ! Creation mode MPIIO is needed for parallel i/o for NetCDF library 4.1 onwards.
  2371. ! But since the parameter is not available for older versions, it can not used
  2372. ! permantently to avoid errors about undefined variables.
  2373. ! Instead, the value of MPIIO is hardcoded here for a number of library versions;
  2374. ! please extend for your version if the error traceback has brought you here.
  2375. ! First get library version:
  2376. netcdf_version = trim(NF90_Inq_LibVers())
  2377. ! switch:
  2378. if ( (netcdf_version(1:5) == '4.0.1') ) then
  2379. ! no NF90_MPIIO needed for this version ...
  2380. else if ( (netcdf_version(1:5) == '4.1.1') .or. &
  2381. (netcdf_version(1:5) == '4.1.2') .or. &
  2382. (netcdf_version(1:5) == '4.1.3') .or. &
  2383. (netcdf_version(1:3) == '4.2') .or. &
  2384. (netcdf_version(1:3) == '4.3') .or. &
  2385. (netcdf_version(1:3) == '4.4') ) then
  2386. ! add value of NF90_MPIIO to creation mode:
  2387. netcdf_mode = netcdf_mode + 8192
  2388. !else if ( netcdf_version(1:y) == '4.x.x.x' ) then
  2389. ! ! show value ; need to uncomment the 'use' statement in the top of this routine:
  2390. ! write (gol,'("Value of NF90_MPIIO : ",i6)') NF90_MPIIO; call goErr
  2391. ! ! add value of NF90_MPIIO to creation mode:
  2392. ! netcdf_mode = netcdf_mode + 0
  2393. else
  2394. write (gol,'("Please implement NF90_MPIIO behaviour for your NetCDF library version:")'); call goErr
  2395. write (gol,'(" ",a)') trim(netcdf_version); call goErr
  2396. TRACEBACK; status=1; return
  2397. end if
  2398. status = NF90_Open_Par( trim(filep%netcdf_fname), netcdf_mode, &
  2399. mpi_comm, mpi_info, filep%netcdf_id )
  2400. IF_NF90_NOT_OK_RETURN(status=1)
  2401. #else
  2402. write (gol,'("Parallel open of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr
  2403. TRACEBACK; status=1; return
  2404. #endif
  2405. else
  2406. ! open file:
  2407. status = NF90_Open( trim(filep%netcdf_fname), netcdf_mode, filep%netcdf_id )
  2408. IF_NF90_NOT_OK_RETURN(status=1)
  2409. end if
  2410. ! get number of global attributes:
  2411. status = NF90_Inquire( filep%netcdf_id, nAttributes=filep%natt )
  2412. IF_NF90_NOT_OK_RETURN(status=1)
  2413. ! get number of dimensions and (dummy) id of unlimitted dimension:
  2414. status = NF90_Inquire( filep%netcdf_id, nDimensions=ndim, unlimitedDimID=unlimid )
  2415. IF_NF90_NOT_OK_RETURN(status=1)
  2416. ! loop over dimensions:
  2417. do idim = 1, ndim
  2418. ! new dimension:
  2419. call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status )
  2420. IF_NOT_OK_RETURN(status=1)
  2421. ! pointer to dimension structure:
  2422. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  2423. IF_NOT_OK_RETURN(status=1)
  2424. ! netcdf dimension id is number from 1..ndim
  2425. dimp%netcdf_dimid = idim
  2426. ! get info:
  2427. status = NF90_Inquire_Dimension( filep%netcdf_id, dimp%netcdf_dimid, &
  2428. name=name, len=length )
  2429. IF_NF90_NOT_OK_RETURN(status=1)
  2430. ! store:
  2431. dimp%named = .true.
  2432. dimp%name = trim(name)
  2433. dimp%length = length
  2434. dimp%unlimited = dimp%netcdf_dimid == unlimid
  2435. end do
  2436. ! get number of variables:
  2437. status = NF90_Inquire( filep%netcdf_id, nVariables=nvar )
  2438. IF_NF90_NOT_OK_RETURN(status=1)
  2439. ! loop over variables:
  2440. do ivar = 1, nvar
  2441. ! new variable:
  2442. call MDF_Var_List_New_Item( filep%Var_List, varid, status )
  2443. IF_NOT_OK_RETURN(status=1)
  2444. ! pointer to variable structure:
  2445. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  2446. IF_NOT_OK_RETURN(status=1)
  2447. ! netcdf variable id is number from 1..nvar
  2448. varp%netcdf_varid = ivar
  2449. ! get info:
  2450. status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, &
  2451. name=name, xtype=netcdf_xtype, ndims=ndim )
  2452. IF_NF90_NOT_OK_RETURN(status=1)
  2453. ! store name:
  2454. varp%name = trim(name)
  2455. ! convert type:
  2456. select case ( netcdf_xtype )
  2457. case ( NF90_CHAR ) ; varp%xtype = MDF_CHAR
  2458. case ( NF90_BYTE ) ; varp%xtype = MDF_BYTE
  2459. case ( NF90_SHORT ) ; varp%xtype = MDF_SHORT
  2460. case ( NF90_INT ) ; varp%xtype = MDF_INT
  2461. case ( NF90_FLOAT ) ; varp%xtype = MDF_FLOAT
  2462. case ( NF90_DOUBLE ) ; varp%xtype = MDF_DOUBLE
  2463. case default
  2464. write (gol,'("unsupported data type : ",i6)') netcdf_xtype; call goErr
  2465. TRACEBACK; status=1; return
  2466. end select
  2467. ! set kind given type:
  2468. call MDF_Get_Kind( varp%xtype, varp%xkind, status )
  2469. IF_NOT_OK_RETURN(status=1)
  2470. ! store number of dimensions:
  2471. varp%ndim = ndim
  2472. ! get netcdf dimension id's now that number is known:
  2473. status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, dimids=dimids(1:ndim) )
  2474. IF_NF90_NOT_OK_RETURN(status=1)
  2475. ! init arrays:
  2476. varp%dimids = -1
  2477. varp%shp = -1
  2478. ! loop over dimensions:
  2479. do idim = 1, ndim
  2480. ! mdf dimension id is the same as the netcdf dimension id,
  2481. ! both are numbers 1,..,maxdim :
  2482. dimid = dimids(idim)
  2483. ! pointer to dimension structure:
  2484. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  2485. IF_NOT_OK_RETURN(status=1)
  2486. ! store:
  2487. varp%dimids(idim) = dimid
  2488. varp%shp (idim) = dimp%length
  2489. end do
  2490. ! get number of variable attributes:
  2491. status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, nAtts=varp%natt )
  2492. IF_NF90_NOT_OK_RETURN(status=1)
  2493. end do ! variables
  2494. #endif
  2495. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2496. case default
  2497. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2498. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  2499. if ((ftype>=1).and.(ftype<=MDF_FILETYPE_MAX)) then
  2500. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  2501. end if
  2502. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  2503. TRACEBACK; status=1; return
  2504. end select
  2505. ! ok
  2506. status = 0
  2507. end subroutine MDF_Open
  2508. ! ***
  2509. subroutine MDF_Close( hid, status )
  2510. #ifdef with_hdf5_beta
  2511. use HDF5, only : H5FClose_f
  2512. use HDF5, only : H5DClose_f
  2513. #endif
  2514. #ifdef with_netcdf
  2515. use NetCDF, only : NF90_Close
  2516. #endif
  2517. ! --- in/out -------------------------------------
  2518. integer, intent(inout) :: hid
  2519. integer, intent(out) :: status
  2520. ! --- const --------------------------------------
  2521. character(len=*), parameter :: rname = mname//'/MDF_Close'
  2522. ! --- external ----------------------------
  2523. #ifdef with_hdf4
  2524. integer(hdf4_wpi), external :: sfEnd
  2525. #endif
  2526. ! --- local --------------------------------------
  2527. type(MDF_File), pointer :: filep
  2528. integer :: iftype
  2529. integer :: ftype
  2530. integer :: ivar, nvar
  2531. type(MDF_Var), pointer :: varp
  2532. ! --- begin --------------------------------------
  2533. ! pointer to file structure:
  2534. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  2535. IF_NOT_OK_RETURN(status=1)
  2536. ! loop over file types:
  2537. do iftype = 1, filep%nftype
  2538. ! current type:
  2539. ftype = filep%ftypes(iftype)
  2540. ! select appropriate routine for each type:
  2541. select case ( ftype )
  2542. #ifdef with_hdf4
  2543. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2544. case ( MDF_HDF4 )
  2545. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2546. ! close file:
  2547. status = sfEnd( filep%hdf4_id )
  2548. if ( status == FAIL ) then
  2549. write (gol,'("while closing HDF4 file:")'); call goErr
  2550. write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr
  2551. TRACEBACK; status=1; return
  2552. end if
  2553. #endif
  2554. #ifdef with_hdf5_beta
  2555. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2556. case ( MDF_HDF5 )
  2557. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2558. ! get number of elements in variable list:
  2559. call MDF_Var_List_Inquire( filep%Var_List, status, n=nvar )
  2560. IF_NOT_OK_RETURN(status=1)
  2561. ! list variables ?
  2562. if ( nvar > 0 ) then
  2563. ! loop over variables:
  2564. do ivar = 1, nvar
  2565. ! pointer to variable structure:
  2566. call MDF_Var_List_Get_Pointer( filep%Var_List, ivar, varp, status )
  2567. IF_NOT_OK_RETURN(status=1)
  2568. ! close data set:
  2569. call H5DClose_f( varp%hdf5_dataset_id, status )
  2570. IF_NOT_OK_RETURN(status=1)
  2571. end do ! variables
  2572. end if ! nvar > 0
  2573. ! close file:
  2574. call H5FClose_f( filep%hdf5_file_id, status )
  2575. if ( status /= 0 ) then
  2576. write (gol,'("while closing HDF5 file:")'); call goErr
  2577. write (gol,'(" file name : ",a)') trim(filep%hdf5_fname); call goErr
  2578. TRACEBACK; status=1; return
  2579. end if
  2580. #endif
  2581. #ifdef with_netcdf
  2582. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2583. case ( MDF_NETCDF, MDF_NETCDF4 )
  2584. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2585. ! close file:
  2586. status = NF90_Close( filep%netcdf_id )
  2587. if ( status /= NF90_NOERR ) then
  2588. write (gol,'("while closing NetCDF4 file:")'); call goErr
  2589. write (gol,'(" file name : ",a)') trim(filep%netcdf_fname); call goErr
  2590. TRACEBACK; status=1; return
  2591. end if
  2592. #endif
  2593. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2594. case default
  2595. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2596. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  2597. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  2598. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  2599. TRACEBACK; status=1; return
  2600. end select
  2601. end do ! file types
  2602. ! done with variable list:
  2603. call MDF_Var_List_Done( filep%Var_List, status )
  2604. IF_NOT_OK_RETURN(status=1)
  2605. ! done with dimension list:
  2606. call MDF_Dim_List_Done( filep%Dim_List, status )
  2607. IF_NOT_OK_RETURN(status=1)
  2608. ! remove item:
  2609. call MDF_File_List_Clear_Item( File_List, hid, status )
  2610. IF_NOT_OK_RETURN(status=1)
  2611. ! ok
  2612. status = 0
  2613. end subroutine MDF_Close
  2614. ! ********************************************************************
  2615. ! ***
  2616. ! *** end of definition phase
  2617. ! ***
  2618. ! ********************************************************************
  2619. subroutine MDF_EndDef( hid, status )
  2620. #ifdef with_netcdf
  2621. use NetCDF, only : NF90_EndDef
  2622. #endif
  2623. ! --- in/out -------------------------------------
  2624. integer, intent(in) :: hid
  2625. integer, intent(out) :: status
  2626. ! --- const --------------------------------------
  2627. character(len=*), parameter :: rname = mname//'/MDF_EndDef'
  2628. ! --- local --------------------------------------
  2629. type(MDF_File), pointer :: filep
  2630. integer :: iftype
  2631. integer :: ftype
  2632. ! --- begin --------------------------------------
  2633. ! pointer to file structure:
  2634. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  2635. IF_NOT_OK_RETURN(status=1)
  2636. ! loop over file types:
  2637. do iftype = 1, filep%nftype
  2638. ! current type:
  2639. ftype = filep%ftypes(iftype)
  2640. ! select appropriate routine for each type:
  2641. select case ( ftype )
  2642. #ifdef with_hdf4
  2643. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2644. case ( MDF_HDF4 )
  2645. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2646. ! nothing required for this format ...
  2647. #endif
  2648. #ifdef with_hdf5_beta
  2649. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2650. case ( MDF_HDF5 )
  2651. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2652. ! nothing required for this format ...
  2653. #endif
  2654. #ifdef with_netcdf
  2655. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2656. case ( MDF_NETCDF, MDF_NETCDF4 )
  2657. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2658. ! end of definition phase:
  2659. status = NF90_EndDef( filep%netcdf_id )
  2660. IF_NF90_NOT_OK_RETURN(status=1)
  2661. #endif
  2662. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2663. case default
  2664. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2665. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  2666. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  2667. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  2668. TRACEBACK; status=1; return
  2669. end select
  2670. end do ! file types
  2671. ! ok
  2672. status = 0
  2673. end subroutine MDF_EndDef
  2674. ! ********************************************************************
  2675. ! ***
  2676. ! *** dimensions
  2677. ! ***
  2678. ! ********************************************************************
  2679. subroutine MDF_Def_Dim( hid, name, length, dimid, status )
  2680. #ifdef with_netcdf
  2681. use NetCDF, only : NF90_Def_Dim, NF90_UNLIMITED
  2682. #endif
  2683. ! --- in/out -------------------------------------
  2684. integer, intent(in) :: hid
  2685. character(len=*), intent(in) :: name
  2686. integer, intent(in) :: length
  2687. integer, intent(out) :: dimid
  2688. integer, intent(out) :: status
  2689. ! --- const --------------------------------------
  2690. character(len=*), parameter :: rname = mname//'/MDF_Def_Dim'
  2691. ! --- local --------------------------------------
  2692. type(MDF_File), pointer :: filep
  2693. type(MDF_Dim), pointer :: dimp
  2694. integer :: iftype
  2695. integer :: ftype
  2696. #ifdef with_netcdf
  2697. integer :: netcdf_length
  2698. #endif
  2699. ! --- begin --------------------------------------
  2700. ! pointer to file structure:
  2701. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  2702. IF_NOT_OK_RETURN(status=1)
  2703. ! new dimension:
  2704. call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status )
  2705. IF_NOT_OK_RETURN(status=1)
  2706. ! pointer to dimension structure:
  2707. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  2708. IF_NOT_OK_RETURN(status=1)
  2709. ! store:
  2710. dimp%name = trim(name)
  2711. dimp%length = length
  2712. ! unlimited length ?
  2713. dimp%unlimited = length == MDF_UNLIMITED
  2714. ! loop over file types:
  2715. do iftype = 1, filep%nftype
  2716. ! current type:
  2717. ftype = filep%ftypes(iftype)
  2718. ! select appropriate routine for each type:
  2719. select case ( ftype )
  2720. #ifdef with_hdf4
  2721. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2722. case ( MDF_HDF4 )
  2723. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2724. ! Dimensions in HDF4 are no special entities in the file,
  2725. ! but part of each variable .
  2726. ! The arguments stored in the dimension structure will
  2727. ! be used to define the shape of new variables.
  2728. #endif
  2729. #ifdef with_hdf5_beta
  2730. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2731. case ( MDF_HDF5 )
  2732. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2733. ! Dimensions in HDF5 are no special entities in the file,
  2734. ! but stored in the 'data space' part of each variable .
  2735. ! The arguments stored in the dimension structure will
  2736. ! be used to define the shape of new variables.
  2737. #endif
  2738. #ifdef with_netcdf
  2739. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2740. case ( MDF_NETCDF, MDF_NETCDF4 )
  2741. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2742. ! set dimension length:
  2743. if ( dimp%unlimited ) then
  2744. netcdf_length = NF90_UNLIMITED
  2745. else
  2746. netcdf_length = length
  2747. end if
  2748. ! define dimension:
  2749. status = NF90_Def_Dim( filep%netcdf_id, trim(name), netcdf_length, dimp%netcdf_dimid )
  2750. IF_NF90_NOT_OK_RETURN(status=1)
  2751. #endif
  2752. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2753. case default
  2754. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2755. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  2756. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  2757. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  2758. TRACEBACK; status=1; return
  2759. end select
  2760. end do ! file types
  2761. ! ok
  2762. status = 0
  2763. end subroutine MDF_Def_Dim
  2764. ! ********************************************************************
  2765. ! ***
  2766. ! *** variables
  2767. ! ***
  2768. ! ********************************************************************
  2769. subroutine MDF_Def_Var( hid, name, xtype, dimids, varid, status, &
  2770. compression, deflate_level )
  2771. #ifdef with_hdf5_beta
  2772. use HDF5, only : HID_T, HSIZE_T
  2773. use HDF5, only : H5TCopy_f, H5TClose_f!, H5TSet_Size_f
  2774. use HDF5, only : H5T_NATIVE_CHARACTER
  2775. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  2776. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  2777. use HDF5, only : H5SCreate_Simple_f, H5SClose_f
  2778. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_UNLIMITED_F
  2779. use HDF5, only : H5PCreate_f, H5PClose_f, H5P_DATASET_CREATE_F
  2780. use HDF5, only : H5PSet_Chunk_f, H5PSet_Deflate_f
  2781. use HDF5, only : H5DCreate_f
  2782. #endif
  2783. #ifdef with_netcdf
  2784. use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE
  2785. use NetCDF, only : NF90_Def_Var
  2786. #ifdef with_netcdf4
  2787. use NetCDF, only : NF90_Def_Var_Deflate
  2788. #endif
  2789. #endif
  2790. ! --- in/out -------------------------------------
  2791. integer, intent(in) :: hid
  2792. character(len=*), intent(in) :: name
  2793. integer, intent(in) :: xtype
  2794. integer, intent(in) :: dimids(:)
  2795. integer, intent(out) :: varid
  2796. integer, intent(out) :: status
  2797. integer, intent(in), optional :: compression
  2798. integer, intent(in), optional :: deflate_level ! 0-9
  2799. ! --- const --------------------------------------
  2800. character(len=*), parameter :: rname = mname//'/MDF_Def_Var'
  2801. ! --- external -----------------------------------
  2802. #ifdef with_hdf4
  2803. integer(hdf4_wpi), external :: sfCreate
  2804. integer(hdf4_wpi), external :: sfDimID
  2805. integer(hdf4_wpi), external :: sfSDmName
  2806. integer(hdf4_wpi), external :: sfsCompress
  2807. #endif
  2808. ! --- local --------------------------------------
  2809. type(MDF_File), pointer :: filep
  2810. type(MDF_Dim), pointer :: dimp
  2811. type(MDF_Var), pointer :: varp
  2812. integer :: iftype
  2813. integer :: ftype
  2814. integer :: idim
  2815. #ifdef with_hdf4
  2816. integer :: hdf4_xtype
  2817. integer :: hdf4_shape(MAX_RANK)
  2818. integer :: hdf4_dimid
  2819. integer :: hdf4_comp_type
  2820. integer :: hdf4_comp_prm(1)
  2821. #endif
  2822. #ifdef with_hdf5_beta
  2823. integer :: hdf5_xtype
  2824. integer(HID_T) :: hdf5_type_id
  2825. integer(HID_T) :: hdf5_space_id
  2826. integer(HID_T) :: hdf5_dcpl_id
  2827. integer :: hdf5_deflate_level
  2828. #endif
  2829. #ifdef with_netcdf
  2830. integer :: netcdf_xtype
  2831. integer :: netcdf_dimids(MAX_RANK)
  2832. integer :: netcdf_deflate_level
  2833. #endif
  2834. ! --- begin --------------------------------------
  2835. ! pointer to file structure:
  2836. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  2837. IF_NOT_OK_RETURN(status=1)
  2838. ! new variable:
  2839. call MDF_Var_List_New_Item( filep%Var_List, varid, status )
  2840. IF_NOT_OK_RETURN(status=1)
  2841. ! pointer to variable structure:
  2842. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  2843. IF_NOT_OK_RETURN(status=1)
  2844. ! store name;
  2845. varp%name = trim(name)
  2846. ! store type:
  2847. varp%xtype = xtype
  2848. ! set kind value given type:
  2849. call MDF_Get_Kind( varp%xtype, varp%xkind, status )
  2850. IF_NOT_OK_RETURN(status=1)
  2851. ! number of dimensions:
  2852. varp%ndim = size(dimids)
  2853. ! dimension id's :
  2854. varp%dimids(1:varp%ndim) = dimids
  2855. ! fill shape:
  2856. do idim = 1, varp%ndim
  2857. ! pointer to dimension type:
  2858. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status )
  2859. IF_NOT_OK_RETURN(status=1)
  2860. ! copy dimension id:
  2861. varp%shp(idim) = dimp%length
  2862. end do
  2863. ! loop over file types:
  2864. do iftype = 1, filep%nftype
  2865. ! current type:
  2866. ftype = filep%ftypes(iftype)
  2867. ! select appropriate routine for each type:
  2868. select case ( ftype )
  2869. #ifdef with_hdf4
  2870. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2871. case ( MDF_HDF4 )
  2872. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2873. ! set data type:
  2874. select case ( xtype )
  2875. case ( MDF_CHAR ) ; hdf4_xtype = DFNT_CHAR
  2876. case ( MDF_BYTE ) ; hdf4_xtype = DFNT_INT8
  2877. case ( MDF_SHORT ) ; hdf4_xtype = DFNT_INT16
  2878. case ( MDF_INT ) ; hdf4_xtype = DFNT_INT32
  2879. case ( MDF_FLOAT ) ; hdf4_xtype = DFNT_FLOAT32
  2880. case ( MDF_DOUBLE ) ; hdf4_xtype = DFNT_FLOAT64
  2881. case default
  2882. write (gol,'("unsupported data type : ",i6)') xtype; call goErr
  2883. TRACEBACK; status=1; return
  2884. end select
  2885. ! extract dimensions:
  2886. do idim = 1, varp%ndim
  2887. ! pointer to dimension type:
  2888. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status )
  2889. IF_NOT_OK_RETURN(status=1)
  2890. ! fill dimension:
  2891. if ( dimp%length == MDF_UNLIMITED ) then
  2892. hdf4_shape(idim) = SD_UNLIMITED
  2893. else
  2894. hdf4_shape(idim) = dimp%length
  2895. end if
  2896. end do
  2897. ! define variable:
  2898. status = sfCreate( filep%hdf4_id, trim(name), hdf4_xtype, &
  2899. varp%ndim, hdf4_shape(1:varp%ndim) )
  2900. if ( status == FAIL ) then
  2901. write (gol,'("from sfCreate :")'); call goErr
  2902. write (gol,'(" name : ",a)') trim(name); call goErr
  2903. write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr
  2904. TRACEBACK; status=1; return
  2905. end if
  2906. ! store
  2907. varp%hdf4_sdid = status
  2908. ! loop over dimension indices:
  2909. do idim = 1, varp%ndim
  2910. ! pointer to dimension type:
  2911. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status )
  2912. IF_NOT_OK_RETURN(status=1)
  2913. ! select dimension with zero based index:
  2914. status = sfDimID( varp%hdf4_sdid, idim-1 )
  2915. if ( status == FAIL ) then
  2916. write (gol,'("from sfDimID :")'); call goErr
  2917. write (gol,'(" dimension index : ",i6)') idim; call goErr
  2918. write (gol,'(" variable name : ",a)') trim(name); call goErr
  2919. write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr
  2920. TRACEBACK; status=1; return
  2921. end if
  2922. hdf4_dimid = status
  2923. ! set dimension name
  2924. status = sfSDmName( hdf4_dimid, trim(dimp%name) )
  2925. if ( status == FAIL ) then
  2926. write (gol,'("setting dimension name :")'); call goErr
  2927. write (gol,'(" dim name : ",a)') trim(dimp%name); call goErr
  2928. write (gol,'(" dimension index : ",i6)') idim; call goErr
  2929. write (gol,'(" variable name : ",a)') trim(name); call goErr
  2930. write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr
  2931. TRACEBACK; status=1; return
  2932. end if
  2933. end do ! dimensions
  2934. ! compression specified ?
  2935. if ( present(compression) ) then
  2936. ! apply ?
  2937. if ( compression /= MDF_NONE ) then
  2938. ! check ...
  2939. if ( any( varp%shp == MDF_UNLIMITED ) ) then
  2940. write (gol,'("HDF4 does not allow compresion of data sets with an unlimitted dimension ...")'); call goErr
  2941. TRACEBACK; status=1; return
  2942. end if
  2943. ! which one ?
  2944. select case ( compression )
  2945. ! deflation (=zlib)
  2946. case ( MDF_DEFLATE )
  2947. ! set compression type:
  2948. hdf4_comp_type = COMP_CODE_DEFLATE
  2949. ! set deflation level:
  2950. if ( present(deflate_level) ) then
  2951. hdf4_comp_prm(1) = deflate_level
  2952. else
  2953. hdf4_comp_prm(1) = 6
  2954. end if
  2955. case default
  2956. write (gol,'("unsupported compression type : ",i6)') compression; call goErr
  2957. TRACEBACK; status=1; return
  2958. end select
  2959. ! call HDF routine:
  2960. status = sfsCompress( varp%hdf4_sdid, hdf4_comp_type, hdf4_comp_prm )
  2961. if ( status == FAIL ) then
  2962. write (gol,'("from sfsCompress : ")'); call goErr
  2963. write (gol,'(" compression index : ",i6)') compression; call goErr
  2964. write (gol,'(" compression name : ",a)') trim(MDF_COMPRESSION_NAME(compression)); call goErr
  2965. write (gol,'(" hdf4 compress type : ",i6)') hdf4_comp_type; call goErr
  2966. write (gol,'(" hdf4 compress param : ",i6)') hdf4_comp_prm; call goErr
  2967. write (gol,'(" return status : ",i6)') status; call goErr
  2968. TRACEBACK; status=1; return
  2969. end if
  2970. end if ! apply ?
  2971. end if ! compression ?
  2972. #endif
  2973. #ifdef with_hdf5_beta
  2974. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2975. case ( MDF_HDF5 )
  2976. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  2977. ! set data type:
  2978. select case ( xtype )
  2979. case ( MDF_CHAR ) ; hdf5_xtype = H5T_NATIVE_CHARACTER
  2980. case ( MDF_BYTE ) ; hdf5_xtype = H5T_STD_I8LE
  2981. case ( MDF_SHORT ) ; hdf5_xtype = H5T_STD_I16LE
  2982. case ( MDF_INT ) ; hdf5_xtype = H5T_NATIVE_INTEGER
  2983. case ( MDF_FLOAT ) ; hdf5_xtype = H5T_NATIVE_REAL
  2984. case ( MDF_DOUBLE ) ; hdf5_xtype = H5T_NATIVE_DOUBLE
  2985. case default
  2986. write (gol,'("unsupported data type : ",i6)') xtype; call goErr
  2987. TRACEBACK; status=1; return
  2988. end select
  2989. ! data type:
  2990. call H5TCopy_f( hdf5_xtype, hdf5_type_id, status )
  2991. IF_NOT_OK_RETURN(status=1)
  2992. !! set length for characters ?
  2993. !call H5TSet_Size_f( hdf5_type_id, len(values), status )
  2994. !IF_NOT_OK_RETURN(status=1)
  2995. ! extract dimensions:
  2996. do idim = 1, varp%ndim
  2997. ! pointer to dimension type:
  2998. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status )
  2999. IF_NOT_OK_RETURN(status=1)
  3000. ! fill dimension:
  3001. if ( dimp%length == MDF_UNLIMITED ) then
  3002. varp%hdf5_dims (idim) = 0
  3003. varp%hdf5_maxdims (idim) = H5S_UNLIMITED_F
  3004. varp%hdf5_chunkdims(idim) = 1
  3005. varp%hdf5_chunked = .true.
  3006. else
  3007. varp%hdf5_dims (idim) = dimp%length
  3008. varp%hdf5_maxdims (idim) = dimp%length
  3009. varp%hdf5_chunkdims(idim) = dimp%length
  3010. varp%hdf5_chunked = .false.
  3011. end if
  3012. end do
  3013. ! create data space:
  3014. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_space_id, status, &
  3015. maxdims=varp%hdf5_maxdims(1:varp%ndim) )
  3016. IF_NOT_OK_RETURN(status=1)
  3017. ! dataset creation property list:
  3018. call H5PCreate_f( H5P_DATASET_CREATE_F, hdf5_dcpl_id, status )
  3019. IF_NOT_OK_RETURN(status=1)
  3020. ! for unlimited dimensions ...
  3021. if ( varp%hdf5_chunked ) then
  3022. call H5PSet_Chunk_f( hdf5_dcpl_id, varp%ndim, varp%hdf5_chunkdims(1:varp%ndim), status )
  3023. IF_NOT_OK_RETURN(status=1)
  3024. end if
  3025. ! compression specified ?
  3026. if ( present(compression) ) then
  3027. ! which one ?
  3028. select case ( compression )
  3029. ! no compression ...
  3030. case ( MDF_NONE )
  3031. ! nothing to be done
  3032. ! deflation (=gzip)
  3033. case ( MDF_DEFLATE )
  3034. ! set deflation level:
  3035. if ( present(deflate_level) ) then
  3036. hdf5_deflate_level = deflate_level
  3037. else
  3038. hdf5_deflate_level = 0
  3039. end if
  3040. ! add filter to property list:
  3041. call H5PSet_Deflate_f( hdf5_dcpl_id, hdf5_deflate_level, status )
  3042. IF_NOT_OK_RETURN(status=1)
  3043. case default
  3044. write (gol,'("unsupported compression type : ",i6)') compression; call goErr
  3045. TRACEBACK; status=1; return
  3046. end select
  3047. end if ! compression ?
  3048. ! store name:
  3049. varp%hdf5_name = trim(name)
  3050. ! define variable:
  3051. call H5DCreate_f( filep%hdf5_file_id, trim(name), hdf5_type_id, hdf5_space_id, varp%hdf5_dataset_id, status, &
  3052. dcpl_id=hdf5_dcpl_id )
  3053. IF_NOT_OK_RETURN(status=1)
  3054. ! close property list:
  3055. call H5PClose_f( hdf5_dcpl_id, status )
  3056. IF_NOT_OK_RETURN(status=1)
  3057. ! close data space:
  3058. call H5SClose_f( hdf5_space_id, status )
  3059. IF_NOT_OK_RETURN(status=1)
  3060. ! close data type:
  3061. call H5TClose_f( hdf5_type_id, status )
  3062. IF_NOT_OK_RETURN(status=1)
  3063. #endif
  3064. #ifdef with_netcdf
  3065. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3066. case ( MDF_NETCDF, MDF_NETCDF4 )
  3067. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3068. ! set data type:
  3069. select case ( xtype )
  3070. case ( MDF_CHAR ) ; netcdf_xtype = NF90_CHAR
  3071. case ( MDF_BYTE ) ; netcdf_xtype = NF90_BYTE
  3072. case ( MDF_SHORT ) ; netcdf_xtype = NF90_SHORT
  3073. case ( MDF_INT ) ; netcdf_xtype = NF90_INT
  3074. case ( MDF_FLOAT ) ; netcdf_xtype = NF90_FLOAT
  3075. case ( MDF_DOUBLE ) ; netcdf_xtype = NF90_DOUBLE
  3076. case default
  3077. write (gol,'("unsupported data type : ",i6)') xtype; call goErr
  3078. TRACEBACK; status=1; return
  3079. end select
  3080. ! extract dimensions:
  3081. do idim = 1, varp%ndim
  3082. ! pointer to dimension type:
  3083. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status )
  3084. IF_NOT_OK_RETURN(status=1)
  3085. ! copy dimension id:
  3086. netcdf_dimids(idim) = dimp%netcdf_dimid
  3087. end do
  3088. ! define variable:
  3089. status = NF90_Def_Var( filep%netcdf_id, trim(name), netcdf_xtype, &
  3090. netcdf_dimids(1:varp%ndim), varp%netcdf_varid )
  3091. IF_NF90_NOT_OK_RETURN(status=1)
  3092. ! compression specified ?
  3093. if ( present(compression) ) then
  3094. ! which one ?
  3095. select case ( compression )
  3096. ! no compression ...
  3097. case ( MDF_NONE )
  3098. ! nothing to be done
  3099. #ifdef with_netcdf4
  3100. ! deflation (=zlib)
  3101. case ( MDF_DEFLATE )
  3102. ! set deflation level:
  3103. if ( present(deflate_level) ) then
  3104. netcdf_deflate_level = deflate_level
  3105. else
  3106. netcdf_deflate_level = 0
  3107. end if
  3108. ! set parameters (without shuffle, with deflate)
  3109. status = NF90_Def_Var_Deflate( filep%netcdf_id, varp%netcdf_varid, 0, 1, netcdf_deflate_level )
  3110. IF_NF90_NOT_OK_RETURN(status=1)
  3111. #endif
  3112. case default
  3113. write (gol,'("unsupported compression type : ",i6)') compression; call goErr
  3114. write (gol,'("(might be necessary to compile with macro `with_netcdf4` defined)")'); call goErr
  3115. TRACEBACK; status=1; return
  3116. end select
  3117. end if ! compression ?
  3118. #endif
  3119. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3120. case default
  3121. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3122. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3123. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3124. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3125. TRACEBACK; status=1; return
  3126. end select
  3127. end do ! file types
  3128. ! no attributes yet:
  3129. varp%natt = 0
  3130. ! ok
  3131. status = 0
  3132. end subroutine MDF_Def_Var
  3133. ! ***
  3134. !--------------------------------------------------------------------------
  3135. ! TM5 !
  3136. !--------------------------------------------------------------------------
  3137. !BOP
  3138. !
  3139. ! !IROUTINE: MDF_Var_Par_Access
  3140. !
  3141. ! !DESCRIPTION: Wrapper around NF90_Var_Par_Access. It changes whether read
  3142. ! /write operations on a parallel file system are performed
  3143. ! collectively or independently (the default) on the variable.
  3144. !\\
  3145. !\\
  3146. ! !INTERFACE:
  3147. !
  3148. subroutine MDF_Var_Par_Access( hid, varid, par_access_mode, status )
  3149. !
  3150. ! !USES:
  3151. !
  3152. #ifdef with_netcdf4_par
  3153. use NetCDF, only : NF90_INDEPENDENT, NF90_COLLECTIVE
  3154. use NetCDF, only : NF90_Var_Par_Access
  3155. #endif
  3156. !
  3157. ! !INPUT PARAMETERS:
  3158. !
  3159. integer, intent(in) :: hid
  3160. integer, intent(in) :: varid
  3161. integer, intent(in) :: par_access_mode
  3162. !
  3163. ! !OUTPUT PARAMETERS:
  3164. !
  3165. integer, intent(out) :: status
  3166. !
  3167. ! !REVISION HISTORY:
  3168. ! 13 Jan 2012 - Philippe Le Sager - added COLLECTIVE case
  3169. !
  3170. ! !REMARKS:
  3171. !
  3172. !EOP
  3173. !------------------------------------------------------------------------
  3174. !BOC
  3175. character(len=*), parameter :: rname = mname//'/MDF_Var_Par_Access'
  3176. ! --- local --------------------------------------
  3177. type(MDF_File), pointer :: filep
  3178. type(MDF_Var), pointer :: varp
  3179. integer :: iftype
  3180. integer :: ftype
  3181. #ifdef with_netcdf4_par
  3182. integer :: netcdf_par_access_mode
  3183. #endif
  3184. ! --- begin --------------------------------------
  3185. ! pointer to file structure:
  3186. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3187. IF_NOT_OK_RETURN(status=1)
  3188. ! opened for parallel i/o ?
  3189. if ( filep%parallel ) then
  3190. ! pointer to variable structure:
  3191. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3192. IF_NOT_OK_RETURN(status=1)
  3193. ! loop over file types:
  3194. do iftype = 1, filep%nftype
  3195. ! current type:
  3196. ftype = filep%ftypes(iftype)
  3197. ! select appropriate routine for each type:
  3198. select case ( ftype )
  3199. #ifdef with_netcdf4
  3200. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3201. case ( MDF_NETCDF4 )
  3202. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3203. #ifdef with_netcdf4_par
  3204. ! set mode:
  3205. select case ( par_access_mode )
  3206. case ( MDF_INDEPENDENT ) ; netcdf_par_access_mode = NF90_INDEPENDENT
  3207. case ( MDF_COLLECTIVE ) ; netcdf_par_access_mode = NF90_COLLECTIVE
  3208. case default
  3209. write (gol,'("unsupported parallel access mode : ",i6)') par_access_mode; call goErr
  3210. TRACEBACK; status=1; return
  3211. end select
  3212. ! set access mode:
  3213. status = NF90_Var_Par_Access( filep%netcdf_id, varp%netcdf_varid, netcdf_par_access_mode )
  3214. IF_NF90_NOT_OK_RETURN(status=1)
  3215. #else
  3216. write (gol,'("Parallel access of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr
  3217. TRACEBACK; status=1; return
  3218. #endif
  3219. #endif
  3220. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3221. case default
  3222. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3223. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3224. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3225. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3226. TRACEBACK; status=1; return
  3227. end select
  3228. end do ! file types
  3229. end if ! parallel i/o
  3230. ! ok
  3231. status = 0
  3232. end subroutine MDF_Var_Par_Access
  3233. !EOC
  3234. ! ***
  3235. subroutine MDF_Put_Var_c1_1d( hid, varid, values, status, &
  3236. start, count, stride, map )
  3237. #ifdef with_hdf5_beta
  3238. use HDF5, only : HID_T, HSIZE_T
  3239. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  3240. use HDF5, only : H5T_NATIVE_CHARACTER
  3241. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  3242. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  3243. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  3244. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  3245. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  3246. #endif
  3247. #ifdef with_netcdf
  3248. use NetCDF, only : NF90_Put_Var
  3249. #endif
  3250. ! --- in/out -------------------------------------
  3251. integer, intent(in) :: hid
  3252. integer, intent(in) :: varid
  3253. character(len=*), intent(in) :: values
  3254. integer, intent(out) :: status
  3255. integer, intent(in), optional :: start (:)
  3256. integer, intent(in), optional :: count (:)
  3257. integer, intent(in), optional :: stride(:)
  3258. integer, intent(in), optional :: map (:)
  3259. ! --- const --------------------------------------
  3260. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_1d'
  3261. ! --- external -----------------------------------
  3262. #ifdef with_hdf4
  3263. integer(hdf4_wpi), external :: sfWData
  3264. #endif
  3265. ! --- local --------------------------------------
  3266. type(MDF_File), pointer :: filep
  3267. type(MDF_Var), pointer :: varp
  3268. integer :: iftype
  3269. integer :: ftype
  3270. #ifdef with_hdf4
  3271. integer :: hdf4_offset(MAX_RANK)
  3272. integer :: hdf4_stride(MAX_RANK)
  3273. integer :: hdf4_count(MAX_RANK)
  3274. #endif
  3275. #ifdef with_hdf5_beta
  3276. !integer(HID_T) :: hdf5_type_id
  3277. integer(HID_T) :: hdf5_file_space_id
  3278. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  3279. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  3280. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  3281. #endif
  3282. ! --- begin --------------------------------------
  3283. ! pointer to file structure:
  3284. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3285. IF_NOT_OK_RETURN(status=1)
  3286. ! pointer to variable structure:
  3287. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3288. IF_NOT_OK_RETURN(status=1)
  3289. ! check ...
  3290. if ( size(shape(values)) > varp%ndim ) then
  3291. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  3292. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  3293. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  3294. TRACEBACK; status=1; return
  3295. end if
  3296. ! check ...
  3297. if ( present(start ) ) then
  3298. if ( size(start ) /= varp%ndim ) then
  3299. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3300. write (gol,'(" size start : ",i6)') size(start ); call goErr
  3301. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3302. TRACEBACK; status=1; return
  3303. end if
  3304. end if
  3305. if ( present(count ) ) then
  3306. if ( size(count ) /= varp%ndim ) then
  3307. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3308. write (gol,'(" size count : ",i6)') size(count ); call goErr
  3309. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3310. TRACEBACK; status=1; return
  3311. end if
  3312. end if
  3313. if ( present(stride ) ) then
  3314. if ( size(stride ) /= varp%ndim ) then
  3315. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3316. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  3317. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3318. TRACEBACK; status=1; return
  3319. end if
  3320. end if
  3321. if ( present(map ) ) then
  3322. if ( size(map ) /= varp%ndim ) then
  3323. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3324. write (gol,'(" size map : ",i6)') size(map ); call goErr
  3325. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3326. TRACEBACK; status=1; return
  3327. end if
  3328. end if
  3329. ! loop over file types:
  3330. do iftype = 1, filep%nftype
  3331. ! current type:
  3332. ftype = filep%ftypes(iftype)
  3333. ! select appropriate routine for each type:
  3334. select case ( ftype )
  3335. #ifdef with_hdf4
  3336. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3337. case ( MDF_HDF4 )
  3338. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3339. ! check ...
  3340. if ( present(map ) ) then
  3341. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  3342. TRACEBACK; status=1; return
  3343. end if
  3344. ! fill offset (zero based!) and stride with default values:
  3345. hdf4_offset = 0
  3346. hdf4_stride = 1
  3347. ! count is by default the shape; padd with singleton dimensions:
  3348. hdf4_count = 1; hdf4_count(1:1) = (/len(values)/)
  3349. ! replace by optional arguments if necessary:
  3350. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  3351. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  3352. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  3353. ! write:
  3354. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  3355. #endif
  3356. #ifdef with_hdf5_beta
  3357. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3358. case ( MDF_HDF5 )
  3359. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3360. ! check ...
  3361. if ( present(map ) ) then
  3362. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  3363. TRACEBACK; status=1; return
  3364. end if
  3365. ! fill offset (zero based!), stride, and count :
  3366. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  3367. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  3368. hdf5_count = 1 ! default singleton dimension
  3369. if ( present(count) ) then
  3370. hdf5_count(1:varp%ndim) = count
  3371. else
  3372. hdf5_count(1:1) = (/len(values)/)
  3373. end if
  3374. ! new dimension:
  3375. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  3376. ! target data space in file:
  3377. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  3378. IF_NOT_OK_RETURN(status=1)
  3379. ! chunked dataset ?
  3380. if ( varp%hdf5_chunked ) then
  3381. ! reset extend:
  3382. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  3383. IF_NOT_OK_RETURN(status=1)
  3384. end if
  3385. ! select hyperslab:
  3386. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  3387. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  3388. stride=hdf5_stride(1:varp%ndim) )
  3389. ! write data:
  3390. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  3391. int(shape(values),kind=HSIZE_T), status, &
  3392. file_space_id=hdf5_file_space_id )
  3393. IF_NOT_OK_RETURN(status=1)
  3394. ! release data space:
  3395. call H5SClose_f( hdf5_file_space_id, status )
  3396. IF_NOT_OK_RETURN(status=1)
  3397. #endif
  3398. #ifdef with_netcdf
  3399. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3400. case ( MDF_NETCDF, MDF_NETCDF4 )
  3401. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3402. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3403. start, count, stride, map )
  3404. IF_NF90_NOT_OK_RETURN(status=1)
  3405. ! just put; let netcdf library convert the right kind:
  3406. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3407. ! start, count, stride, map )
  3408. !IF_NF90_NOT_OK_RETURN(status=1)
  3409. #endif
  3410. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3411. case default
  3412. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3413. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3414. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3415. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3416. TRACEBACK; status=1; return
  3417. end select
  3418. end do ! file types
  3419. ! ok
  3420. status = 0
  3421. end subroutine MDF_Put_Var_c1_1d
  3422. ! ***
  3423. subroutine MDF_Get_Var_c1_1d( hid, varid, values, status, &
  3424. start, count, stride, map )
  3425. #ifdef with_netcdf
  3426. use NetCDF, only : NF90_Get_Var
  3427. #endif
  3428. ! --- in/out -------------------------------------
  3429. integer, intent(in) :: hid
  3430. integer, intent(in) :: varid
  3431. character(len=*), intent(out) :: values
  3432. integer, intent(out) :: status
  3433. integer, intent(in), optional :: start (:)
  3434. integer, intent(in), optional :: count (:)
  3435. integer, intent(in), optional :: stride(:)
  3436. integer, intent(in), optional :: map (:)
  3437. ! --- const --------------------------------------
  3438. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_1d'
  3439. ! --- external -----------------------------------
  3440. #ifdef with_hdf4
  3441. integer(hdf4_wpi), external :: sfRData
  3442. #endif
  3443. ! --- local --------------------------------------
  3444. type(MDF_File), pointer :: filep
  3445. type(MDF_Var), pointer :: varp
  3446. integer :: iftype
  3447. integer :: ftype
  3448. #ifdef with_hdf4
  3449. integer :: hdf4_offset(MAX_RANK)
  3450. integer :: hdf4_stride(MAX_RANK)
  3451. integer :: hdf4_count(MAX_RANK)
  3452. #endif
  3453. ! --- begin --------------------------------------
  3454. ! pointer to file structure:
  3455. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3456. IF_NOT_OK_RETURN(status=1)
  3457. ! pointer to variable structure:
  3458. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3459. IF_NOT_OK_RETURN(status=1)
  3460. ! check ...
  3461. if ( size(shape(values)) > varp%ndim ) then
  3462. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  3463. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  3464. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  3465. TRACEBACK; status=1; return
  3466. end if
  3467. ! check ...
  3468. if ( present(start ) ) then
  3469. if ( size(start ) /= varp%ndim ) then
  3470. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3471. write (gol,'(" size start : ",i6)') size(start ); call goErr
  3472. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3473. TRACEBACK; status=1; return
  3474. end if
  3475. end if
  3476. if ( present(count ) ) then
  3477. if ( size(count ) /= varp%ndim ) then
  3478. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3479. write (gol,'(" size count : ",i6)') size(count ); call goErr
  3480. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3481. TRACEBACK; status=1; return
  3482. end if
  3483. end if
  3484. if ( present(stride ) ) then
  3485. if ( size(stride ) /= varp%ndim ) then
  3486. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3487. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  3488. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3489. TRACEBACK; status=1; return
  3490. end if
  3491. end if
  3492. if ( present(map ) ) then
  3493. if ( size(map ) /= varp%ndim ) then
  3494. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3495. write (gol,'(" size map : ",i6)') size(map ); call goErr
  3496. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3497. TRACEBACK; status=1; return
  3498. end if
  3499. end if
  3500. ! loop over file types:
  3501. do iftype = 1, filep%nftype
  3502. ! current type:
  3503. ftype = filep%ftypes(iftype)
  3504. ! select appropriate routine for each type:
  3505. select case ( ftype )
  3506. #ifdef with_hdf4
  3507. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3508. case ( MDF_HDF4 )
  3509. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3510. ! check ...
  3511. if ( present(map ) ) then
  3512. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  3513. TRACEBACK; status=1; return
  3514. end if
  3515. ! fill offset (zero based!), stride, and count :
  3516. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  3517. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  3518. hdf4_count = 1 ! default singleton dimension
  3519. hdf4_count(1:1) = (/ len(values) /)
  3520. ! read:
  3521. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  3522. #endif
  3523. #ifdef with_netcdf
  3524. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3525. case ( MDF_NETCDF, MDF_NETCDF4 )
  3526. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3527. ! read values, converted automatically:
  3528. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3529. start, count, stride, map )
  3530. IF_NF90_NOT_OK_RETURN(status=1)
  3531. #endif
  3532. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3533. case default
  3534. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3535. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3536. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3537. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3538. TRACEBACK; status=1; return
  3539. end select
  3540. end do ! file types
  3541. ! ok
  3542. status = 0
  3543. end subroutine MDF_Get_Var_c1_1d
  3544. ! ***
  3545. subroutine MDF_Put_Var_c1_2d( hid, varid, values, status, &
  3546. start, count, stride, map )
  3547. #ifdef with_hdf5_beta
  3548. use HDF5, only : HID_T, HSIZE_T
  3549. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  3550. use HDF5, only : H5T_NATIVE_CHARACTER
  3551. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  3552. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  3553. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  3554. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  3555. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  3556. #endif
  3557. #ifdef with_netcdf
  3558. use NetCDF, only : NF90_Put_Var
  3559. #endif
  3560. ! --- in/out -------------------------------------
  3561. integer, intent(in) :: hid
  3562. integer, intent(in) :: varid
  3563. character(len=*), intent(in) :: values(:)
  3564. integer, intent(out) :: status
  3565. integer, intent(in), optional :: start (:)
  3566. integer, intent(in), optional :: count (:)
  3567. integer, intent(in), optional :: stride(:)
  3568. integer, intent(in), optional :: map (:)
  3569. ! --- const --------------------------------------
  3570. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_2d'
  3571. ! --- external -----------------------------------
  3572. #ifdef with_hdf4
  3573. integer(hdf4_wpi), external :: sfWData
  3574. #endif
  3575. ! --- local --------------------------------------
  3576. type(MDF_File), pointer :: filep
  3577. type(MDF_Var), pointer :: varp
  3578. integer :: iftype
  3579. integer :: ftype
  3580. #ifdef with_hdf4
  3581. integer :: hdf4_offset(MAX_RANK)
  3582. integer :: hdf4_stride(MAX_RANK)
  3583. integer :: hdf4_count(MAX_RANK)
  3584. #endif
  3585. #ifdef with_hdf5_beta
  3586. !integer(HID_T) :: hdf5_type_id
  3587. integer(HID_T) :: hdf5_file_space_id
  3588. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  3589. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  3590. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  3591. #endif
  3592. ! --- begin --------------------------------------
  3593. ! pointer to file structure:
  3594. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3595. IF_NOT_OK_RETURN(status=1)
  3596. ! pointer to variable structure:
  3597. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3598. IF_NOT_OK_RETURN(status=1)
  3599. ! check ...
  3600. if ( size(shape(values)) > varp%ndim ) then
  3601. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  3602. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  3603. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  3604. TRACEBACK; status=1; return
  3605. end if
  3606. ! check ...
  3607. if ( present(start ) ) then
  3608. if ( size(start ) /= varp%ndim ) then
  3609. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3610. write (gol,'(" size start : ",i6)') size(start ); call goErr
  3611. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3612. TRACEBACK; status=1; return
  3613. end if
  3614. end if
  3615. if ( present(count ) ) then
  3616. if ( size(count ) /= varp%ndim ) then
  3617. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3618. write (gol,'(" size count : ",i6)') size(count ); call goErr
  3619. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3620. TRACEBACK; status=1; return
  3621. end if
  3622. end if
  3623. if ( present(stride ) ) then
  3624. if ( size(stride ) /= varp%ndim ) then
  3625. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3626. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  3627. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3628. TRACEBACK; status=1; return
  3629. end if
  3630. end if
  3631. if ( present(map ) ) then
  3632. if ( size(map ) /= varp%ndim ) then
  3633. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3634. write (gol,'(" size map : ",i6)') size(map ); call goErr
  3635. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3636. TRACEBACK; status=1; return
  3637. end if
  3638. end if
  3639. ! loop over file types:
  3640. do iftype = 1, filep%nftype
  3641. ! current type:
  3642. ftype = filep%ftypes(iftype)
  3643. ! select appropriate routine for each type:
  3644. select case ( ftype )
  3645. #ifdef with_hdf4
  3646. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3647. case ( MDF_HDF4 )
  3648. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3649. ! check ...
  3650. if ( present(map ) ) then
  3651. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  3652. TRACEBACK; status=1; return
  3653. end if
  3654. ! fill offset (zero based!) and stride with default values:
  3655. hdf4_offset = 0
  3656. hdf4_stride = 1
  3657. ! count is by default the shape; padd with singleton dimensions:
  3658. hdf4_count = 1; hdf4_count(1:2) = (/len(values),shape(values)/)
  3659. ! replace by optional arguments if necessary:
  3660. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  3661. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  3662. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  3663. ! write:
  3664. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  3665. #endif
  3666. #ifdef with_hdf5_beta
  3667. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3668. case ( MDF_HDF5 )
  3669. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3670. ! check ...
  3671. if ( present(map ) ) then
  3672. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  3673. TRACEBACK; status=1; return
  3674. end if
  3675. ! fill offset (zero based!), stride, and count :
  3676. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  3677. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  3678. hdf5_count = 1 ! default singleton dimension
  3679. if ( present(count) ) then
  3680. hdf5_count(1:varp%ndim) = count
  3681. else
  3682. hdf5_count(1:2) = (/len(values),shape(values)/)
  3683. end if
  3684. ! new dimension:
  3685. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  3686. ! target data space in file:
  3687. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  3688. IF_NOT_OK_RETURN(status=1)
  3689. ! chunked dataset ?
  3690. if ( varp%hdf5_chunked ) then
  3691. ! reset extend:
  3692. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  3693. IF_NOT_OK_RETURN(status=1)
  3694. end if
  3695. ! select hyperslab:
  3696. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  3697. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  3698. stride=hdf5_stride(1:varp%ndim) )
  3699. ! write data:
  3700. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  3701. int(shape(values),kind=HSIZE_T), status, &
  3702. file_space_id=hdf5_file_space_id )
  3703. IF_NOT_OK_RETURN(status=1)
  3704. ! release data space:
  3705. call H5SClose_f( hdf5_file_space_id, status )
  3706. IF_NOT_OK_RETURN(status=1)
  3707. #endif
  3708. #ifdef with_netcdf
  3709. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3710. case ( MDF_NETCDF, MDF_NETCDF4 )
  3711. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3712. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3713. start, count, stride, map )
  3714. IF_NF90_NOT_OK_RETURN(status=1)
  3715. ! just put; let netcdf library convert the right kind:
  3716. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3717. ! start, count, stride, map )
  3718. !IF_NF90_NOT_OK_RETURN(status=1)
  3719. #endif
  3720. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3721. case default
  3722. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3723. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3724. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3725. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3726. TRACEBACK; status=1; return
  3727. end select
  3728. end do ! file types
  3729. ! ok
  3730. status = 0
  3731. end subroutine MDF_Put_Var_c1_2d
  3732. ! ***
  3733. subroutine MDF_Get_Var_c1_2d( hid, varid, values, status, &
  3734. start, count, stride, map )
  3735. #ifdef with_netcdf
  3736. use NetCDF, only : NF90_Get_Var
  3737. #endif
  3738. ! --- in/out -------------------------------------
  3739. integer, intent(in) :: hid
  3740. integer, intent(in) :: varid
  3741. character(len=*), intent(out) :: values(:)
  3742. integer, intent(out) :: status
  3743. integer, intent(in), optional :: start (:)
  3744. integer, intent(in), optional :: count (:)
  3745. integer, intent(in), optional :: stride(:)
  3746. integer, intent(in), optional :: map (:)
  3747. ! --- const --------------------------------------
  3748. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_2d'
  3749. ! --- external -----------------------------------
  3750. #ifdef with_hdf4
  3751. integer(hdf4_wpi), external :: sfRData
  3752. #endif
  3753. ! --- local --------------------------------------
  3754. type(MDF_File), pointer :: filep
  3755. type(MDF_Var), pointer :: varp
  3756. integer :: iftype
  3757. integer :: ftype
  3758. #ifdef with_hdf4
  3759. integer :: hdf4_offset(MAX_RANK)
  3760. integer :: hdf4_stride(MAX_RANK)
  3761. integer :: hdf4_count(MAX_RANK)
  3762. #endif
  3763. ! --- begin --------------------------------------
  3764. ! pointer to file structure:
  3765. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3766. IF_NOT_OK_RETURN(status=1)
  3767. ! pointer to variable structure:
  3768. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3769. IF_NOT_OK_RETURN(status=1)
  3770. ! check ...
  3771. if ( size(shape(values)) > varp%ndim ) then
  3772. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  3773. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  3774. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  3775. TRACEBACK; status=1; return
  3776. end if
  3777. ! check ...
  3778. if ( present(start ) ) then
  3779. if ( size(start ) /= varp%ndim ) then
  3780. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3781. write (gol,'(" size start : ",i6)') size(start ); call goErr
  3782. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3783. TRACEBACK; status=1; return
  3784. end if
  3785. end if
  3786. if ( present(count ) ) then
  3787. if ( size(count ) /= varp%ndim ) then
  3788. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3789. write (gol,'(" size count : ",i6)') size(count ); call goErr
  3790. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3791. TRACEBACK; status=1; return
  3792. end if
  3793. end if
  3794. if ( present(stride ) ) then
  3795. if ( size(stride ) /= varp%ndim ) then
  3796. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3797. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  3798. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3799. TRACEBACK; status=1; return
  3800. end if
  3801. end if
  3802. if ( present(map ) ) then
  3803. if ( size(map ) /= varp%ndim ) then
  3804. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3805. write (gol,'(" size map : ",i6)') size(map ); call goErr
  3806. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3807. TRACEBACK; status=1; return
  3808. end if
  3809. end if
  3810. ! loop over file types:
  3811. do iftype = 1, filep%nftype
  3812. ! current type:
  3813. ftype = filep%ftypes(iftype)
  3814. ! select appropriate routine for each type:
  3815. select case ( ftype )
  3816. #ifdef with_hdf4
  3817. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3818. case ( MDF_HDF4 )
  3819. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3820. ! check ...
  3821. if ( present(map ) ) then
  3822. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  3823. TRACEBACK; status=1; return
  3824. end if
  3825. ! fill offset (zero based!), stride, and count :
  3826. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  3827. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  3828. hdf4_count = 1 ! default singleton dimension
  3829. hdf4_count(1:2) = (/ len(values), shape(values) /)
  3830. ! read:
  3831. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  3832. #endif
  3833. #ifdef with_netcdf
  3834. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3835. case ( MDF_NETCDF, MDF_NETCDF4 )
  3836. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3837. ! read values, converted automatically:
  3838. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  3839. start, count, stride, map )
  3840. IF_NF90_NOT_OK_RETURN(status=1)
  3841. #endif
  3842. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3843. case default
  3844. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3845. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  3846. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  3847. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  3848. TRACEBACK; status=1; return
  3849. end select
  3850. end do ! file types
  3851. ! ok
  3852. status = 0
  3853. end subroutine MDF_Get_Var_c1_2d
  3854. ! ***
  3855. subroutine MDF_Put_Var_c1_3d( hid, varid, values, status, &
  3856. start, count, stride, map )
  3857. #ifdef with_hdf5_beta
  3858. use HDF5, only : HID_T, HSIZE_T
  3859. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  3860. use HDF5, only : H5T_NATIVE_CHARACTER
  3861. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  3862. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  3863. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  3864. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  3865. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  3866. #endif
  3867. #ifdef with_netcdf
  3868. use NetCDF, only : NF90_Put_Var
  3869. #endif
  3870. ! --- in/out -------------------------------------
  3871. integer, intent(in) :: hid
  3872. integer, intent(in) :: varid
  3873. character(len=*), intent(in) :: values(:,:)
  3874. integer, intent(out) :: status
  3875. integer, intent(in), optional :: start (:)
  3876. integer, intent(in), optional :: count (:)
  3877. integer, intent(in), optional :: stride(:)
  3878. integer, intent(in), optional :: map (:)
  3879. ! --- const --------------------------------------
  3880. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_3d'
  3881. ! --- external -----------------------------------
  3882. #ifdef with_hdf4
  3883. integer(hdf4_wpi), external :: sfWData
  3884. #endif
  3885. ! --- local --------------------------------------
  3886. type(MDF_File), pointer :: filep
  3887. type(MDF_Var), pointer :: varp
  3888. integer :: iftype
  3889. integer :: ftype
  3890. #ifdef with_hdf4
  3891. integer :: hdf4_offset(MAX_RANK)
  3892. integer :: hdf4_stride(MAX_RANK)
  3893. integer :: hdf4_count(MAX_RANK)
  3894. #endif
  3895. #ifdef with_hdf5_beta
  3896. !integer(HID_T) :: hdf5_type_id
  3897. integer(HID_T) :: hdf5_file_space_id
  3898. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  3899. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  3900. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  3901. #endif
  3902. ! --- begin --------------------------------------
  3903. ! pointer to file structure:
  3904. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  3905. IF_NOT_OK_RETURN(status=1)
  3906. ! pointer to variable structure:
  3907. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  3908. IF_NOT_OK_RETURN(status=1)
  3909. ! check ...
  3910. if ( size(shape(values)) > varp%ndim ) then
  3911. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  3912. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  3913. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  3914. TRACEBACK; status=1; return
  3915. end if
  3916. ! check ...
  3917. if ( present(start ) ) then
  3918. if ( size(start ) /= varp%ndim ) then
  3919. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3920. write (gol,'(" size start : ",i6)') size(start ); call goErr
  3921. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3922. TRACEBACK; status=1; return
  3923. end if
  3924. end if
  3925. if ( present(count ) ) then
  3926. if ( size(count ) /= varp%ndim ) then
  3927. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3928. write (gol,'(" size count : ",i6)') size(count ); call goErr
  3929. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3930. TRACEBACK; status=1; return
  3931. end if
  3932. end if
  3933. if ( present(stride ) ) then
  3934. if ( size(stride ) /= varp%ndim ) then
  3935. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3936. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  3937. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3938. TRACEBACK; status=1; return
  3939. end if
  3940. end if
  3941. if ( present(map ) ) then
  3942. if ( size(map ) /= varp%ndim ) then
  3943. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  3944. write (gol,'(" size map : ",i6)') size(map ); call goErr
  3945. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  3946. TRACEBACK; status=1; return
  3947. end if
  3948. end if
  3949. ! loop over file types:
  3950. do iftype = 1, filep%nftype
  3951. ! current type:
  3952. ftype = filep%ftypes(iftype)
  3953. ! select appropriate routine for each type:
  3954. select case ( ftype )
  3955. #ifdef with_hdf4
  3956. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3957. case ( MDF_HDF4 )
  3958. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3959. ! check ...
  3960. if ( present(map ) ) then
  3961. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  3962. TRACEBACK; status=1; return
  3963. end if
  3964. ! fill offset (zero based!) and stride with default values:
  3965. hdf4_offset = 0
  3966. hdf4_stride = 1
  3967. ! count is by default the shape; padd with singleton dimensions:
  3968. hdf4_count = 1; hdf4_count(1:3) = (/len(values),shape(values)/)
  3969. ! replace by optional arguments if necessary:
  3970. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  3971. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  3972. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  3973. ! write:
  3974. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  3975. #endif
  3976. #ifdef with_hdf5_beta
  3977. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3978. case ( MDF_HDF5 )
  3979. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  3980. ! check ...
  3981. if ( present(map ) ) then
  3982. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  3983. TRACEBACK; status=1; return
  3984. end if
  3985. ! fill offset (zero based!), stride, and count :
  3986. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  3987. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  3988. hdf5_count = 1 ! default singleton dimension
  3989. if ( present(count) ) then
  3990. hdf5_count(1:varp%ndim) = count
  3991. else
  3992. hdf5_count(1:3) = (/len(values),shape(values)/)
  3993. end if
  3994. ! new dimension:
  3995. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  3996. ! target data space in file:
  3997. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  3998. IF_NOT_OK_RETURN(status=1)
  3999. ! chunked dataset ?
  4000. if ( varp%hdf5_chunked ) then
  4001. ! reset extend:
  4002. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  4003. IF_NOT_OK_RETURN(status=1)
  4004. end if
  4005. ! select hyperslab:
  4006. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  4007. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  4008. stride=hdf5_stride(1:varp%ndim) )
  4009. ! write data:
  4010. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  4011. int(shape(values),kind=HSIZE_T), status, &
  4012. file_space_id=hdf5_file_space_id )
  4013. IF_NOT_OK_RETURN(status=1)
  4014. ! release data space:
  4015. call H5SClose_f( hdf5_file_space_id, status )
  4016. IF_NOT_OK_RETURN(status=1)
  4017. #endif
  4018. #ifdef with_netcdf
  4019. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4020. case ( MDF_NETCDF, MDF_NETCDF4 )
  4021. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4022. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4023. start, count, stride, map )
  4024. IF_NF90_NOT_OK_RETURN(status=1)
  4025. ! just put; let netcdf library convert the right kind:
  4026. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4027. ! start, count, stride, map )
  4028. !IF_NF90_NOT_OK_RETURN(status=1)
  4029. #endif
  4030. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4031. case default
  4032. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4033. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4034. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4035. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4036. TRACEBACK; status=1; return
  4037. end select
  4038. end do ! file types
  4039. ! ok
  4040. status = 0
  4041. end subroutine MDF_Put_Var_c1_3d
  4042. ! ***
  4043. subroutine MDF_Get_Var_c1_3d( hid, varid, values, status, &
  4044. start, count, stride, map )
  4045. #ifdef with_netcdf
  4046. use NetCDF, only : NF90_Get_Var
  4047. #endif
  4048. ! --- in/out -------------------------------------
  4049. integer, intent(in) :: hid
  4050. integer, intent(in) :: varid
  4051. character(len=*), intent(out) :: values(:,:)
  4052. integer, intent(out) :: status
  4053. integer, intent(in), optional :: start (:)
  4054. integer, intent(in), optional :: count (:)
  4055. integer, intent(in), optional :: stride(:)
  4056. integer, intent(in), optional :: map (:)
  4057. ! --- const --------------------------------------
  4058. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_3d'
  4059. ! --- external -----------------------------------
  4060. #ifdef with_hdf4
  4061. integer(hdf4_wpi), external :: sfRData
  4062. #endif
  4063. ! --- local --------------------------------------
  4064. type(MDF_File), pointer :: filep
  4065. type(MDF_Var), pointer :: varp
  4066. integer :: iftype
  4067. integer :: ftype
  4068. #ifdef with_hdf4
  4069. integer :: hdf4_offset(MAX_RANK)
  4070. integer :: hdf4_stride(MAX_RANK)
  4071. integer :: hdf4_count(MAX_RANK)
  4072. #endif
  4073. ! --- begin --------------------------------------
  4074. ! pointer to file structure:
  4075. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4076. IF_NOT_OK_RETURN(status=1)
  4077. ! pointer to variable structure:
  4078. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4079. IF_NOT_OK_RETURN(status=1)
  4080. ! check ...
  4081. if ( size(shape(values)) > varp%ndim ) then
  4082. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  4083. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4084. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4085. TRACEBACK; status=1; return
  4086. end if
  4087. ! check ...
  4088. if ( present(start ) ) then
  4089. if ( size(start ) /= varp%ndim ) then
  4090. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4091. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4092. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4093. TRACEBACK; status=1; return
  4094. end if
  4095. end if
  4096. if ( present(count ) ) then
  4097. if ( size(count ) /= varp%ndim ) then
  4098. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4099. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4100. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4101. TRACEBACK; status=1; return
  4102. end if
  4103. end if
  4104. if ( present(stride ) ) then
  4105. if ( size(stride ) /= varp%ndim ) then
  4106. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4107. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4108. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4109. TRACEBACK; status=1; return
  4110. end if
  4111. end if
  4112. if ( present(map ) ) then
  4113. if ( size(map ) /= varp%ndim ) then
  4114. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4115. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4116. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4117. TRACEBACK; status=1; return
  4118. end if
  4119. end if
  4120. ! loop over file types:
  4121. do iftype = 1, filep%nftype
  4122. ! current type:
  4123. ftype = filep%ftypes(iftype)
  4124. ! select appropriate routine for each type:
  4125. select case ( ftype )
  4126. #ifdef with_hdf4
  4127. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4128. case ( MDF_HDF4 )
  4129. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4130. ! check ...
  4131. if ( present(map ) ) then
  4132. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4133. TRACEBACK; status=1; return
  4134. end if
  4135. ! fill offset (zero based!), stride, and count :
  4136. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4137. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4138. hdf4_count = 1 ! default singleton dimension
  4139. hdf4_count(1:3) = (/ len(values), shape(values) /)
  4140. ! read:
  4141. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4142. #endif
  4143. #ifdef with_netcdf
  4144. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4145. case ( MDF_NETCDF, MDF_NETCDF4 )
  4146. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4147. ! read values, converted automatically:
  4148. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4149. start, count, stride, map )
  4150. IF_NF90_NOT_OK_RETURN(status=1)
  4151. #endif
  4152. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4153. case default
  4154. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4155. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4156. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4157. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4158. TRACEBACK; status=1; return
  4159. end select
  4160. end do ! file types
  4161. ! ok
  4162. status = 0
  4163. end subroutine MDF_Get_Var_c1_3d
  4164. ! ***
  4165. subroutine MDF_Put_Var_c1_4d( hid, varid, values, status, &
  4166. start, count, stride, map )
  4167. #ifdef with_hdf5_beta
  4168. use HDF5, only : HID_T, HSIZE_T
  4169. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  4170. use HDF5, only : H5T_NATIVE_CHARACTER
  4171. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  4172. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  4173. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  4174. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  4175. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  4176. #endif
  4177. #ifdef with_netcdf
  4178. use NetCDF, only : NF90_Put_Var
  4179. #endif
  4180. ! --- in/out -------------------------------------
  4181. integer, intent(in) :: hid
  4182. integer, intent(in) :: varid
  4183. character(len=*), intent(in) :: values(:,:,:)
  4184. integer, intent(out) :: status
  4185. integer, intent(in), optional :: start (:)
  4186. integer, intent(in), optional :: count (:)
  4187. integer, intent(in), optional :: stride(:)
  4188. integer, intent(in), optional :: map (:)
  4189. ! --- const --------------------------------------
  4190. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_4d'
  4191. ! --- external -----------------------------------
  4192. #ifdef with_hdf4
  4193. integer(hdf4_wpi), external :: sfWData
  4194. #endif
  4195. ! --- local --------------------------------------
  4196. type(MDF_File), pointer :: filep
  4197. type(MDF_Var), pointer :: varp
  4198. integer :: iftype
  4199. integer :: ftype
  4200. #ifdef with_hdf4
  4201. integer :: hdf4_offset(MAX_RANK)
  4202. integer :: hdf4_stride(MAX_RANK)
  4203. integer :: hdf4_count(MAX_RANK)
  4204. #endif
  4205. #ifdef with_hdf5_beta
  4206. !integer(HID_T) :: hdf5_type_id
  4207. integer(HID_T) :: hdf5_file_space_id
  4208. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  4209. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  4210. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  4211. #endif
  4212. ! --- begin --------------------------------------
  4213. ! pointer to file structure:
  4214. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4215. IF_NOT_OK_RETURN(status=1)
  4216. ! pointer to variable structure:
  4217. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4218. IF_NOT_OK_RETURN(status=1)
  4219. ! check ...
  4220. if ( size(shape(values)) > varp%ndim ) then
  4221. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  4222. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4223. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4224. TRACEBACK; status=1; return
  4225. end if
  4226. ! check ...
  4227. if ( present(start ) ) then
  4228. if ( size(start ) /= varp%ndim ) then
  4229. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4230. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4231. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4232. TRACEBACK; status=1; return
  4233. end if
  4234. end if
  4235. if ( present(count ) ) then
  4236. if ( size(count ) /= varp%ndim ) then
  4237. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4238. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4239. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4240. TRACEBACK; status=1; return
  4241. end if
  4242. end if
  4243. if ( present(stride ) ) then
  4244. if ( size(stride ) /= varp%ndim ) then
  4245. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4246. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4247. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4248. TRACEBACK; status=1; return
  4249. end if
  4250. end if
  4251. if ( present(map ) ) then
  4252. if ( size(map ) /= varp%ndim ) then
  4253. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4254. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4255. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4256. TRACEBACK; status=1; return
  4257. end if
  4258. end if
  4259. ! loop over file types:
  4260. do iftype = 1, filep%nftype
  4261. ! current type:
  4262. ftype = filep%ftypes(iftype)
  4263. ! select appropriate routine for each type:
  4264. select case ( ftype )
  4265. #ifdef with_hdf4
  4266. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4267. case ( MDF_HDF4 )
  4268. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4269. ! check ...
  4270. if ( present(map ) ) then
  4271. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4272. TRACEBACK; status=1; return
  4273. end if
  4274. ! fill offset (zero based!) and stride with default values:
  4275. hdf4_offset = 0
  4276. hdf4_stride = 1
  4277. ! count is by default the shape; padd with singleton dimensions:
  4278. hdf4_count = 1; hdf4_count(1:4) = (/len(values),shape(values)/)
  4279. ! replace by optional arguments if necessary:
  4280. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4281. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4282. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  4283. ! write:
  4284. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4285. #endif
  4286. #ifdef with_hdf5_beta
  4287. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4288. case ( MDF_HDF5 )
  4289. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4290. ! check ...
  4291. if ( present(map ) ) then
  4292. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  4293. TRACEBACK; status=1; return
  4294. end if
  4295. ! fill offset (zero based!), stride, and count :
  4296. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  4297. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  4298. hdf5_count = 1 ! default singleton dimension
  4299. if ( present(count) ) then
  4300. hdf5_count(1:varp%ndim) = count
  4301. else
  4302. hdf5_count(1:4) = (/len(values),shape(values)/)
  4303. end if
  4304. ! new dimension:
  4305. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  4306. ! target data space in file:
  4307. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  4308. IF_NOT_OK_RETURN(status=1)
  4309. ! chunked dataset ?
  4310. if ( varp%hdf5_chunked ) then
  4311. ! reset extend:
  4312. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  4313. IF_NOT_OK_RETURN(status=1)
  4314. end if
  4315. ! select hyperslab:
  4316. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  4317. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  4318. stride=hdf5_stride(1:varp%ndim) )
  4319. ! write data:
  4320. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  4321. int(shape(values),kind=HSIZE_T), status, &
  4322. file_space_id=hdf5_file_space_id )
  4323. IF_NOT_OK_RETURN(status=1)
  4324. ! release data space:
  4325. call H5SClose_f( hdf5_file_space_id, status )
  4326. IF_NOT_OK_RETURN(status=1)
  4327. #endif
  4328. #ifdef with_netcdf
  4329. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4330. case ( MDF_NETCDF, MDF_NETCDF4 )
  4331. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4332. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4333. start, count, stride, map )
  4334. IF_NF90_NOT_OK_RETURN(status=1)
  4335. ! just put; let netcdf library convert the right kind:
  4336. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4337. ! start, count, stride, map )
  4338. !IF_NF90_NOT_OK_RETURN(status=1)
  4339. #endif
  4340. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4341. case default
  4342. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4343. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4344. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4345. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4346. TRACEBACK; status=1; return
  4347. end select
  4348. end do ! file types
  4349. ! ok
  4350. status = 0
  4351. end subroutine MDF_Put_Var_c1_4d
  4352. ! ***
  4353. subroutine MDF_Get_Var_c1_4d( hid, varid, values, status, &
  4354. start, count, stride, map )
  4355. #ifdef with_netcdf
  4356. use NetCDF, only : NF90_Get_Var
  4357. #endif
  4358. ! --- in/out -------------------------------------
  4359. integer, intent(in) :: hid
  4360. integer, intent(in) :: varid
  4361. character(len=*), intent(out) :: values(:,:,:)
  4362. integer, intent(out) :: status
  4363. integer, intent(in), optional :: start (:)
  4364. integer, intent(in), optional :: count (:)
  4365. integer, intent(in), optional :: stride(:)
  4366. integer, intent(in), optional :: map (:)
  4367. ! --- const --------------------------------------
  4368. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_4d'
  4369. ! --- external -----------------------------------
  4370. #ifdef with_hdf4
  4371. integer(hdf4_wpi), external :: sfRData
  4372. #endif
  4373. ! --- local --------------------------------------
  4374. type(MDF_File), pointer :: filep
  4375. type(MDF_Var), pointer :: varp
  4376. integer :: iftype
  4377. integer :: ftype
  4378. #ifdef with_hdf4
  4379. integer :: hdf4_offset(MAX_RANK)
  4380. integer :: hdf4_stride(MAX_RANK)
  4381. integer :: hdf4_count(MAX_RANK)
  4382. #endif
  4383. ! --- begin --------------------------------------
  4384. ! pointer to file structure:
  4385. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4386. IF_NOT_OK_RETURN(status=1)
  4387. ! pointer to variable structure:
  4388. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4389. IF_NOT_OK_RETURN(status=1)
  4390. ! check ...
  4391. if ( size(shape(values)) > varp%ndim ) then
  4392. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  4393. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4394. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4395. TRACEBACK; status=1; return
  4396. end if
  4397. ! check ...
  4398. if ( present(start ) ) then
  4399. if ( size(start ) /= varp%ndim ) then
  4400. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4401. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4402. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4403. TRACEBACK; status=1; return
  4404. end if
  4405. end if
  4406. if ( present(count ) ) then
  4407. if ( size(count ) /= varp%ndim ) then
  4408. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4409. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4410. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4411. TRACEBACK; status=1; return
  4412. end if
  4413. end if
  4414. if ( present(stride ) ) then
  4415. if ( size(stride ) /= varp%ndim ) then
  4416. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4417. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4418. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4419. TRACEBACK; status=1; return
  4420. end if
  4421. end if
  4422. if ( present(map ) ) then
  4423. if ( size(map ) /= varp%ndim ) then
  4424. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4425. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4426. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4427. TRACEBACK; status=1; return
  4428. end if
  4429. end if
  4430. ! loop over file types:
  4431. do iftype = 1, filep%nftype
  4432. ! current type:
  4433. ftype = filep%ftypes(iftype)
  4434. ! select appropriate routine for each type:
  4435. select case ( ftype )
  4436. #ifdef with_hdf4
  4437. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4438. case ( MDF_HDF4 )
  4439. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4440. ! check ...
  4441. if ( present(map ) ) then
  4442. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4443. TRACEBACK; status=1; return
  4444. end if
  4445. ! fill offset (zero based!), stride, and count :
  4446. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4447. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4448. hdf4_count = 1 ! default singleton dimension
  4449. hdf4_count(1:4) = (/ len(values), shape(values) /)
  4450. ! read:
  4451. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4452. #endif
  4453. #ifdef with_netcdf
  4454. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4455. case ( MDF_NETCDF, MDF_NETCDF4 )
  4456. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4457. ! read values, converted automatically:
  4458. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4459. start, count, stride, map )
  4460. IF_NF90_NOT_OK_RETURN(status=1)
  4461. #endif
  4462. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4463. case default
  4464. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4465. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4466. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4467. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4468. TRACEBACK; status=1; return
  4469. end select
  4470. end do ! file types
  4471. ! ok
  4472. status = 0
  4473. end subroutine MDF_Get_Var_c1_4d
  4474. ! ***
  4475. subroutine MDF_Put_Var_c1_5d( hid, varid, values, status, &
  4476. start, count, stride, map )
  4477. #ifdef with_hdf5_beta
  4478. use HDF5, only : HID_T, HSIZE_T
  4479. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  4480. use HDF5, only : H5T_NATIVE_CHARACTER
  4481. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  4482. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  4483. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  4484. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  4485. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  4486. #endif
  4487. #ifdef with_netcdf
  4488. use NetCDF, only : NF90_Put_Var
  4489. #endif
  4490. ! --- in/out -------------------------------------
  4491. integer, intent(in) :: hid
  4492. integer, intent(in) :: varid
  4493. character(len=*), intent(in) :: values(:,:,:,:)
  4494. integer, intent(out) :: status
  4495. integer, intent(in), optional :: start (:)
  4496. integer, intent(in), optional :: count (:)
  4497. integer, intent(in), optional :: stride(:)
  4498. integer, intent(in), optional :: map (:)
  4499. ! --- const --------------------------------------
  4500. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_5d'
  4501. ! --- external -----------------------------------
  4502. #ifdef with_hdf4
  4503. integer(hdf4_wpi), external :: sfWData
  4504. #endif
  4505. ! --- local --------------------------------------
  4506. type(MDF_File), pointer :: filep
  4507. type(MDF_Var), pointer :: varp
  4508. integer :: iftype
  4509. integer :: ftype
  4510. #ifdef with_hdf4
  4511. integer :: hdf4_offset(MAX_RANK)
  4512. integer :: hdf4_stride(MAX_RANK)
  4513. integer :: hdf4_count(MAX_RANK)
  4514. #endif
  4515. #ifdef with_hdf5_beta
  4516. !integer(HID_T) :: hdf5_type_id
  4517. integer(HID_T) :: hdf5_file_space_id
  4518. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  4519. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  4520. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  4521. #endif
  4522. ! --- begin --------------------------------------
  4523. ! pointer to file structure:
  4524. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4525. IF_NOT_OK_RETURN(status=1)
  4526. ! pointer to variable structure:
  4527. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4528. IF_NOT_OK_RETURN(status=1)
  4529. ! check ...
  4530. if ( size(shape(values)) > varp%ndim ) then
  4531. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  4532. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4533. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4534. TRACEBACK; status=1; return
  4535. end if
  4536. ! check ...
  4537. if ( present(start ) ) then
  4538. if ( size(start ) /= varp%ndim ) then
  4539. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4540. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4541. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4542. TRACEBACK; status=1; return
  4543. end if
  4544. end if
  4545. if ( present(count ) ) then
  4546. if ( size(count ) /= varp%ndim ) then
  4547. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4548. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4549. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4550. TRACEBACK; status=1; return
  4551. end if
  4552. end if
  4553. if ( present(stride ) ) then
  4554. if ( size(stride ) /= varp%ndim ) then
  4555. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4556. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4557. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4558. TRACEBACK; status=1; return
  4559. end if
  4560. end if
  4561. if ( present(map ) ) then
  4562. if ( size(map ) /= varp%ndim ) then
  4563. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4564. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4565. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4566. TRACEBACK; status=1; return
  4567. end if
  4568. end if
  4569. ! loop over file types:
  4570. do iftype = 1, filep%nftype
  4571. ! current type:
  4572. ftype = filep%ftypes(iftype)
  4573. ! select appropriate routine for each type:
  4574. select case ( ftype )
  4575. #ifdef with_hdf4
  4576. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4577. case ( MDF_HDF4 )
  4578. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4579. ! check ...
  4580. if ( present(map ) ) then
  4581. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4582. TRACEBACK; status=1; return
  4583. end if
  4584. ! fill offset (zero based!) and stride with default values:
  4585. hdf4_offset = 0
  4586. hdf4_stride = 1
  4587. ! count is by default the shape; padd with singleton dimensions:
  4588. hdf4_count = 1; hdf4_count(1:5) = (/len(values),shape(values)/)
  4589. ! replace by optional arguments if necessary:
  4590. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4591. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4592. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  4593. ! write:
  4594. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4595. #endif
  4596. #ifdef with_hdf5_beta
  4597. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4598. case ( MDF_HDF5 )
  4599. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4600. ! check ...
  4601. if ( present(map ) ) then
  4602. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  4603. TRACEBACK; status=1; return
  4604. end if
  4605. ! fill offset (zero based!), stride, and count :
  4606. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  4607. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  4608. hdf5_count = 1 ! default singleton dimension
  4609. if ( present(count) ) then
  4610. hdf5_count(1:varp%ndim) = count
  4611. else
  4612. hdf5_count(1:5) = (/len(values),shape(values)/)
  4613. end if
  4614. ! new dimension:
  4615. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  4616. ! target data space in file:
  4617. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  4618. IF_NOT_OK_RETURN(status=1)
  4619. ! chunked dataset ?
  4620. if ( varp%hdf5_chunked ) then
  4621. ! reset extend:
  4622. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  4623. IF_NOT_OK_RETURN(status=1)
  4624. end if
  4625. ! select hyperslab:
  4626. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  4627. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  4628. stride=hdf5_stride(1:varp%ndim) )
  4629. ! write data:
  4630. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  4631. int(shape(values),kind=HSIZE_T), status, &
  4632. file_space_id=hdf5_file_space_id )
  4633. IF_NOT_OK_RETURN(status=1)
  4634. ! release data space:
  4635. call H5SClose_f( hdf5_file_space_id, status )
  4636. IF_NOT_OK_RETURN(status=1)
  4637. #endif
  4638. #ifdef with_netcdf
  4639. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4640. case ( MDF_NETCDF, MDF_NETCDF4 )
  4641. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4642. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4643. start, count, stride, map )
  4644. IF_NF90_NOT_OK_RETURN(status=1)
  4645. ! just put; let netcdf library convert the right kind:
  4646. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4647. ! start, count, stride, map )
  4648. !IF_NF90_NOT_OK_RETURN(status=1)
  4649. #endif
  4650. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4651. case default
  4652. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4653. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4654. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4655. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4656. TRACEBACK; status=1; return
  4657. end select
  4658. end do ! file types
  4659. ! ok
  4660. status = 0
  4661. end subroutine MDF_Put_Var_c1_5d
  4662. ! ***
  4663. subroutine MDF_Get_Var_c1_5d( hid, varid, values, status, &
  4664. start, count, stride, map )
  4665. #ifdef with_netcdf
  4666. use NetCDF, only : NF90_Get_Var
  4667. #endif
  4668. ! --- in/out -------------------------------------
  4669. integer, intent(in) :: hid
  4670. integer, intent(in) :: varid
  4671. character(len=*), intent(out) :: values(:,:,:,:)
  4672. integer, intent(out) :: status
  4673. integer, intent(in), optional :: start (:)
  4674. integer, intent(in), optional :: count (:)
  4675. integer, intent(in), optional :: stride(:)
  4676. integer, intent(in), optional :: map (:)
  4677. ! --- const --------------------------------------
  4678. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_5d'
  4679. ! --- external -----------------------------------
  4680. #ifdef with_hdf4
  4681. integer(hdf4_wpi), external :: sfRData
  4682. #endif
  4683. ! --- local --------------------------------------
  4684. type(MDF_File), pointer :: filep
  4685. type(MDF_Var), pointer :: varp
  4686. integer :: iftype
  4687. integer :: ftype
  4688. #ifdef with_hdf4
  4689. integer :: hdf4_offset(MAX_RANK)
  4690. integer :: hdf4_stride(MAX_RANK)
  4691. integer :: hdf4_count(MAX_RANK)
  4692. #endif
  4693. ! --- begin --------------------------------------
  4694. ! pointer to file structure:
  4695. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4696. IF_NOT_OK_RETURN(status=1)
  4697. ! pointer to variable structure:
  4698. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4699. IF_NOT_OK_RETURN(status=1)
  4700. ! check ...
  4701. if ( size(shape(values)) > varp%ndim ) then
  4702. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  4703. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4704. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4705. TRACEBACK; status=1; return
  4706. end if
  4707. ! check ...
  4708. if ( present(start ) ) then
  4709. if ( size(start ) /= varp%ndim ) then
  4710. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4711. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4712. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4713. TRACEBACK; status=1; return
  4714. end if
  4715. end if
  4716. if ( present(count ) ) then
  4717. if ( size(count ) /= varp%ndim ) then
  4718. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4719. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4720. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4721. TRACEBACK; status=1; return
  4722. end if
  4723. end if
  4724. if ( present(stride ) ) then
  4725. if ( size(stride ) /= varp%ndim ) then
  4726. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4727. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4728. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4729. TRACEBACK; status=1; return
  4730. end if
  4731. end if
  4732. if ( present(map ) ) then
  4733. if ( size(map ) /= varp%ndim ) then
  4734. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4735. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4736. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4737. TRACEBACK; status=1; return
  4738. end if
  4739. end if
  4740. ! loop over file types:
  4741. do iftype = 1, filep%nftype
  4742. ! current type:
  4743. ftype = filep%ftypes(iftype)
  4744. ! select appropriate routine for each type:
  4745. select case ( ftype )
  4746. #ifdef with_hdf4
  4747. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4748. case ( MDF_HDF4 )
  4749. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4750. ! check ...
  4751. if ( present(map ) ) then
  4752. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4753. TRACEBACK; status=1; return
  4754. end if
  4755. ! fill offset (zero based!), stride, and count :
  4756. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4757. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4758. hdf4_count = 1 ! default singleton dimension
  4759. hdf4_count(1:5) = (/ len(values), shape(values) /)
  4760. ! read:
  4761. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4762. #endif
  4763. #ifdef with_netcdf
  4764. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4765. case ( MDF_NETCDF, MDF_NETCDF4 )
  4766. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4767. ! read values, converted automatically:
  4768. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4769. start, count, stride, map )
  4770. IF_NF90_NOT_OK_RETURN(status=1)
  4771. #endif
  4772. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4773. case default
  4774. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4775. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4776. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4777. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4778. TRACEBACK; status=1; return
  4779. end select
  4780. end do ! file types
  4781. ! ok
  4782. status = 0
  4783. end subroutine MDF_Get_Var_c1_5d
  4784. ! ***
  4785. subroutine MDF_Put_Var_c1_6d( hid, varid, values, status, &
  4786. start, count, stride, map )
  4787. #ifdef with_hdf5_beta
  4788. use HDF5, only : HID_T, HSIZE_T
  4789. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  4790. use HDF5, only : H5T_NATIVE_CHARACTER
  4791. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  4792. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  4793. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  4794. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  4795. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  4796. #endif
  4797. #ifdef with_netcdf
  4798. use NetCDF, only : NF90_Put_Var
  4799. #endif
  4800. ! --- in/out -------------------------------------
  4801. integer, intent(in) :: hid
  4802. integer, intent(in) :: varid
  4803. character(len=*), intent(in) :: values(:,:,:,:,:)
  4804. integer, intent(out) :: status
  4805. integer, intent(in), optional :: start (:)
  4806. integer, intent(in), optional :: count (:)
  4807. integer, intent(in), optional :: stride(:)
  4808. integer, intent(in), optional :: map (:)
  4809. ! --- const --------------------------------------
  4810. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_6d'
  4811. ! --- external -----------------------------------
  4812. #ifdef with_hdf4
  4813. integer(hdf4_wpi), external :: sfWData
  4814. #endif
  4815. ! --- local --------------------------------------
  4816. type(MDF_File), pointer :: filep
  4817. type(MDF_Var), pointer :: varp
  4818. integer :: iftype
  4819. integer :: ftype
  4820. #ifdef with_hdf4
  4821. integer :: hdf4_offset(MAX_RANK)
  4822. integer :: hdf4_stride(MAX_RANK)
  4823. integer :: hdf4_count(MAX_RANK)
  4824. #endif
  4825. #ifdef with_hdf5_beta
  4826. !integer(HID_T) :: hdf5_type_id
  4827. integer(HID_T) :: hdf5_file_space_id
  4828. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  4829. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  4830. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  4831. #endif
  4832. ! --- begin --------------------------------------
  4833. ! pointer to file structure:
  4834. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  4835. IF_NOT_OK_RETURN(status=1)
  4836. ! pointer to variable structure:
  4837. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  4838. IF_NOT_OK_RETURN(status=1)
  4839. ! check ...
  4840. if ( size(shape(values)) > varp%ndim ) then
  4841. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  4842. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  4843. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  4844. TRACEBACK; status=1; return
  4845. end if
  4846. ! check ...
  4847. if ( present(start ) ) then
  4848. if ( size(start ) /= varp%ndim ) then
  4849. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4850. write (gol,'(" size start : ",i6)') size(start ); call goErr
  4851. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4852. TRACEBACK; status=1; return
  4853. end if
  4854. end if
  4855. if ( present(count ) ) then
  4856. if ( size(count ) /= varp%ndim ) then
  4857. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4858. write (gol,'(" size count : ",i6)') size(count ); call goErr
  4859. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4860. TRACEBACK; status=1; return
  4861. end if
  4862. end if
  4863. if ( present(stride ) ) then
  4864. if ( size(stride ) /= varp%ndim ) then
  4865. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4866. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  4867. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4868. TRACEBACK; status=1; return
  4869. end if
  4870. end if
  4871. if ( present(map ) ) then
  4872. if ( size(map ) /= varp%ndim ) then
  4873. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  4874. write (gol,'(" size map : ",i6)') size(map ); call goErr
  4875. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  4876. TRACEBACK; status=1; return
  4877. end if
  4878. end if
  4879. ! loop over file types:
  4880. do iftype = 1, filep%nftype
  4881. ! current type:
  4882. ftype = filep%ftypes(iftype)
  4883. ! select appropriate routine for each type:
  4884. select case ( ftype )
  4885. #ifdef with_hdf4
  4886. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4887. case ( MDF_HDF4 )
  4888. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4889. ! check ...
  4890. if ( present(map ) ) then
  4891. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  4892. TRACEBACK; status=1; return
  4893. end if
  4894. ! fill offset (zero based!) and stride with default values:
  4895. hdf4_offset = 0
  4896. hdf4_stride = 1
  4897. ! count is by default the shape; padd with singleton dimensions:
  4898. hdf4_count = 1; hdf4_count(1:6) = (/len(values),shape(values)/)
  4899. ! replace by optional arguments if necessary:
  4900. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  4901. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  4902. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  4903. ! write:
  4904. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  4905. #endif
  4906. #ifdef with_hdf5_beta
  4907. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4908. case ( MDF_HDF5 )
  4909. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4910. ! check ...
  4911. if ( present(map ) ) then
  4912. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  4913. TRACEBACK; status=1; return
  4914. end if
  4915. ! fill offset (zero based!), stride, and count :
  4916. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  4917. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  4918. hdf5_count = 1 ! default singleton dimension
  4919. if ( present(count) ) then
  4920. hdf5_count(1:varp%ndim) = count
  4921. else
  4922. hdf5_count(1:6) = (/len(values),shape(values)/)
  4923. end if
  4924. ! new dimension:
  4925. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  4926. ! target data space in file:
  4927. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  4928. IF_NOT_OK_RETURN(status=1)
  4929. ! chunked dataset ?
  4930. if ( varp%hdf5_chunked ) then
  4931. ! reset extend:
  4932. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  4933. IF_NOT_OK_RETURN(status=1)
  4934. end if
  4935. ! select hyperslab:
  4936. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  4937. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  4938. stride=hdf5_stride(1:varp%ndim) )
  4939. ! write data:
  4940. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  4941. int(shape(values),kind=HSIZE_T), status, &
  4942. file_space_id=hdf5_file_space_id )
  4943. IF_NOT_OK_RETURN(status=1)
  4944. ! release data space:
  4945. call H5SClose_f( hdf5_file_space_id, status )
  4946. IF_NOT_OK_RETURN(status=1)
  4947. #endif
  4948. #ifdef with_netcdf
  4949. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4950. case ( MDF_NETCDF, MDF_NETCDF4 )
  4951. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4952. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4953. start, count, stride, map )
  4954. IF_NF90_NOT_OK_RETURN(status=1)
  4955. ! just put; let netcdf library convert the right kind:
  4956. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  4957. ! start, count, stride, map )
  4958. !IF_NF90_NOT_OK_RETURN(status=1)
  4959. #endif
  4960. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4961. case default
  4962. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  4963. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  4964. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  4965. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  4966. TRACEBACK; status=1; return
  4967. end select
  4968. end do ! file types
  4969. ! ok
  4970. status = 0
  4971. end subroutine MDF_Put_Var_c1_6d
  4972. ! ***
  4973. subroutine MDF_Get_Var_c1_6d( hid, varid, values, status, &
  4974. start, count, stride, map )
  4975. #ifdef with_netcdf
  4976. use NetCDF, only : NF90_Get_Var
  4977. #endif
  4978. ! --- in/out -------------------------------------
  4979. integer, intent(in) :: hid
  4980. integer, intent(in) :: varid
  4981. character(len=*), intent(out) :: values(:,:,:,:,:)
  4982. integer, intent(out) :: status
  4983. integer, intent(in), optional :: start (:)
  4984. integer, intent(in), optional :: count (:)
  4985. integer, intent(in), optional :: stride(:)
  4986. integer, intent(in), optional :: map (:)
  4987. ! --- const --------------------------------------
  4988. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_6d'
  4989. ! --- external -----------------------------------
  4990. #ifdef with_hdf4
  4991. integer(hdf4_wpi), external :: sfRData
  4992. #endif
  4993. ! --- local --------------------------------------
  4994. type(MDF_File), pointer :: filep
  4995. type(MDF_Var), pointer :: varp
  4996. integer :: iftype
  4997. integer :: ftype
  4998. #ifdef with_hdf4
  4999. integer :: hdf4_offset(MAX_RANK)
  5000. integer :: hdf4_stride(MAX_RANK)
  5001. integer :: hdf4_count(MAX_RANK)
  5002. #endif
  5003. ! --- begin --------------------------------------
  5004. ! pointer to file structure:
  5005. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5006. IF_NOT_OK_RETURN(status=1)
  5007. ! pointer to variable structure:
  5008. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5009. IF_NOT_OK_RETURN(status=1)
  5010. ! check ...
  5011. if ( size(shape(values)) > varp%ndim ) then
  5012. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  5013. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5014. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5015. TRACEBACK; status=1; return
  5016. end if
  5017. ! check ...
  5018. if ( present(start ) ) then
  5019. if ( size(start ) /= varp%ndim ) then
  5020. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5021. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5022. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5023. TRACEBACK; status=1; return
  5024. end if
  5025. end if
  5026. if ( present(count ) ) then
  5027. if ( size(count ) /= varp%ndim ) then
  5028. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5029. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5030. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5031. TRACEBACK; status=1; return
  5032. end if
  5033. end if
  5034. if ( present(stride ) ) then
  5035. if ( size(stride ) /= varp%ndim ) then
  5036. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5037. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5038. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5039. TRACEBACK; status=1; return
  5040. end if
  5041. end if
  5042. if ( present(map ) ) then
  5043. if ( size(map ) /= varp%ndim ) then
  5044. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5045. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5046. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5047. TRACEBACK; status=1; return
  5048. end if
  5049. end if
  5050. ! loop over file types:
  5051. do iftype = 1, filep%nftype
  5052. ! current type:
  5053. ftype = filep%ftypes(iftype)
  5054. ! select appropriate routine for each type:
  5055. select case ( ftype )
  5056. #ifdef with_hdf4
  5057. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5058. case ( MDF_HDF4 )
  5059. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5060. ! check ...
  5061. if ( present(map ) ) then
  5062. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5063. TRACEBACK; status=1; return
  5064. end if
  5065. ! fill offset (zero based!), stride, and count :
  5066. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5067. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5068. hdf4_count = 1 ! default singleton dimension
  5069. hdf4_count(1:6) = (/ len(values), shape(values) /)
  5070. ! read:
  5071. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  5072. #endif
  5073. #ifdef with_netcdf
  5074. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5075. case ( MDF_NETCDF, MDF_NETCDF4 )
  5076. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5077. ! read values, converted automatically:
  5078. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5079. start, count, stride, map )
  5080. IF_NF90_NOT_OK_RETURN(status=1)
  5081. #endif
  5082. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5083. case default
  5084. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5085. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  5086. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  5087. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  5088. TRACEBACK; status=1; return
  5089. end select
  5090. end do ! file types
  5091. ! ok
  5092. status = 0
  5093. end subroutine MDF_Get_Var_c1_6d
  5094. ! ***
  5095. subroutine MDF_Put_Var_c1_7d( hid, varid, values, status, &
  5096. start, count, stride, map )
  5097. #ifdef with_hdf5_beta
  5098. use HDF5, only : HID_T, HSIZE_T
  5099. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  5100. use HDF5, only : H5T_NATIVE_CHARACTER
  5101. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  5102. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  5103. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  5104. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  5105. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  5106. #endif
  5107. #ifdef with_netcdf
  5108. use NetCDF, only : NF90_Put_Var
  5109. #endif
  5110. ! --- in/out -------------------------------------
  5111. integer, intent(in) :: hid
  5112. integer, intent(in) :: varid
  5113. character(len=*), intent(in) :: values(:,:,:,:,:,:)
  5114. integer, intent(out) :: status
  5115. integer, intent(in), optional :: start (:)
  5116. integer, intent(in), optional :: count (:)
  5117. integer, intent(in), optional :: stride(:)
  5118. integer, intent(in), optional :: map (:)
  5119. ! --- const --------------------------------------
  5120. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_7d'
  5121. ! --- external -----------------------------------
  5122. #ifdef with_hdf4
  5123. integer(hdf4_wpi), external :: sfWData
  5124. #endif
  5125. ! --- local --------------------------------------
  5126. type(MDF_File), pointer :: filep
  5127. type(MDF_Var), pointer :: varp
  5128. integer :: iftype
  5129. integer :: ftype
  5130. #ifdef with_hdf4
  5131. integer :: hdf4_offset(MAX_RANK)
  5132. integer :: hdf4_stride(MAX_RANK)
  5133. integer :: hdf4_count(MAX_RANK)
  5134. #endif
  5135. #ifdef with_hdf5_beta
  5136. !integer(HID_T) :: hdf5_type_id
  5137. integer(HID_T) :: hdf5_file_space_id
  5138. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  5139. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  5140. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  5141. #endif
  5142. ! --- begin --------------------------------------
  5143. ! pointer to file structure:
  5144. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5145. IF_NOT_OK_RETURN(status=1)
  5146. ! pointer to variable structure:
  5147. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5148. IF_NOT_OK_RETURN(status=1)
  5149. ! check ...
  5150. if ( size(shape(values)) > varp%ndim ) then
  5151. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  5152. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5153. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5154. TRACEBACK; status=1; return
  5155. end if
  5156. ! check ...
  5157. if ( present(start ) ) then
  5158. if ( size(start ) /= varp%ndim ) then
  5159. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5160. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5161. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5162. TRACEBACK; status=1; return
  5163. end if
  5164. end if
  5165. if ( present(count ) ) then
  5166. if ( size(count ) /= varp%ndim ) then
  5167. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5168. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5169. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5170. TRACEBACK; status=1; return
  5171. end if
  5172. end if
  5173. if ( present(stride ) ) then
  5174. if ( size(stride ) /= varp%ndim ) then
  5175. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5176. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5177. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5178. TRACEBACK; status=1; return
  5179. end if
  5180. end if
  5181. if ( present(map ) ) then
  5182. if ( size(map ) /= varp%ndim ) then
  5183. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5184. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5185. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5186. TRACEBACK; status=1; return
  5187. end if
  5188. end if
  5189. ! loop over file types:
  5190. do iftype = 1, filep%nftype
  5191. ! current type:
  5192. ftype = filep%ftypes(iftype)
  5193. ! select appropriate routine for each type:
  5194. select case ( ftype )
  5195. #ifdef with_hdf4
  5196. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5197. case ( MDF_HDF4 )
  5198. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5199. ! check ...
  5200. if ( present(map ) ) then
  5201. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5202. TRACEBACK; status=1; return
  5203. end if
  5204. ! fill offset (zero based!) and stride with default values:
  5205. hdf4_offset = 0
  5206. hdf4_stride = 1
  5207. ! count is by default the shape; padd with singleton dimensions:
  5208. hdf4_count = 1; hdf4_count(1:7) = (/len(values),shape(values)/)
  5209. ! replace by optional arguments if necessary:
  5210. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5211. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5212. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  5213. ! write:
  5214. status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  5215. #endif
  5216. #ifdef with_hdf5_beta
  5217. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5218. case ( MDF_HDF5 )
  5219. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5220. ! check ...
  5221. if ( present(map ) ) then
  5222. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  5223. TRACEBACK; status=1; return
  5224. end if
  5225. ! fill offset (zero based!), stride, and count :
  5226. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  5227. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  5228. hdf5_count = 1 ! default singleton dimension
  5229. if ( present(count) ) then
  5230. hdf5_count(1:varp%ndim) = count
  5231. else
  5232. hdf5_count(1:7) = (/len(values),shape(values)/)
  5233. end if
  5234. ! new dimension:
  5235. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  5236. ! target data space in file:
  5237. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  5238. IF_NOT_OK_RETURN(status=1)
  5239. ! chunked dataset ?
  5240. if ( varp%hdf5_chunked ) then
  5241. ! reset extend:
  5242. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  5243. IF_NOT_OK_RETURN(status=1)
  5244. end if
  5245. ! select hyperslab:
  5246. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  5247. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  5248. stride=hdf5_stride(1:varp%ndim) )
  5249. ! write data:
  5250. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, &
  5251. int(shape(values),kind=HSIZE_T), status, &
  5252. file_space_id=hdf5_file_space_id )
  5253. IF_NOT_OK_RETURN(status=1)
  5254. ! release data space:
  5255. call H5SClose_f( hdf5_file_space_id, status )
  5256. IF_NOT_OK_RETURN(status=1)
  5257. #endif
  5258. #ifdef with_netcdf
  5259. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5260. case ( MDF_NETCDF, MDF_NETCDF4 )
  5261. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5262. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5263. start, count, stride, map )
  5264. IF_NF90_NOT_OK_RETURN(status=1)
  5265. ! just put; let netcdf library convert the right kind:
  5266. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5267. ! start, count, stride, map )
  5268. !IF_NF90_NOT_OK_RETURN(status=1)
  5269. #endif
  5270. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5271. case default
  5272. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5273. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  5274. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  5275. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  5276. TRACEBACK; status=1; return
  5277. end select
  5278. end do ! file types
  5279. ! ok
  5280. status = 0
  5281. end subroutine MDF_Put_Var_c1_7d
  5282. ! ***
  5283. subroutine MDF_Get_Var_c1_7d( hid, varid, values, status, &
  5284. start, count, stride, map )
  5285. #ifdef with_netcdf
  5286. use NetCDF, only : NF90_Get_Var
  5287. #endif
  5288. ! --- in/out -------------------------------------
  5289. integer, intent(in) :: hid
  5290. integer, intent(in) :: varid
  5291. character(len=*), intent(out) :: values(:,:,:,:,:,:)
  5292. integer, intent(out) :: status
  5293. integer, intent(in), optional :: start (:)
  5294. integer, intent(in), optional :: count (:)
  5295. integer, intent(in), optional :: stride(:)
  5296. integer, intent(in), optional :: map (:)
  5297. ! --- const --------------------------------------
  5298. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_7d'
  5299. ! --- external -----------------------------------
  5300. #ifdef with_hdf4
  5301. integer(hdf4_wpi), external :: sfRData
  5302. #endif
  5303. ! --- local --------------------------------------
  5304. type(MDF_File), pointer :: filep
  5305. type(MDF_Var), pointer :: varp
  5306. integer :: iftype
  5307. integer :: ftype
  5308. #ifdef with_hdf4
  5309. integer :: hdf4_offset(MAX_RANK)
  5310. integer :: hdf4_stride(MAX_RANK)
  5311. integer :: hdf4_count(MAX_RANK)
  5312. #endif
  5313. ! --- begin --------------------------------------
  5314. ! pointer to file structure:
  5315. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5316. IF_NOT_OK_RETURN(status=1)
  5317. ! pointer to variable structure:
  5318. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5319. IF_NOT_OK_RETURN(status=1)
  5320. ! check ...
  5321. if ( size(shape(values)) > varp%ndim ) then
  5322. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  5323. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5324. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5325. TRACEBACK; status=1; return
  5326. end if
  5327. ! check ...
  5328. if ( present(start ) ) then
  5329. if ( size(start ) /= varp%ndim ) then
  5330. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5331. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5332. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5333. TRACEBACK; status=1; return
  5334. end if
  5335. end if
  5336. if ( present(count ) ) then
  5337. if ( size(count ) /= varp%ndim ) then
  5338. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5339. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5340. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5341. TRACEBACK; status=1; return
  5342. end if
  5343. end if
  5344. if ( present(stride ) ) then
  5345. if ( size(stride ) /= varp%ndim ) then
  5346. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5347. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5348. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5349. TRACEBACK; status=1; return
  5350. end if
  5351. end if
  5352. if ( present(map ) ) then
  5353. if ( size(map ) /= varp%ndim ) then
  5354. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5355. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5356. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5357. TRACEBACK; status=1; return
  5358. end if
  5359. end if
  5360. ! loop over file types:
  5361. do iftype = 1, filep%nftype
  5362. ! current type:
  5363. ftype = filep%ftypes(iftype)
  5364. ! select appropriate routine for each type:
  5365. select case ( ftype )
  5366. #ifdef with_hdf4
  5367. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5368. case ( MDF_HDF4 )
  5369. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5370. ! check ...
  5371. if ( present(map ) ) then
  5372. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5373. TRACEBACK; status=1; return
  5374. end if
  5375. ! fill offset (zero based!), stride, and count :
  5376. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5377. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5378. hdf4_count = 1 ! default singleton dimension
  5379. hdf4_count(1:7) = (/ len(values), shape(values) /)
  5380. ! read:
  5381. status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values )
  5382. #endif
  5383. #ifdef with_netcdf
  5384. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5385. case ( MDF_NETCDF, MDF_NETCDF4 )
  5386. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5387. ! read values, converted automatically:
  5388. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5389. start, count, stride, map )
  5390. IF_NF90_NOT_OK_RETURN(status=1)
  5391. #endif
  5392. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5393. case default
  5394. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5395. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  5396. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  5397. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  5398. TRACEBACK; status=1; return
  5399. end select
  5400. end do ! file types
  5401. ! ok
  5402. status = 0
  5403. end subroutine MDF_Get_Var_c1_7d
  5404. ! ***
  5405. subroutine MDF_Put_Var_i1_1d( hid, varid, values, status, &
  5406. start, count, stride, map )
  5407. #ifdef with_hdf5_beta
  5408. use HDF5, only : HID_T, HSIZE_T
  5409. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  5410. use HDF5, only : H5T_NATIVE_CHARACTER
  5411. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  5412. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  5413. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  5414. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  5415. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  5416. #endif
  5417. #ifdef with_netcdf
  5418. use NetCDF, only : NF90_Put_Var
  5419. #endif
  5420. ! --- in/out -------------------------------------
  5421. integer, intent(in) :: hid
  5422. integer, intent(in) :: varid
  5423. integer(1), intent(in) :: values(:)
  5424. integer, intent(out) :: status
  5425. integer, intent(in), optional :: start (:)
  5426. integer, intent(in), optional :: count (:)
  5427. integer, intent(in), optional :: stride(:)
  5428. integer, intent(in), optional :: map (:)
  5429. ! --- const --------------------------------------
  5430. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_1d'
  5431. ! --- external -----------------------------------
  5432. #ifdef with_hdf4
  5433. integer(hdf4_wpi), external :: sfWData
  5434. #endif
  5435. ! --- local --------------------------------------
  5436. type(MDF_File), pointer :: filep
  5437. type(MDF_Var), pointer :: varp
  5438. integer :: iftype
  5439. integer :: ftype
  5440. #ifdef with_hdf4
  5441. integer :: hdf4_offset(MAX_RANK)
  5442. integer :: hdf4_stride(MAX_RANK)
  5443. integer :: hdf4_count(MAX_RANK)
  5444. #endif
  5445. #ifdef with_hdf5_beta
  5446. !integer(HID_T) :: hdf5_type_id
  5447. integer(HID_T) :: hdf5_file_space_id
  5448. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  5449. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  5450. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  5451. #endif
  5452. integer(1), allocatable :: values_int1(:)
  5453. integer(2), allocatable :: values_int2(:)
  5454. integer(4), allocatable :: values_int4(:)
  5455. integer(8), allocatable :: values_int8(:)
  5456. real(4), allocatable :: values_real4(:)
  5457. real(8), allocatable :: values_real8(:)
  5458. ! --- begin --------------------------------------
  5459. ! pointer to file structure:
  5460. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5461. IF_NOT_OK_RETURN(status=1)
  5462. ! pointer to variable structure:
  5463. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5464. IF_NOT_OK_RETURN(status=1)
  5465. ! check ...
  5466. if ( size(shape(values)) > varp%ndim ) then
  5467. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  5468. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5469. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5470. TRACEBACK; status=1; return
  5471. end if
  5472. ! check ...
  5473. if ( present(start ) ) then
  5474. if ( size(start ) /= varp%ndim ) then
  5475. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5476. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5477. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5478. TRACEBACK; status=1; return
  5479. end if
  5480. end if
  5481. if ( present(count ) ) then
  5482. if ( size(count ) /= varp%ndim ) then
  5483. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5484. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5485. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5486. TRACEBACK; status=1; return
  5487. end if
  5488. end if
  5489. if ( present(stride ) ) then
  5490. if ( size(stride ) /= varp%ndim ) then
  5491. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5492. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5493. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5494. TRACEBACK; status=1; return
  5495. end if
  5496. end if
  5497. if ( present(map ) ) then
  5498. if ( size(map ) /= varp%ndim ) then
  5499. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5500. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5501. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5502. TRACEBACK; status=1; return
  5503. end if
  5504. end if
  5505. ! loop over file types:
  5506. do iftype = 1, filep%nftype
  5507. ! current type:
  5508. ftype = filep%ftypes(iftype)
  5509. ! select appropriate routine for each type:
  5510. select case ( ftype )
  5511. #ifdef with_hdf4
  5512. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5513. case ( MDF_HDF4 )
  5514. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5515. ! check ...
  5516. if ( present(map ) ) then
  5517. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5518. TRACEBACK; status=1; return
  5519. end if
  5520. ! fill offset (zero based!) and stride with default values:
  5521. hdf4_offset = 0
  5522. hdf4_stride = 1
  5523. ! count is by default the shape; padd with singleton dimensions:
  5524. hdf4_count = 1; hdf4_count(1:1) = shape(values)
  5525. ! replace by optional arguments if necessary:
  5526. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5527. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5528. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  5529. ! test target type;
  5530. ! convert to required kind before entering sfWData,
  5531. ! otherwise segmentation faults on some machines ...
  5532. select case ( varp%xtype )
  5533. case ( MDF_BYTE )
  5534. allocate( values_int1(size(values,1)) )
  5535. values_int1 = int(values,kind=1)
  5536. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5537. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  5538. deallocate( values_int1 )
  5539. case ( MDF_SHORT )
  5540. allocate( values_int2(size(values,1)) )
  5541. values_int2 = int(values,kind=2)
  5542. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5543. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  5544. deallocate( values_int2 )
  5545. case ( MDF_INT )
  5546. allocate( values_int4(size(values,1)) )
  5547. values_int4 = int(values,kind=4)
  5548. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5549. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  5550. deallocate( values_int4 )
  5551. case ( MDF_FLOAT )
  5552. allocate( values_real4(size(values,1)) )
  5553. values_real4 = real(values,kind=4)
  5554. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5555. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  5556. deallocate( values_real4 )
  5557. case ( MDF_DOUBLE )
  5558. allocate( values_real8(size(values,1)) )
  5559. values_real8 = real(values,kind=8)
  5560. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5561. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  5562. deallocate( values_real8 )
  5563. case default
  5564. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  5565. TRACEBACK; status=1; return
  5566. end select
  5567. if ( status == FAIL ) then
  5568. write (gol,'("writing hdf4 data set:")'); call goErr
  5569. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  5570. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  5571. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  5572. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  5573. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  5574. write (gol,'(" size : ",i12)') size(values); call goErr
  5575. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  5576. TRACEBACK; status=1; return
  5577. end if
  5578. #endif
  5579. #ifdef with_hdf5_beta
  5580. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5581. case ( MDF_HDF5 )
  5582. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5583. ! check ...
  5584. if ( present(map ) ) then
  5585. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  5586. TRACEBACK; status=1; return
  5587. end if
  5588. ! fill offset (zero based!), stride, and count :
  5589. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  5590. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  5591. hdf5_count = 1 ! default singleton dimension
  5592. if ( present(count) ) then
  5593. hdf5_count(1:varp%ndim) = count
  5594. else
  5595. hdf5_count(1:1) = shape(values)
  5596. end if
  5597. ! new dimension:
  5598. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  5599. ! target data space in file:
  5600. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  5601. IF_NOT_OK_RETURN(status=1)
  5602. ! chunked dataset ?
  5603. if ( varp%hdf5_chunked ) then
  5604. ! reset extend:
  5605. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  5606. IF_NOT_OK_RETURN(status=1)
  5607. end if
  5608. ! select hyperslab:
  5609. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  5610. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  5611. stride=hdf5_stride(1:varp%ndim) )
  5612. ! write data:
  5613. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  5614. int(shape(values),kind=HSIZE_T), status, &
  5615. file_space_id=hdf5_file_space_id )
  5616. IF_NOT_OK_RETURN(status=1)
  5617. ! release data space:
  5618. call H5SClose_f( hdf5_file_space_id, status )
  5619. IF_NOT_OK_RETURN(status=1)
  5620. #endif
  5621. #ifdef with_netcdf
  5622. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5623. case ( MDF_NETCDF, MDF_NETCDF4 )
  5624. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5625. ! test target type:
  5626. ! convert to required kind before entering NF90_Put_Var,
  5627. ! otherwise segmentation faults on some machines ...
  5628. select case ( varp%xtype )
  5629. case ( MDF_BYTE )
  5630. allocate( values_int1(size(values,1)) )
  5631. values_int1 = int(values,kind=1)
  5632. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  5633. start, count, stride, map )
  5634. IF_NF90_NOT_OK_RETURN(status=1)
  5635. deallocate( values_int1 )
  5636. case ( MDF_SHORT )
  5637. allocate( values_int2(size(values,1)) )
  5638. values_int2 = int(values,kind=2)
  5639. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  5640. start, count, stride, map )
  5641. IF_NF90_NOT_OK_RETURN(status=1)
  5642. deallocate( values_int2 )
  5643. case ( MDF_INT )
  5644. allocate( values_int4(size(values,1)) )
  5645. values_int4 = int(values,kind=4)
  5646. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  5647. start, count, stride, map )
  5648. IF_NF90_NOT_OK_RETURN(status=1)
  5649. deallocate( values_int4 )
  5650. case ( MDF_FLOAT )
  5651. allocate( values_real4(size(values,1)) )
  5652. values_real4 = real(values,kind=4)
  5653. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  5654. start, count, stride, map )
  5655. IF_NF90_NOT_OK_RETURN(status=1)
  5656. deallocate( values_real4 )
  5657. case ( MDF_DOUBLE )
  5658. allocate( values_real8(size(values,1)) )
  5659. values_real8 = real(values,kind=8)
  5660. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  5661. start, count, stride, map )
  5662. IF_NF90_NOT_OK_RETURN(status=1)
  5663. deallocate( values_real8 )
  5664. case default
  5665. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  5666. TRACEBACK; status=1; return
  5667. end select
  5668. ! just put; let netcdf library convert the right kind:
  5669. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5670. ! start, count, stride, map )
  5671. !IF_NF90_NOT_OK_RETURN(status=1)
  5672. #endif
  5673. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5674. case default
  5675. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5676. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  5677. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  5678. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  5679. TRACEBACK; status=1; return
  5680. end select
  5681. end do ! file types
  5682. ! ok
  5683. status = 0
  5684. end subroutine MDF_Put_Var_i1_1d
  5685. ! ***
  5686. subroutine MDF_Get_Var_i1_1d( hid, varid, values, status, &
  5687. start, count, stride, map )
  5688. #ifdef with_netcdf
  5689. use NetCDF, only : NF90_Get_Var
  5690. #endif
  5691. ! --- in/out -------------------------------------
  5692. integer, intent(in) :: hid
  5693. integer, intent(in) :: varid
  5694. integer(1), intent(out) :: values(:)
  5695. integer, intent(out) :: status
  5696. integer, intent(in), optional :: start (:)
  5697. integer, intent(in), optional :: count (:)
  5698. integer, intent(in), optional :: stride(:)
  5699. integer, intent(in), optional :: map (:)
  5700. ! --- const --------------------------------------
  5701. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_1d'
  5702. ! --- external -----------------------------------
  5703. #ifdef with_hdf4
  5704. integer(hdf4_wpi), external :: sfRData
  5705. #endif
  5706. ! --- local --------------------------------------
  5707. type(MDF_File), pointer :: filep
  5708. type(MDF_Var), pointer :: varp
  5709. integer :: iftype
  5710. integer :: ftype
  5711. #ifdef with_hdf4
  5712. integer :: hdf4_offset(MAX_RANK)
  5713. integer :: hdf4_stride(MAX_RANK)
  5714. integer :: hdf4_count(MAX_RANK)
  5715. integer(1), allocatable :: values_int1(:)
  5716. integer(2), allocatable :: values_int2(:)
  5717. integer(4), allocatable :: values_int4(:)
  5718. integer(8), allocatable :: values_int8(:)
  5719. real(4), allocatable :: values_real4(:)
  5720. real(8), allocatable :: values_real8(:)
  5721. #endif
  5722. ! --- begin --------------------------------------
  5723. ! pointer to file structure:
  5724. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5725. IF_NOT_OK_RETURN(status=1)
  5726. ! pointer to variable structure:
  5727. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5728. IF_NOT_OK_RETURN(status=1)
  5729. ! check ...
  5730. if ( size(shape(values)) > varp%ndim ) then
  5731. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  5732. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5733. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5734. TRACEBACK; status=1; return
  5735. end if
  5736. ! check ...
  5737. if ( present(start ) ) then
  5738. if ( size(start ) /= varp%ndim ) then
  5739. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5740. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5741. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5742. TRACEBACK; status=1; return
  5743. end if
  5744. end if
  5745. if ( present(count ) ) then
  5746. if ( size(count ) /= varp%ndim ) then
  5747. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5748. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5749. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5750. TRACEBACK; status=1; return
  5751. end if
  5752. end if
  5753. if ( present(stride ) ) then
  5754. if ( size(stride ) /= varp%ndim ) then
  5755. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5756. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5757. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5758. TRACEBACK; status=1; return
  5759. end if
  5760. end if
  5761. if ( present(map ) ) then
  5762. if ( size(map ) /= varp%ndim ) then
  5763. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5764. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5765. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5766. TRACEBACK; status=1; return
  5767. end if
  5768. end if
  5769. ! loop over file types:
  5770. do iftype = 1, filep%nftype
  5771. ! current type:
  5772. ftype = filep%ftypes(iftype)
  5773. ! select appropriate routine for each type:
  5774. select case ( ftype )
  5775. #ifdef with_hdf4
  5776. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5777. case ( MDF_HDF4 )
  5778. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5779. ! check ...
  5780. if ( present(map ) ) then
  5781. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5782. TRACEBACK; status=1; return
  5783. end if
  5784. ! fill offset (zero based!), stride, and count :
  5785. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5786. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5787. hdf4_count = 1 ! default singleton dimension
  5788. hdf4_count(1:1) = shape(values)
  5789. ! test source type:
  5790. select case ( varp%hdf4_xtype )
  5791. case ( DFNT_INT8 )
  5792. allocate( values_int1(size(values,1)) )
  5793. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  5794. values = int(values_int1,kind=1)
  5795. deallocate( values_int1 )
  5796. case ( DFNT_INT16 )
  5797. allocate( values_int2(size(values,1)) )
  5798. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  5799. values = int(values_int2,kind=1)
  5800. deallocate( values_int2 )
  5801. case ( DFNT_INT32 )
  5802. allocate( values_int4(size(values,1)) )
  5803. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  5804. values = int(values_int4,kind=1)
  5805. deallocate( values_int4 )
  5806. case ( DFNT_INT64 )
  5807. allocate( values_int8(size(values,1)) )
  5808. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  5809. values = int(values_int8,kind=1)
  5810. deallocate( values_int8 )
  5811. case ( DFNT_FLOAT32 )
  5812. allocate( values_real4(size(values,1)) )
  5813. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  5814. values = int(values_real4,kind=1)
  5815. deallocate( values_real4 )
  5816. case ( DFNT_FLOAT64 )
  5817. allocate( values_real8(size(values,1)) )
  5818. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  5819. values = int(values_real8,kind=1)
  5820. deallocate( values_real8 )
  5821. case default
  5822. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  5823. TRACEBACK; status=1; return
  5824. end select
  5825. if ( status == FAIL ) then
  5826. write (gol,'("reading hdf4 data set:")'); call goErr
  5827. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  5828. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  5829. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  5830. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  5831. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  5832. write (gol,'(" size : ",i6)') size(values); call goErr
  5833. TRACEBACK; status=1; return
  5834. end if
  5835. #endif
  5836. #ifdef with_netcdf
  5837. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5838. case ( MDF_NETCDF, MDF_NETCDF4 )
  5839. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5840. ! read values, converted automatically:
  5841. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  5842. start, count, stride, map )
  5843. IF_NF90_NOT_OK_RETURN(status=1)
  5844. #endif
  5845. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5846. case default
  5847. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5848. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  5849. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  5850. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  5851. TRACEBACK; status=1; return
  5852. end select
  5853. end do ! file types
  5854. ! ok
  5855. status = 0
  5856. end subroutine MDF_Get_Var_i1_1d
  5857. ! ***
  5858. subroutine MDF_Put_Var_i1_2d( hid, varid, values, status, &
  5859. start, count, stride, map )
  5860. #ifdef with_hdf5_beta
  5861. use HDF5, only : HID_T, HSIZE_T
  5862. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  5863. use HDF5, only : H5T_NATIVE_CHARACTER
  5864. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  5865. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  5866. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  5867. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  5868. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  5869. #endif
  5870. #ifdef with_netcdf
  5871. use NetCDF, only : NF90_Put_Var
  5872. #endif
  5873. ! --- in/out -------------------------------------
  5874. integer, intent(in) :: hid
  5875. integer, intent(in) :: varid
  5876. integer(1), intent(in) :: values(:,:)
  5877. integer, intent(out) :: status
  5878. integer, intent(in), optional :: start (:)
  5879. integer, intent(in), optional :: count (:)
  5880. integer, intent(in), optional :: stride(:)
  5881. integer, intent(in), optional :: map (:)
  5882. ! --- const --------------------------------------
  5883. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_2d'
  5884. ! --- external -----------------------------------
  5885. #ifdef with_hdf4
  5886. integer(hdf4_wpi), external :: sfWData
  5887. #endif
  5888. ! --- local --------------------------------------
  5889. type(MDF_File), pointer :: filep
  5890. type(MDF_Var), pointer :: varp
  5891. integer :: iftype
  5892. integer :: ftype
  5893. #ifdef with_hdf4
  5894. integer :: hdf4_offset(MAX_RANK)
  5895. integer :: hdf4_stride(MAX_RANK)
  5896. integer :: hdf4_count(MAX_RANK)
  5897. #endif
  5898. #ifdef with_hdf5_beta
  5899. !integer(HID_T) :: hdf5_type_id
  5900. integer(HID_T) :: hdf5_file_space_id
  5901. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  5902. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  5903. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  5904. #endif
  5905. integer(1), allocatable :: values_int1(:,:)
  5906. integer(2), allocatable :: values_int2(:,:)
  5907. integer(4), allocatable :: values_int4(:,:)
  5908. integer(8), allocatable :: values_int8(:,:)
  5909. real(4), allocatable :: values_real4(:,:)
  5910. real(8), allocatable :: values_real8(:,:)
  5911. ! --- begin --------------------------------------
  5912. ! pointer to file structure:
  5913. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  5914. IF_NOT_OK_RETURN(status=1)
  5915. ! pointer to variable structure:
  5916. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  5917. IF_NOT_OK_RETURN(status=1)
  5918. ! check ...
  5919. if ( size(shape(values)) > varp%ndim ) then
  5920. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  5921. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  5922. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  5923. TRACEBACK; status=1; return
  5924. end if
  5925. ! check ...
  5926. if ( present(start ) ) then
  5927. if ( size(start ) /= varp%ndim ) then
  5928. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5929. write (gol,'(" size start : ",i6)') size(start ); call goErr
  5930. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5931. TRACEBACK; status=1; return
  5932. end if
  5933. end if
  5934. if ( present(count ) ) then
  5935. if ( size(count ) /= varp%ndim ) then
  5936. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5937. write (gol,'(" size count : ",i6)') size(count ); call goErr
  5938. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5939. TRACEBACK; status=1; return
  5940. end if
  5941. end if
  5942. if ( present(stride ) ) then
  5943. if ( size(stride ) /= varp%ndim ) then
  5944. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5945. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  5946. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5947. TRACEBACK; status=1; return
  5948. end if
  5949. end if
  5950. if ( present(map ) ) then
  5951. if ( size(map ) /= varp%ndim ) then
  5952. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  5953. write (gol,'(" size map : ",i6)') size(map ); call goErr
  5954. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  5955. TRACEBACK; status=1; return
  5956. end if
  5957. end if
  5958. ! loop over file types:
  5959. do iftype = 1, filep%nftype
  5960. ! current type:
  5961. ftype = filep%ftypes(iftype)
  5962. ! select appropriate routine for each type:
  5963. select case ( ftype )
  5964. #ifdef with_hdf4
  5965. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5966. case ( MDF_HDF4 )
  5967. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  5968. ! check ...
  5969. if ( present(map ) ) then
  5970. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  5971. TRACEBACK; status=1; return
  5972. end if
  5973. ! fill offset (zero based!) and stride with default values:
  5974. hdf4_offset = 0
  5975. hdf4_stride = 1
  5976. ! count is by default the shape; padd with singleton dimensions:
  5977. hdf4_count = 1; hdf4_count(1:2) = shape(values)
  5978. ! replace by optional arguments if necessary:
  5979. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  5980. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  5981. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  5982. ! test target type;
  5983. ! convert to required kind before entering sfWData,
  5984. ! otherwise segmentation faults on some machines ...
  5985. select case ( varp%xtype )
  5986. case ( MDF_BYTE )
  5987. allocate( values_int1(size(values,1),size(values,2)) )
  5988. values_int1 = int(values,kind=1)
  5989. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5990. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  5991. deallocate( values_int1 )
  5992. case ( MDF_SHORT )
  5993. allocate( values_int2(size(values,1),size(values,2)) )
  5994. values_int2 = int(values,kind=2)
  5995. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  5996. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  5997. deallocate( values_int2 )
  5998. case ( MDF_INT )
  5999. allocate( values_int4(size(values,1),size(values,2)) )
  6000. values_int4 = int(values,kind=4)
  6001. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6002. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  6003. deallocate( values_int4 )
  6004. case ( MDF_FLOAT )
  6005. allocate( values_real4(size(values,1),size(values,2)) )
  6006. values_real4 = real(values,kind=4)
  6007. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6008. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  6009. deallocate( values_real4 )
  6010. case ( MDF_DOUBLE )
  6011. allocate( values_real8(size(values,1),size(values,2)) )
  6012. values_real8 = real(values,kind=8)
  6013. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6014. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  6015. deallocate( values_real8 )
  6016. case default
  6017. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  6018. TRACEBACK; status=1; return
  6019. end select
  6020. if ( status == FAIL ) then
  6021. write (gol,'("writing hdf4 data set:")'); call goErr
  6022. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  6023. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  6024. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  6025. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  6026. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  6027. write (gol,'(" size : ",i12)') size(values); call goErr
  6028. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  6029. TRACEBACK; status=1; return
  6030. end if
  6031. #endif
  6032. #ifdef with_hdf5_beta
  6033. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6034. case ( MDF_HDF5 )
  6035. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6036. ! check ...
  6037. if ( present(map ) ) then
  6038. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  6039. TRACEBACK; status=1; return
  6040. end if
  6041. ! fill offset (zero based!), stride, and count :
  6042. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  6043. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  6044. hdf5_count = 1 ! default singleton dimension
  6045. if ( present(count) ) then
  6046. hdf5_count(1:varp%ndim) = count
  6047. else
  6048. hdf5_count(1:2) = shape(values)
  6049. end if
  6050. ! new dimension:
  6051. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  6052. ! target data space in file:
  6053. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  6054. IF_NOT_OK_RETURN(status=1)
  6055. ! chunked dataset ?
  6056. if ( varp%hdf5_chunked ) then
  6057. ! reset extend:
  6058. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  6059. IF_NOT_OK_RETURN(status=1)
  6060. end if
  6061. ! select hyperslab:
  6062. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  6063. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  6064. stride=hdf5_stride(1:varp%ndim) )
  6065. ! write data:
  6066. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  6067. int(shape(values),kind=HSIZE_T), status, &
  6068. file_space_id=hdf5_file_space_id )
  6069. IF_NOT_OK_RETURN(status=1)
  6070. ! release data space:
  6071. call H5SClose_f( hdf5_file_space_id, status )
  6072. IF_NOT_OK_RETURN(status=1)
  6073. #endif
  6074. #ifdef with_netcdf
  6075. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6076. case ( MDF_NETCDF, MDF_NETCDF4 )
  6077. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6078. ! test target type:
  6079. ! convert to required kind before entering NF90_Put_Var,
  6080. ! otherwise segmentation faults on some machines ...
  6081. select case ( varp%xtype )
  6082. case ( MDF_BYTE )
  6083. allocate( values_int1(size(values,1),size(values,2)) )
  6084. values_int1 = int(values,kind=1)
  6085. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  6086. start, count, stride, map )
  6087. IF_NF90_NOT_OK_RETURN(status=1)
  6088. deallocate( values_int1 )
  6089. case ( MDF_SHORT )
  6090. allocate( values_int2(size(values,1),size(values,2)) )
  6091. values_int2 = int(values,kind=2)
  6092. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  6093. start, count, stride, map )
  6094. IF_NF90_NOT_OK_RETURN(status=1)
  6095. deallocate( values_int2 )
  6096. case ( MDF_INT )
  6097. allocate( values_int4(size(values,1),size(values,2)) )
  6098. values_int4 = int(values,kind=4)
  6099. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  6100. start, count, stride, map )
  6101. IF_NF90_NOT_OK_RETURN(status=1)
  6102. deallocate( values_int4 )
  6103. case ( MDF_FLOAT )
  6104. allocate( values_real4(size(values,1),size(values,2)) )
  6105. values_real4 = real(values,kind=4)
  6106. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  6107. start, count, stride, map )
  6108. IF_NF90_NOT_OK_RETURN(status=1)
  6109. deallocate( values_real4 )
  6110. case ( MDF_DOUBLE )
  6111. allocate( values_real8(size(values,1),size(values,2)) )
  6112. values_real8 = real(values,kind=8)
  6113. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  6114. start, count, stride, map )
  6115. IF_NF90_NOT_OK_RETURN(status=1)
  6116. deallocate( values_real8 )
  6117. case default
  6118. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  6119. TRACEBACK; status=1; return
  6120. end select
  6121. ! just put; let netcdf library convert the right kind:
  6122. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  6123. ! start, count, stride, map )
  6124. !IF_NF90_NOT_OK_RETURN(status=1)
  6125. #endif
  6126. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6127. case default
  6128. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6129. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  6130. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  6131. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  6132. TRACEBACK; status=1; return
  6133. end select
  6134. end do ! file types
  6135. ! ok
  6136. status = 0
  6137. end subroutine MDF_Put_Var_i1_2d
  6138. ! ***
  6139. subroutine MDF_Get_Var_i1_2d( hid, varid, values, status, &
  6140. start, count, stride, map )
  6141. #ifdef with_netcdf
  6142. use NetCDF, only : NF90_Get_Var
  6143. #endif
  6144. ! --- in/out -------------------------------------
  6145. integer, intent(in) :: hid
  6146. integer, intent(in) :: varid
  6147. integer(1), intent(out) :: values(:,:)
  6148. integer, intent(out) :: status
  6149. integer, intent(in), optional :: start (:)
  6150. integer, intent(in), optional :: count (:)
  6151. integer, intent(in), optional :: stride(:)
  6152. integer, intent(in), optional :: map (:)
  6153. ! --- const --------------------------------------
  6154. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_2d'
  6155. ! --- external -----------------------------------
  6156. #ifdef with_hdf4
  6157. integer(hdf4_wpi), external :: sfRData
  6158. #endif
  6159. ! --- local --------------------------------------
  6160. type(MDF_File), pointer :: filep
  6161. type(MDF_Var), pointer :: varp
  6162. integer :: iftype
  6163. integer :: ftype
  6164. #ifdef with_hdf4
  6165. integer :: hdf4_offset(MAX_RANK)
  6166. integer :: hdf4_stride(MAX_RANK)
  6167. integer :: hdf4_count(MAX_RANK)
  6168. integer(1), allocatable :: values_int1(:,:)
  6169. integer(2), allocatable :: values_int2(:,:)
  6170. integer(4), allocatable :: values_int4(:,:)
  6171. integer(8), allocatable :: values_int8(:,:)
  6172. real(4), allocatable :: values_real4(:,:)
  6173. real(8), allocatable :: values_real8(:,:)
  6174. #endif
  6175. ! --- begin --------------------------------------
  6176. ! pointer to file structure:
  6177. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  6178. IF_NOT_OK_RETURN(status=1)
  6179. ! pointer to variable structure:
  6180. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  6181. IF_NOT_OK_RETURN(status=1)
  6182. ! check ...
  6183. if ( size(shape(values)) > varp%ndim ) then
  6184. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  6185. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  6186. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  6187. TRACEBACK; status=1; return
  6188. end if
  6189. ! check ...
  6190. if ( present(start ) ) then
  6191. if ( size(start ) /= varp%ndim ) then
  6192. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6193. write (gol,'(" size start : ",i6)') size(start ); call goErr
  6194. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6195. TRACEBACK; status=1; return
  6196. end if
  6197. end if
  6198. if ( present(count ) ) then
  6199. if ( size(count ) /= varp%ndim ) then
  6200. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6201. write (gol,'(" size count : ",i6)') size(count ); call goErr
  6202. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6203. TRACEBACK; status=1; return
  6204. end if
  6205. end if
  6206. if ( present(stride ) ) then
  6207. if ( size(stride ) /= varp%ndim ) then
  6208. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6209. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  6210. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6211. TRACEBACK; status=1; return
  6212. end if
  6213. end if
  6214. if ( present(map ) ) then
  6215. if ( size(map ) /= varp%ndim ) then
  6216. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6217. write (gol,'(" size map : ",i6)') size(map ); call goErr
  6218. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6219. TRACEBACK; status=1; return
  6220. end if
  6221. end if
  6222. ! loop over file types:
  6223. do iftype = 1, filep%nftype
  6224. ! current type:
  6225. ftype = filep%ftypes(iftype)
  6226. ! select appropriate routine for each type:
  6227. select case ( ftype )
  6228. #ifdef with_hdf4
  6229. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6230. case ( MDF_HDF4 )
  6231. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6232. ! check ...
  6233. if ( present(map ) ) then
  6234. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  6235. TRACEBACK; status=1; return
  6236. end if
  6237. ! fill offset (zero based!), stride, and count :
  6238. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  6239. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  6240. hdf4_count = 1 ! default singleton dimension
  6241. hdf4_count(1:2) = shape(values)
  6242. ! test source type:
  6243. select case ( varp%hdf4_xtype )
  6244. case ( DFNT_INT8 )
  6245. allocate( values_int1(size(values,1),size(values,2)) )
  6246. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  6247. values = int(values_int1,kind=1)
  6248. deallocate( values_int1 )
  6249. case ( DFNT_INT16 )
  6250. allocate( values_int2(size(values,1),size(values,2)) )
  6251. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  6252. values = int(values_int2,kind=1)
  6253. deallocate( values_int2 )
  6254. case ( DFNT_INT32 )
  6255. allocate( values_int4(size(values,1),size(values,2)) )
  6256. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  6257. values = int(values_int4,kind=1)
  6258. deallocate( values_int4 )
  6259. case ( DFNT_INT64 )
  6260. allocate( values_int8(size(values,1),size(values,2)) )
  6261. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  6262. values = int(values_int8,kind=1)
  6263. deallocate( values_int8 )
  6264. case ( DFNT_FLOAT32 )
  6265. allocate( values_real4(size(values,1),size(values,2)) )
  6266. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  6267. values = int(values_real4,kind=1)
  6268. deallocate( values_real4 )
  6269. case ( DFNT_FLOAT64 )
  6270. allocate( values_real8(size(values,1),size(values,2)) )
  6271. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  6272. values = int(values_real8,kind=1)
  6273. deallocate( values_real8 )
  6274. case default
  6275. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  6276. TRACEBACK; status=1; return
  6277. end select
  6278. if ( status == FAIL ) then
  6279. write (gol,'("reading hdf4 data set:")'); call goErr
  6280. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  6281. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  6282. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  6283. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  6284. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  6285. write (gol,'(" size : ",i6)') size(values); call goErr
  6286. TRACEBACK; status=1; return
  6287. end if
  6288. #endif
  6289. #ifdef with_netcdf
  6290. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6291. case ( MDF_NETCDF, MDF_NETCDF4 )
  6292. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6293. ! read values, converted automatically:
  6294. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  6295. start, count, stride, map )
  6296. IF_NF90_NOT_OK_RETURN(status=1)
  6297. #endif
  6298. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6299. case default
  6300. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6301. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  6302. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  6303. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  6304. TRACEBACK; status=1; return
  6305. end select
  6306. end do ! file types
  6307. ! ok
  6308. status = 0
  6309. end subroutine MDF_Get_Var_i1_2d
  6310. ! ***
  6311. subroutine MDF_Put_Var_i1_3d( hid, varid, values, status, &
  6312. start, count, stride, map )
  6313. #ifdef with_hdf5_beta
  6314. use HDF5, only : HID_T, HSIZE_T
  6315. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  6316. use HDF5, only : H5T_NATIVE_CHARACTER
  6317. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  6318. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  6319. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  6320. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  6321. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  6322. #endif
  6323. #ifdef with_netcdf
  6324. use NetCDF, only : NF90_Put_Var
  6325. #endif
  6326. ! --- in/out -------------------------------------
  6327. integer, intent(in) :: hid
  6328. integer, intent(in) :: varid
  6329. integer(1), intent(in) :: values(:,:,:)
  6330. integer, intent(out) :: status
  6331. integer, intent(in), optional :: start (:)
  6332. integer, intent(in), optional :: count (:)
  6333. integer, intent(in), optional :: stride(:)
  6334. integer, intent(in), optional :: map (:)
  6335. ! --- const --------------------------------------
  6336. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_3d'
  6337. ! --- external -----------------------------------
  6338. #ifdef with_hdf4
  6339. integer(hdf4_wpi), external :: sfWData
  6340. #endif
  6341. ! --- local --------------------------------------
  6342. type(MDF_File), pointer :: filep
  6343. type(MDF_Var), pointer :: varp
  6344. integer :: iftype
  6345. integer :: ftype
  6346. #ifdef with_hdf4
  6347. integer :: hdf4_offset(MAX_RANK)
  6348. integer :: hdf4_stride(MAX_RANK)
  6349. integer :: hdf4_count(MAX_RANK)
  6350. #endif
  6351. #ifdef with_hdf5_beta
  6352. !integer(HID_T) :: hdf5_type_id
  6353. integer(HID_T) :: hdf5_file_space_id
  6354. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  6355. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  6356. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  6357. #endif
  6358. integer(1), allocatable :: values_int1(:,:,:)
  6359. integer(2), allocatable :: values_int2(:,:,:)
  6360. integer(4), allocatable :: values_int4(:,:,:)
  6361. integer(8), allocatable :: values_int8(:,:,:)
  6362. real(4), allocatable :: values_real4(:,:,:)
  6363. real(8), allocatable :: values_real8(:,:,:)
  6364. ! --- begin --------------------------------------
  6365. ! pointer to file structure:
  6366. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  6367. IF_NOT_OK_RETURN(status=1)
  6368. ! pointer to variable structure:
  6369. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  6370. IF_NOT_OK_RETURN(status=1)
  6371. ! check ...
  6372. if ( size(shape(values)) > varp%ndim ) then
  6373. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  6374. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  6375. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  6376. TRACEBACK; status=1; return
  6377. end if
  6378. ! check ...
  6379. if ( present(start ) ) then
  6380. if ( size(start ) /= varp%ndim ) then
  6381. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6382. write (gol,'(" size start : ",i6)') size(start ); call goErr
  6383. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6384. TRACEBACK; status=1; return
  6385. end if
  6386. end if
  6387. if ( present(count ) ) then
  6388. if ( size(count ) /= varp%ndim ) then
  6389. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6390. write (gol,'(" size count : ",i6)') size(count ); call goErr
  6391. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6392. TRACEBACK; status=1; return
  6393. end if
  6394. end if
  6395. if ( present(stride ) ) then
  6396. if ( size(stride ) /= varp%ndim ) then
  6397. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6398. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  6399. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6400. TRACEBACK; status=1; return
  6401. end if
  6402. end if
  6403. if ( present(map ) ) then
  6404. if ( size(map ) /= varp%ndim ) then
  6405. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6406. write (gol,'(" size map : ",i6)') size(map ); call goErr
  6407. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6408. TRACEBACK; status=1; return
  6409. end if
  6410. end if
  6411. ! loop over file types:
  6412. do iftype = 1, filep%nftype
  6413. ! current type:
  6414. ftype = filep%ftypes(iftype)
  6415. ! select appropriate routine for each type:
  6416. select case ( ftype )
  6417. #ifdef with_hdf4
  6418. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6419. case ( MDF_HDF4 )
  6420. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6421. ! check ...
  6422. if ( present(map ) ) then
  6423. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  6424. TRACEBACK; status=1; return
  6425. end if
  6426. ! fill offset (zero based!) and stride with default values:
  6427. hdf4_offset = 0
  6428. hdf4_stride = 1
  6429. ! count is by default the shape; padd with singleton dimensions:
  6430. hdf4_count = 1; hdf4_count(1:3) = shape(values)
  6431. ! replace by optional arguments if necessary:
  6432. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  6433. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  6434. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  6435. ! test target type;
  6436. ! convert to required kind before entering sfWData,
  6437. ! otherwise segmentation faults on some machines ...
  6438. select case ( varp%xtype )
  6439. case ( MDF_BYTE )
  6440. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  6441. values_int1 = int(values,kind=1)
  6442. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6443. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  6444. deallocate( values_int1 )
  6445. case ( MDF_SHORT )
  6446. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  6447. values_int2 = int(values,kind=2)
  6448. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6449. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  6450. deallocate( values_int2 )
  6451. case ( MDF_INT )
  6452. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  6453. values_int4 = int(values,kind=4)
  6454. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6455. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  6456. deallocate( values_int4 )
  6457. case ( MDF_FLOAT )
  6458. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  6459. values_real4 = real(values,kind=4)
  6460. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6461. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  6462. deallocate( values_real4 )
  6463. case ( MDF_DOUBLE )
  6464. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  6465. values_real8 = real(values,kind=8)
  6466. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6467. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  6468. deallocate( values_real8 )
  6469. case default
  6470. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  6471. TRACEBACK; status=1; return
  6472. end select
  6473. if ( status == FAIL ) then
  6474. write (gol,'("writing hdf4 data set:")'); call goErr
  6475. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  6476. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  6477. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  6478. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  6479. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  6480. write (gol,'(" size : ",i12)') size(values); call goErr
  6481. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  6482. TRACEBACK; status=1; return
  6483. end if
  6484. #endif
  6485. #ifdef with_hdf5_beta
  6486. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6487. case ( MDF_HDF5 )
  6488. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6489. ! check ...
  6490. if ( present(map ) ) then
  6491. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  6492. TRACEBACK; status=1; return
  6493. end if
  6494. ! fill offset (zero based!), stride, and count :
  6495. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  6496. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  6497. hdf5_count = 1 ! default singleton dimension
  6498. if ( present(count) ) then
  6499. hdf5_count(1:varp%ndim) = count
  6500. else
  6501. hdf5_count(1:3) = shape(values)
  6502. end if
  6503. ! new dimension:
  6504. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  6505. ! target data space in file:
  6506. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  6507. IF_NOT_OK_RETURN(status=1)
  6508. ! chunked dataset ?
  6509. if ( varp%hdf5_chunked ) then
  6510. ! reset extend:
  6511. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  6512. IF_NOT_OK_RETURN(status=1)
  6513. end if
  6514. ! select hyperslab:
  6515. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  6516. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  6517. stride=hdf5_stride(1:varp%ndim) )
  6518. ! write data:
  6519. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  6520. int(shape(values),kind=HSIZE_T), status, &
  6521. file_space_id=hdf5_file_space_id )
  6522. IF_NOT_OK_RETURN(status=1)
  6523. ! release data space:
  6524. call H5SClose_f( hdf5_file_space_id, status )
  6525. IF_NOT_OK_RETURN(status=1)
  6526. #endif
  6527. #ifdef with_netcdf
  6528. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6529. case ( MDF_NETCDF, MDF_NETCDF4 )
  6530. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6531. ! test target type:
  6532. ! convert to required kind before entering NF90_Put_Var,
  6533. ! otherwise segmentation faults on some machines ...
  6534. select case ( varp%xtype )
  6535. case ( MDF_BYTE )
  6536. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  6537. values_int1 = int(values,kind=1)
  6538. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  6539. start, count, stride, map )
  6540. IF_NF90_NOT_OK_RETURN(status=1)
  6541. deallocate( values_int1 )
  6542. case ( MDF_SHORT )
  6543. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  6544. values_int2 = int(values,kind=2)
  6545. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  6546. start, count, stride, map )
  6547. IF_NF90_NOT_OK_RETURN(status=1)
  6548. deallocate( values_int2 )
  6549. case ( MDF_INT )
  6550. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  6551. values_int4 = int(values,kind=4)
  6552. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  6553. start, count, stride, map )
  6554. IF_NF90_NOT_OK_RETURN(status=1)
  6555. deallocate( values_int4 )
  6556. case ( MDF_FLOAT )
  6557. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  6558. values_real4 = real(values,kind=4)
  6559. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  6560. start, count, stride, map )
  6561. IF_NF90_NOT_OK_RETURN(status=1)
  6562. deallocate( values_real4 )
  6563. case ( MDF_DOUBLE )
  6564. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  6565. values_real8 = real(values,kind=8)
  6566. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  6567. start, count, stride, map )
  6568. IF_NF90_NOT_OK_RETURN(status=1)
  6569. deallocate( values_real8 )
  6570. case default
  6571. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  6572. TRACEBACK; status=1; return
  6573. end select
  6574. ! just put; let netcdf library convert the right kind:
  6575. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  6576. ! start, count, stride, map )
  6577. !IF_NF90_NOT_OK_RETURN(status=1)
  6578. #endif
  6579. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6580. case default
  6581. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6582. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  6583. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  6584. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  6585. TRACEBACK; status=1; return
  6586. end select
  6587. end do ! file types
  6588. ! ok
  6589. status = 0
  6590. end subroutine MDF_Put_Var_i1_3d
  6591. ! ***
  6592. subroutine MDF_Get_Var_i1_3d( hid, varid, values, status, &
  6593. start, count, stride, map )
  6594. #ifdef with_netcdf
  6595. use NetCDF, only : NF90_Get_Var
  6596. #endif
  6597. ! --- in/out -------------------------------------
  6598. integer, intent(in) :: hid
  6599. integer, intent(in) :: varid
  6600. integer(1), intent(out) :: values(:,:,:)
  6601. integer, intent(out) :: status
  6602. integer, intent(in), optional :: start (:)
  6603. integer, intent(in), optional :: count (:)
  6604. integer, intent(in), optional :: stride(:)
  6605. integer, intent(in), optional :: map (:)
  6606. ! --- const --------------------------------------
  6607. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_3d'
  6608. ! --- external -----------------------------------
  6609. #ifdef with_hdf4
  6610. integer(hdf4_wpi), external :: sfRData
  6611. #endif
  6612. ! --- local --------------------------------------
  6613. type(MDF_File), pointer :: filep
  6614. type(MDF_Var), pointer :: varp
  6615. integer :: iftype
  6616. integer :: ftype
  6617. #ifdef with_hdf4
  6618. integer :: hdf4_offset(MAX_RANK)
  6619. integer :: hdf4_stride(MAX_RANK)
  6620. integer :: hdf4_count(MAX_RANK)
  6621. integer(1), allocatable :: values_int1(:,:,:)
  6622. integer(2), allocatable :: values_int2(:,:,:)
  6623. integer(4), allocatable :: values_int4(:,:,:)
  6624. integer(8), allocatable :: values_int8(:,:,:)
  6625. real(4), allocatable :: values_real4(:,:,:)
  6626. real(8), allocatable :: values_real8(:,:,:)
  6627. #endif
  6628. ! --- begin --------------------------------------
  6629. ! pointer to file structure:
  6630. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  6631. IF_NOT_OK_RETURN(status=1)
  6632. ! pointer to variable structure:
  6633. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  6634. IF_NOT_OK_RETURN(status=1)
  6635. ! check ...
  6636. if ( size(shape(values)) > varp%ndim ) then
  6637. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  6638. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  6639. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  6640. TRACEBACK; status=1; return
  6641. end if
  6642. ! check ...
  6643. if ( present(start ) ) then
  6644. if ( size(start ) /= varp%ndim ) then
  6645. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6646. write (gol,'(" size start : ",i6)') size(start ); call goErr
  6647. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6648. TRACEBACK; status=1; return
  6649. end if
  6650. end if
  6651. if ( present(count ) ) then
  6652. if ( size(count ) /= varp%ndim ) then
  6653. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6654. write (gol,'(" size count : ",i6)') size(count ); call goErr
  6655. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6656. TRACEBACK; status=1; return
  6657. end if
  6658. end if
  6659. if ( present(stride ) ) then
  6660. if ( size(stride ) /= varp%ndim ) then
  6661. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6662. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  6663. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6664. TRACEBACK; status=1; return
  6665. end if
  6666. end if
  6667. if ( present(map ) ) then
  6668. if ( size(map ) /= varp%ndim ) then
  6669. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6670. write (gol,'(" size map : ",i6)') size(map ); call goErr
  6671. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6672. TRACEBACK; status=1; return
  6673. end if
  6674. end if
  6675. ! loop over file types:
  6676. do iftype = 1, filep%nftype
  6677. ! current type:
  6678. ftype = filep%ftypes(iftype)
  6679. ! select appropriate routine for each type:
  6680. select case ( ftype )
  6681. #ifdef with_hdf4
  6682. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6683. case ( MDF_HDF4 )
  6684. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6685. ! check ...
  6686. if ( present(map ) ) then
  6687. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  6688. TRACEBACK; status=1; return
  6689. end if
  6690. ! fill offset (zero based!), stride, and count :
  6691. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  6692. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  6693. hdf4_count = 1 ! default singleton dimension
  6694. hdf4_count(1:3) = shape(values)
  6695. ! test source type:
  6696. select case ( varp%hdf4_xtype )
  6697. case ( DFNT_INT8 )
  6698. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  6699. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  6700. values = int(values_int1,kind=1)
  6701. deallocate( values_int1 )
  6702. case ( DFNT_INT16 )
  6703. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  6704. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  6705. values = int(values_int2,kind=1)
  6706. deallocate( values_int2 )
  6707. case ( DFNT_INT32 )
  6708. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  6709. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  6710. values = int(values_int4,kind=1)
  6711. deallocate( values_int4 )
  6712. case ( DFNT_INT64 )
  6713. allocate( values_int8(size(values,1),size(values,2),size(values,3)) )
  6714. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  6715. values = int(values_int8,kind=1)
  6716. deallocate( values_int8 )
  6717. case ( DFNT_FLOAT32 )
  6718. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  6719. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  6720. values = int(values_real4,kind=1)
  6721. deallocate( values_real4 )
  6722. case ( DFNT_FLOAT64 )
  6723. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  6724. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  6725. values = int(values_real8,kind=1)
  6726. deallocate( values_real8 )
  6727. case default
  6728. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  6729. TRACEBACK; status=1; return
  6730. end select
  6731. if ( status == FAIL ) then
  6732. write (gol,'("reading hdf4 data set:")'); call goErr
  6733. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  6734. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  6735. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  6736. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  6737. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  6738. write (gol,'(" size : ",i6)') size(values); call goErr
  6739. TRACEBACK; status=1; return
  6740. end if
  6741. #endif
  6742. #ifdef with_netcdf
  6743. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6744. case ( MDF_NETCDF, MDF_NETCDF4 )
  6745. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6746. ! read values, converted automatically:
  6747. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  6748. start, count, stride, map )
  6749. IF_NF90_NOT_OK_RETURN(status=1)
  6750. #endif
  6751. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6752. case default
  6753. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6754. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  6755. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  6756. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  6757. TRACEBACK; status=1; return
  6758. end select
  6759. end do ! file types
  6760. ! ok
  6761. status = 0
  6762. end subroutine MDF_Get_Var_i1_3d
  6763. ! ***
  6764. subroutine MDF_Put_Var_i1_4d( hid, varid, values, status, &
  6765. start, count, stride, map )
  6766. #ifdef with_hdf5_beta
  6767. use HDF5, only : HID_T, HSIZE_T
  6768. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  6769. use HDF5, only : H5T_NATIVE_CHARACTER
  6770. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  6771. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  6772. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  6773. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  6774. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  6775. #endif
  6776. #ifdef with_netcdf
  6777. use NetCDF, only : NF90_Put_Var
  6778. #endif
  6779. ! --- in/out -------------------------------------
  6780. integer, intent(in) :: hid
  6781. integer, intent(in) :: varid
  6782. integer(1), intent(in) :: values(:,:,:,:)
  6783. integer, intent(out) :: status
  6784. integer, intent(in), optional :: start (:)
  6785. integer, intent(in), optional :: count (:)
  6786. integer, intent(in), optional :: stride(:)
  6787. integer, intent(in), optional :: map (:)
  6788. ! --- const --------------------------------------
  6789. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_4d'
  6790. ! --- external -----------------------------------
  6791. #ifdef with_hdf4
  6792. integer(hdf4_wpi), external :: sfWData
  6793. #endif
  6794. ! --- local --------------------------------------
  6795. type(MDF_File), pointer :: filep
  6796. type(MDF_Var), pointer :: varp
  6797. integer :: iftype
  6798. integer :: ftype
  6799. #ifdef with_hdf4
  6800. integer :: hdf4_offset(MAX_RANK)
  6801. integer :: hdf4_stride(MAX_RANK)
  6802. integer :: hdf4_count(MAX_RANK)
  6803. #endif
  6804. #ifdef with_hdf5_beta
  6805. !integer(HID_T) :: hdf5_type_id
  6806. integer(HID_T) :: hdf5_file_space_id
  6807. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  6808. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  6809. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  6810. #endif
  6811. integer(1), allocatable :: values_int1(:,:,:,:)
  6812. integer(2), allocatable :: values_int2(:,:,:,:)
  6813. integer(4), allocatable :: values_int4(:,:,:,:)
  6814. integer(8), allocatable :: values_int8(:,:,:,:)
  6815. real(4), allocatable :: values_real4(:,:,:,:)
  6816. real(8), allocatable :: values_real8(:,:,:,:)
  6817. ! --- begin --------------------------------------
  6818. ! pointer to file structure:
  6819. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  6820. IF_NOT_OK_RETURN(status=1)
  6821. ! pointer to variable structure:
  6822. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  6823. IF_NOT_OK_RETURN(status=1)
  6824. ! check ...
  6825. if ( size(shape(values)) > varp%ndim ) then
  6826. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  6827. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  6828. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  6829. TRACEBACK; status=1; return
  6830. end if
  6831. ! check ...
  6832. if ( present(start ) ) then
  6833. if ( size(start ) /= varp%ndim ) then
  6834. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6835. write (gol,'(" size start : ",i6)') size(start ); call goErr
  6836. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6837. TRACEBACK; status=1; return
  6838. end if
  6839. end if
  6840. if ( present(count ) ) then
  6841. if ( size(count ) /= varp%ndim ) then
  6842. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6843. write (gol,'(" size count : ",i6)') size(count ); call goErr
  6844. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6845. TRACEBACK; status=1; return
  6846. end if
  6847. end if
  6848. if ( present(stride ) ) then
  6849. if ( size(stride ) /= varp%ndim ) then
  6850. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6851. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  6852. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6853. TRACEBACK; status=1; return
  6854. end if
  6855. end if
  6856. if ( present(map ) ) then
  6857. if ( size(map ) /= varp%ndim ) then
  6858. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  6859. write (gol,'(" size map : ",i6)') size(map ); call goErr
  6860. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  6861. TRACEBACK; status=1; return
  6862. end if
  6863. end if
  6864. ! loop over file types:
  6865. do iftype = 1, filep%nftype
  6866. ! current type:
  6867. ftype = filep%ftypes(iftype)
  6868. ! select appropriate routine for each type:
  6869. select case ( ftype )
  6870. #ifdef with_hdf4
  6871. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6872. case ( MDF_HDF4 )
  6873. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6874. ! check ...
  6875. if ( present(map ) ) then
  6876. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  6877. TRACEBACK; status=1; return
  6878. end if
  6879. ! fill offset (zero based!) and stride with default values:
  6880. hdf4_offset = 0
  6881. hdf4_stride = 1
  6882. ! count is by default the shape; padd with singleton dimensions:
  6883. hdf4_count = 1; hdf4_count(1:4) = shape(values)
  6884. ! replace by optional arguments if necessary:
  6885. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  6886. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  6887. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  6888. ! test target type;
  6889. ! convert to required kind before entering sfWData,
  6890. ! otherwise segmentation faults on some machines ...
  6891. select case ( varp%xtype )
  6892. case ( MDF_BYTE )
  6893. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6894. values_int1 = int(values,kind=1)
  6895. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6896. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  6897. deallocate( values_int1 )
  6898. case ( MDF_SHORT )
  6899. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6900. values_int2 = int(values,kind=2)
  6901. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6902. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  6903. deallocate( values_int2 )
  6904. case ( MDF_INT )
  6905. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6906. values_int4 = int(values,kind=4)
  6907. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6908. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  6909. deallocate( values_int4 )
  6910. case ( MDF_FLOAT )
  6911. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6912. values_real4 = real(values,kind=4)
  6913. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6914. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  6915. deallocate( values_real4 )
  6916. case ( MDF_DOUBLE )
  6917. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6918. values_real8 = real(values,kind=8)
  6919. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  6920. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  6921. deallocate( values_real8 )
  6922. case default
  6923. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  6924. TRACEBACK; status=1; return
  6925. end select
  6926. if ( status == FAIL ) then
  6927. write (gol,'("writing hdf4 data set:")'); call goErr
  6928. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  6929. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  6930. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  6931. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  6932. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  6933. write (gol,'(" size : ",i12)') size(values); call goErr
  6934. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  6935. TRACEBACK; status=1; return
  6936. end if
  6937. #endif
  6938. #ifdef with_hdf5_beta
  6939. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6940. case ( MDF_HDF5 )
  6941. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6942. ! check ...
  6943. if ( present(map ) ) then
  6944. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  6945. TRACEBACK; status=1; return
  6946. end if
  6947. ! fill offset (zero based!), stride, and count :
  6948. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  6949. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  6950. hdf5_count = 1 ! default singleton dimension
  6951. if ( present(count) ) then
  6952. hdf5_count(1:varp%ndim) = count
  6953. else
  6954. hdf5_count(1:4) = shape(values)
  6955. end if
  6956. ! new dimension:
  6957. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  6958. ! target data space in file:
  6959. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  6960. IF_NOT_OK_RETURN(status=1)
  6961. ! chunked dataset ?
  6962. if ( varp%hdf5_chunked ) then
  6963. ! reset extend:
  6964. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  6965. IF_NOT_OK_RETURN(status=1)
  6966. end if
  6967. ! select hyperslab:
  6968. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  6969. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  6970. stride=hdf5_stride(1:varp%ndim) )
  6971. ! write data:
  6972. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  6973. int(shape(values),kind=HSIZE_T), status, &
  6974. file_space_id=hdf5_file_space_id )
  6975. IF_NOT_OK_RETURN(status=1)
  6976. ! release data space:
  6977. call H5SClose_f( hdf5_file_space_id, status )
  6978. IF_NOT_OK_RETURN(status=1)
  6979. #endif
  6980. #ifdef with_netcdf
  6981. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6982. case ( MDF_NETCDF, MDF_NETCDF4 )
  6983. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  6984. ! test target type:
  6985. ! convert to required kind before entering NF90_Put_Var,
  6986. ! otherwise segmentation faults on some machines ...
  6987. select case ( varp%xtype )
  6988. case ( MDF_BYTE )
  6989. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6990. values_int1 = int(values,kind=1)
  6991. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  6992. start, count, stride, map )
  6993. IF_NF90_NOT_OK_RETURN(status=1)
  6994. deallocate( values_int1 )
  6995. case ( MDF_SHORT )
  6996. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  6997. values_int2 = int(values,kind=2)
  6998. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  6999. start, count, stride, map )
  7000. IF_NF90_NOT_OK_RETURN(status=1)
  7001. deallocate( values_int2 )
  7002. case ( MDF_INT )
  7003. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7004. values_int4 = int(values,kind=4)
  7005. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  7006. start, count, stride, map )
  7007. IF_NF90_NOT_OK_RETURN(status=1)
  7008. deallocate( values_int4 )
  7009. case ( MDF_FLOAT )
  7010. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7011. values_real4 = real(values,kind=4)
  7012. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  7013. start, count, stride, map )
  7014. IF_NF90_NOT_OK_RETURN(status=1)
  7015. deallocate( values_real4 )
  7016. case ( MDF_DOUBLE )
  7017. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7018. values_real8 = real(values,kind=8)
  7019. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  7020. start, count, stride, map )
  7021. IF_NF90_NOT_OK_RETURN(status=1)
  7022. deallocate( values_real8 )
  7023. case default
  7024. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  7025. TRACEBACK; status=1; return
  7026. end select
  7027. ! just put; let netcdf library convert the right kind:
  7028. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  7029. ! start, count, stride, map )
  7030. !IF_NF90_NOT_OK_RETURN(status=1)
  7031. #endif
  7032. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7033. case default
  7034. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7035. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  7036. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  7037. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  7038. TRACEBACK; status=1; return
  7039. end select
  7040. end do ! file types
  7041. ! ok
  7042. status = 0
  7043. end subroutine MDF_Put_Var_i1_4d
  7044. ! ***
  7045. subroutine MDF_Get_Var_i1_4d( hid, varid, values, status, &
  7046. start, count, stride, map )
  7047. #ifdef with_netcdf
  7048. use NetCDF, only : NF90_Get_Var
  7049. #endif
  7050. ! --- in/out -------------------------------------
  7051. integer, intent(in) :: hid
  7052. integer, intent(in) :: varid
  7053. integer(1), intent(out) :: values(:,:,:,:)
  7054. integer, intent(out) :: status
  7055. integer, intent(in), optional :: start (:)
  7056. integer, intent(in), optional :: count (:)
  7057. integer, intent(in), optional :: stride(:)
  7058. integer, intent(in), optional :: map (:)
  7059. ! --- const --------------------------------------
  7060. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_4d'
  7061. ! --- external -----------------------------------
  7062. #ifdef with_hdf4
  7063. integer(hdf4_wpi), external :: sfRData
  7064. #endif
  7065. ! --- local --------------------------------------
  7066. type(MDF_File), pointer :: filep
  7067. type(MDF_Var), pointer :: varp
  7068. integer :: iftype
  7069. integer :: ftype
  7070. #ifdef with_hdf4
  7071. integer :: hdf4_offset(MAX_RANK)
  7072. integer :: hdf4_stride(MAX_RANK)
  7073. integer :: hdf4_count(MAX_RANK)
  7074. integer(1), allocatable :: values_int1(:,:,:,:)
  7075. integer(2), allocatable :: values_int2(:,:,:,:)
  7076. integer(4), allocatable :: values_int4(:,:,:,:)
  7077. integer(8), allocatable :: values_int8(:,:,:,:)
  7078. real(4), allocatable :: values_real4(:,:,:,:)
  7079. real(8), allocatable :: values_real8(:,:,:,:)
  7080. #endif
  7081. ! --- begin --------------------------------------
  7082. ! pointer to file structure:
  7083. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  7084. IF_NOT_OK_RETURN(status=1)
  7085. ! pointer to variable structure:
  7086. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  7087. IF_NOT_OK_RETURN(status=1)
  7088. ! check ...
  7089. if ( size(shape(values)) > varp%ndim ) then
  7090. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  7091. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  7092. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  7093. TRACEBACK; status=1; return
  7094. end if
  7095. ! check ...
  7096. if ( present(start ) ) then
  7097. if ( size(start ) /= varp%ndim ) then
  7098. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7099. write (gol,'(" size start : ",i6)') size(start ); call goErr
  7100. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7101. TRACEBACK; status=1; return
  7102. end if
  7103. end if
  7104. if ( present(count ) ) then
  7105. if ( size(count ) /= varp%ndim ) then
  7106. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7107. write (gol,'(" size count : ",i6)') size(count ); call goErr
  7108. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7109. TRACEBACK; status=1; return
  7110. end if
  7111. end if
  7112. if ( present(stride ) ) then
  7113. if ( size(stride ) /= varp%ndim ) then
  7114. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7115. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  7116. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7117. TRACEBACK; status=1; return
  7118. end if
  7119. end if
  7120. if ( present(map ) ) then
  7121. if ( size(map ) /= varp%ndim ) then
  7122. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7123. write (gol,'(" size map : ",i6)') size(map ); call goErr
  7124. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7125. TRACEBACK; status=1; return
  7126. end if
  7127. end if
  7128. ! loop over file types:
  7129. do iftype = 1, filep%nftype
  7130. ! current type:
  7131. ftype = filep%ftypes(iftype)
  7132. ! select appropriate routine for each type:
  7133. select case ( ftype )
  7134. #ifdef with_hdf4
  7135. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7136. case ( MDF_HDF4 )
  7137. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7138. ! check ...
  7139. if ( present(map ) ) then
  7140. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  7141. TRACEBACK; status=1; return
  7142. end if
  7143. ! fill offset (zero based!), stride, and count :
  7144. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  7145. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  7146. hdf4_count = 1 ! default singleton dimension
  7147. hdf4_count(1:4) = shape(values)
  7148. ! test source type:
  7149. select case ( varp%hdf4_xtype )
  7150. case ( DFNT_INT8 )
  7151. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7152. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  7153. values = int(values_int1,kind=1)
  7154. deallocate( values_int1 )
  7155. case ( DFNT_INT16 )
  7156. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7157. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  7158. values = int(values_int2,kind=1)
  7159. deallocate( values_int2 )
  7160. case ( DFNT_INT32 )
  7161. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7162. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  7163. values = int(values_int4,kind=1)
  7164. deallocate( values_int4 )
  7165. case ( DFNT_INT64 )
  7166. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7167. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  7168. values = int(values_int8,kind=1)
  7169. deallocate( values_int8 )
  7170. case ( DFNT_FLOAT32 )
  7171. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7172. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  7173. values = int(values_real4,kind=1)
  7174. deallocate( values_real4 )
  7175. case ( DFNT_FLOAT64 )
  7176. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  7177. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  7178. values = int(values_real8,kind=1)
  7179. deallocate( values_real8 )
  7180. case default
  7181. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  7182. TRACEBACK; status=1; return
  7183. end select
  7184. if ( status == FAIL ) then
  7185. write (gol,'("reading hdf4 data set:")'); call goErr
  7186. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  7187. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  7188. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  7189. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  7190. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  7191. write (gol,'(" size : ",i6)') size(values); call goErr
  7192. TRACEBACK; status=1; return
  7193. end if
  7194. #endif
  7195. #ifdef with_netcdf
  7196. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7197. case ( MDF_NETCDF, MDF_NETCDF4 )
  7198. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7199. ! read values, converted automatically:
  7200. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  7201. start, count, stride, map )
  7202. IF_NF90_NOT_OK_RETURN(status=1)
  7203. #endif
  7204. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7205. case default
  7206. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7207. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  7208. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  7209. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  7210. TRACEBACK; status=1; return
  7211. end select
  7212. end do ! file types
  7213. ! ok
  7214. status = 0
  7215. end subroutine MDF_Get_Var_i1_4d
  7216. ! ***
  7217. subroutine MDF_Put_Var_i1_5d( hid, varid, values, status, &
  7218. start, count, stride, map )
  7219. #ifdef with_hdf5_beta
  7220. use HDF5, only : HID_T, HSIZE_T
  7221. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  7222. use HDF5, only : H5T_NATIVE_CHARACTER
  7223. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  7224. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  7225. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  7226. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  7227. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  7228. #endif
  7229. #ifdef with_netcdf
  7230. use NetCDF, only : NF90_Put_Var
  7231. #endif
  7232. ! --- in/out -------------------------------------
  7233. integer, intent(in) :: hid
  7234. integer, intent(in) :: varid
  7235. integer(1), intent(in) :: values(:,:,:,:,:)
  7236. integer, intent(out) :: status
  7237. integer, intent(in), optional :: start (:)
  7238. integer, intent(in), optional :: count (:)
  7239. integer, intent(in), optional :: stride(:)
  7240. integer, intent(in), optional :: map (:)
  7241. ! --- const --------------------------------------
  7242. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_5d'
  7243. ! --- external -----------------------------------
  7244. #ifdef with_hdf4
  7245. integer(hdf4_wpi), external :: sfWData
  7246. #endif
  7247. ! --- local --------------------------------------
  7248. type(MDF_File), pointer :: filep
  7249. type(MDF_Var), pointer :: varp
  7250. integer :: iftype
  7251. integer :: ftype
  7252. #ifdef with_hdf4
  7253. integer :: hdf4_offset(MAX_RANK)
  7254. integer :: hdf4_stride(MAX_RANK)
  7255. integer :: hdf4_count(MAX_RANK)
  7256. #endif
  7257. #ifdef with_hdf5_beta
  7258. !integer(HID_T) :: hdf5_type_id
  7259. integer(HID_T) :: hdf5_file_space_id
  7260. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  7261. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  7262. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  7263. #endif
  7264. integer(1), allocatable :: values_int1(:,:,:,:,:)
  7265. integer(2), allocatable :: values_int2(:,:,:,:,:)
  7266. integer(4), allocatable :: values_int4(:,:,:,:,:)
  7267. integer(8), allocatable :: values_int8(:,:,:,:,:)
  7268. real(4), allocatable :: values_real4(:,:,:,:,:)
  7269. real(8), allocatable :: values_real8(:,:,:,:,:)
  7270. ! --- begin --------------------------------------
  7271. ! pointer to file structure:
  7272. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  7273. IF_NOT_OK_RETURN(status=1)
  7274. ! pointer to variable structure:
  7275. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  7276. IF_NOT_OK_RETURN(status=1)
  7277. ! check ...
  7278. if ( size(shape(values)) > varp%ndim ) then
  7279. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  7280. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  7281. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  7282. TRACEBACK; status=1; return
  7283. end if
  7284. ! check ...
  7285. if ( present(start ) ) then
  7286. if ( size(start ) /= varp%ndim ) then
  7287. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7288. write (gol,'(" size start : ",i6)') size(start ); call goErr
  7289. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7290. TRACEBACK; status=1; return
  7291. end if
  7292. end if
  7293. if ( present(count ) ) then
  7294. if ( size(count ) /= varp%ndim ) then
  7295. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7296. write (gol,'(" size count : ",i6)') size(count ); call goErr
  7297. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7298. TRACEBACK; status=1; return
  7299. end if
  7300. end if
  7301. if ( present(stride ) ) then
  7302. if ( size(stride ) /= varp%ndim ) then
  7303. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7304. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  7305. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7306. TRACEBACK; status=1; return
  7307. end if
  7308. end if
  7309. if ( present(map ) ) then
  7310. if ( size(map ) /= varp%ndim ) then
  7311. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7312. write (gol,'(" size map : ",i6)') size(map ); call goErr
  7313. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7314. TRACEBACK; status=1; return
  7315. end if
  7316. end if
  7317. ! loop over file types:
  7318. do iftype = 1, filep%nftype
  7319. ! current type:
  7320. ftype = filep%ftypes(iftype)
  7321. ! select appropriate routine for each type:
  7322. select case ( ftype )
  7323. #ifdef with_hdf4
  7324. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7325. case ( MDF_HDF4 )
  7326. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7327. ! check ...
  7328. if ( present(map ) ) then
  7329. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  7330. TRACEBACK; status=1; return
  7331. end if
  7332. ! fill offset (zero based!) and stride with default values:
  7333. hdf4_offset = 0
  7334. hdf4_stride = 1
  7335. ! count is by default the shape; padd with singleton dimensions:
  7336. hdf4_count = 1; hdf4_count(1:5) = shape(values)
  7337. ! replace by optional arguments if necessary:
  7338. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  7339. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  7340. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  7341. ! test target type;
  7342. ! convert to required kind before entering sfWData,
  7343. ! otherwise segmentation faults on some machines ...
  7344. select case ( varp%xtype )
  7345. case ( MDF_BYTE )
  7346. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7347. values_int1 = int(values,kind=1)
  7348. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7349. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  7350. deallocate( values_int1 )
  7351. case ( MDF_SHORT )
  7352. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7353. values_int2 = int(values,kind=2)
  7354. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7355. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  7356. deallocate( values_int2 )
  7357. case ( MDF_INT )
  7358. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7359. values_int4 = int(values,kind=4)
  7360. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7361. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  7362. deallocate( values_int4 )
  7363. case ( MDF_FLOAT )
  7364. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7365. values_real4 = real(values,kind=4)
  7366. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7367. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  7368. deallocate( values_real4 )
  7369. case ( MDF_DOUBLE )
  7370. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7371. values_real8 = real(values,kind=8)
  7372. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7373. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  7374. deallocate( values_real8 )
  7375. case default
  7376. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  7377. TRACEBACK; status=1; return
  7378. end select
  7379. if ( status == FAIL ) then
  7380. write (gol,'("writing hdf4 data set:")'); call goErr
  7381. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  7382. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  7383. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  7384. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  7385. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  7386. write (gol,'(" size : ",i12)') size(values); call goErr
  7387. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  7388. TRACEBACK; status=1; return
  7389. end if
  7390. #endif
  7391. #ifdef with_hdf5_beta
  7392. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7393. case ( MDF_HDF5 )
  7394. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7395. ! check ...
  7396. if ( present(map ) ) then
  7397. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  7398. TRACEBACK; status=1; return
  7399. end if
  7400. ! fill offset (zero based!), stride, and count :
  7401. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  7402. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  7403. hdf5_count = 1 ! default singleton dimension
  7404. if ( present(count) ) then
  7405. hdf5_count(1:varp%ndim) = count
  7406. else
  7407. hdf5_count(1:5) = shape(values)
  7408. end if
  7409. ! new dimension:
  7410. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  7411. ! target data space in file:
  7412. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  7413. IF_NOT_OK_RETURN(status=1)
  7414. ! chunked dataset ?
  7415. if ( varp%hdf5_chunked ) then
  7416. ! reset extend:
  7417. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  7418. IF_NOT_OK_RETURN(status=1)
  7419. end if
  7420. ! select hyperslab:
  7421. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  7422. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  7423. stride=hdf5_stride(1:varp%ndim) )
  7424. ! write data:
  7425. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  7426. int(shape(values),kind=HSIZE_T), status, &
  7427. file_space_id=hdf5_file_space_id )
  7428. IF_NOT_OK_RETURN(status=1)
  7429. ! release data space:
  7430. call H5SClose_f( hdf5_file_space_id, status )
  7431. IF_NOT_OK_RETURN(status=1)
  7432. #endif
  7433. #ifdef with_netcdf
  7434. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7435. case ( MDF_NETCDF, MDF_NETCDF4 )
  7436. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7437. ! test target type:
  7438. ! convert to required kind before entering NF90_Put_Var,
  7439. ! otherwise segmentation faults on some machines ...
  7440. select case ( varp%xtype )
  7441. case ( MDF_BYTE )
  7442. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7443. values_int1 = int(values,kind=1)
  7444. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  7445. start, count, stride, map )
  7446. IF_NF90_NOT_OK_RETURN(status=1)
  7447. deallocate( values_int1 )
  7448. case ( MDF_SHORT )
  7449. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7450. values_int2 = int(values,kind=2)
  7451. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  7452. start, count, stride, map )
  7453. IF_NF90_NOT_OK_RETURN(status=1)
  7454. deallocate( values_int2 )
  7455. case ( MDF_INT )
  7456. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7457. values_int4 = int(values,kind=4)
  7458. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  7459. start, count, stride, map )
  7460. IF_NF90_NOT_OK_RETURN(status=1)
  7461. deallocate( values_int4 )
  7462. case ( MDF_FLOAT )
  7463. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7464. values_real4 = real(values,kind=4)
  7465. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  7466. start, count, stride, map )
  7467. IF_NF90_NOT_OK_RETURN(status=1)
  7468. deallocate( values_real4 )
  7469. case ( MDF_DOUBLE )
  7470. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7471. values_real8 = real(values,kind=8)
  7472. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  7473. start, count, stride, map )
  7474. IF_NF90_NOT_OK_RETURN(status=1)
  7475. deallocate( values_real8 )
  7476. case default
  7477. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  7478. TRACEBACK; status=1; return
  7479. end select
  7480. ! just put; let netcdf library convert the right kind:
  7481. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  7482. ! start, count, stride, map )
  7483. !IF_NF90_NOT_OK_RETURN(status=1)
  7484. #endif
  7485. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7486. case default
  7487. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7488. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  7489. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  7490. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  7491. TRACEBACK; status=1; return
  7492. end select
  7493. end do ! file types
  7494. ! ok
  7495. status = 0
  7496. end subroutine MDF_Put_Var_i1_5d
  7497. ! ***
  7498. subroutine MDF_Get_Var_i1_5d( hid, varid, values, status, &
  7499. start, count, stride, map )
  7500. #ifdef with_netcdf
  7501. use NetCDF, only : NF90_Get_Var
  7502. #endif
  7503. ! --- in/out -------------------------------------
  7504. integer, intent(in) :: hid
  7505. integer, intent(in) :: varid
  7506. integer(1), intent(out) :: values(:,:,:,:,:)
  7507. integer, intent(out) :: status
  7508. integer, intent(in), optional :: start (:)
  7509. integer, intent(in), optional :: count (:)
  7510. integer, intent(in), optional :: stride(:)
  7511. integer, intent(in), optional :: map (:)
  7512. ! --- const --------------------------------------
  7513. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_5d'
  7514. ! --- external -----------------------------------
  7515. #ifdef with_hdf4
  7516. integer(hdf4_wpi), external :: sfRData
  7517. #endif
  7518. ! --- local --------------------------------------
  7519. type(MDF_File), pointer :: filep
  7520. type(MDF_Var), pointer :: varp
  7521. integer :: iftype
  7522. integer :: ftype
  7523. #ifdef with_hdf4
  7524. integer :: hdf4_offset(MAX_RANK)
  7525. integer :: hdf4_stride(MAX_RANK)
  7526. integer :: hdf4_count(MAX_RANK)
  7527. integer(1), allocatable :: values_int1(:,:,:,:,:)
  7528. integer(2), allocatable :: values_int2(:,:,:,:,:)
  7529. integer(4), allocatable :: values_int4(:,:,:,:,:)
  7530. integer(8), allocatable :: values_int8(:,:,:,:,:)
  7531. real(4), allocatable :: values_real4(:,:,:,:,:)
  7532. real(8), allocatable :: values_real8(:,:,:,:,:)
  7533. #endif
  7534. ! --- begin --------------------------------------
  7535. ! pointer to file structure:
  7536. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  7537. IF_NOT_OK_RETURN(status=1)
  7538. ! pointer to variable structure:
  7539. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  7540. IF_NOT_OK_RETURN(status=1)
  7541. ! check ...
  7542. if ( size(shape(values)) > varp%ndim ) then
  7543. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  7544. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  7545. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  7546. TRACEBACK; status=1; return
  7547. end if
  7548. ! check ...
  7549. if ( present(start ) ) then
  7550. if ( size(start ) /= varp%ndim ) then
  7551. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7552. write (gol,'(" size start : ",i6)') size(start ); call goErr
  7553. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7554. TRACEBACK; status=1; return
  7555. end if
  7556. end if
  7557. if ( present(count ) ) then
  7558. if ( size(count ) /= varp%ndim ) then
  7559. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7560. write (gol,'(" size count : ",i6)') size(count ); call goErr
  7561. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7562. TRACEBACK; status=1; return
  7563. end if
  7564. end if
  7565. if ( present(stride ) ) then
  7566. if ( size(stride ) /= varp%ndim ) then
  7567. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7568. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  7569. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7570. TRACEBACK; status=1; return
  7571. end if
  7572. end if
  7573. if ( present(map ) ) then
  7574. if ( size(map ) /= varp%ndim ) then
  7575. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7576. write (gol,'(" size map : ",i6)') size(map ); call goErr
  7577. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7578. TRACEBACK; status=1; return
  7579. end if
  7580. end if
  7581. ! loop over file types:
  7582. do iftype = 1, filep%nftype
  7583. ! current type:
  7584. ftype = filep%ftypes(iftype)
  7585. ! select appropriate routine for each type:
  7586. select case ( ftype )
  7587. #ifdef with_hdf4
  7588. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7589. case ( MDF_HDF4 )
  7590. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7591. ! check ...
  7592. if ( present(map ) ) then
  7593. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  7594. TRACEBACK; status=1; return
  7595. end if
  7596. ! fill offset (zero based!), stride, and count :
  7597. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  7598. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  7599. hdf4_count = 1 ! default singleton dimension
  7600. hdf4_count(1:5) = shape(values)
  7601. ! test source type:
  7602. select case ( varp%hdf4_xtype )
  7603. case ( DFNT_INT8 )
  7604. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7605. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  7606. values = int(values_int1,kind=1)
  7607. deallocate( values_int1 )
  7608. case ( DFNT_INT16 )
  7609. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7610. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  7611. values = int(values_int2,kind=1)
  7612. deallocate( values_int2 )
  7613. case ( DFNT_INT32 )
  7614. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7615. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  7616. values = int(values_int4,kind=1)
  7617. deallocate( values_int4 )
  7618. case ( DFNT_INT64 )
  7619. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7620. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  7621. values = int(values_int8,kind=1)
  7622. deallocate( values_int8 )
  7623. case ( DFNT_FLOAT32 )
  7624. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7625. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  7626. values = int(values_real4,kind=1)
  7627. deallocate( values_real4 )
  7628. case ( DFNT_FLOAT64 )
  7629. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  7630. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  7631. values = int(values_real8,kind=1)
  7632. deallocate( values_real8 )
  7633. case default
  7634. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  7635. TRACEBACK; status=1; return
  7636. end select
  7637. if ( status == FAIL ) then
  7638. write (gol,'("reading hdf4 data set:")'); call goErr
  7639. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  7640. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  7641. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  7642. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  7643. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  7644. write (gol,'(" size : ",i6)') size(values); call goErr
  7645. TRACEBACK; status=1; return
  7646. end if
  7647. #endif
  7648. #ifdef with_netcdf
  7649. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7650. case ( MDF_NETCDF, MDF_NETCDF4 )
  7651. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7652. ! read values, converted automatically:
  7653. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  7654. start, count, stride, map )
  7655. IF_NF90_NOT_OK_RETURN(status=1)
  7656. #endif
  7657. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7658. case default
  7659. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7660. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  7661. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  7662. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  7663. TRACEBACK; status=1; return
  7664. end select
  7665. end do ! file types
  7666. ! ok
  7667. status = 0
  7668. end subroutine MDF_Get_Var_i1_5d
  7669. ! ***
  7670. subroutine MDF_Put_Var_i1_6d( hid, varid, values, status, &
  7671. start, count, stride, map )
  7672. #ifdef with_hdf5_beta
  7673. use HDF5, only : HID_T, HSIZE_T
  7674. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  7675. use HDF5, only : H5T_NATIVE_CHARACTER
  7676. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  7677. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  7678. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  7679. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  7680. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  7681. #endif
  7682. #ifdef with_netcdf
  7683. use NetCDF, only : NF90_Put_Var
  7684. #endif
  7685. ! --- in/out -------------------------------------
  7686. integer, intent(in) :: hid
  7687. integer, intent(in) :: varid
  7688. integer(1), intent(in) :: values(:,:,:,:,:,:)
  7689. integer, intent(out) :: status
  7690. integer, intent(in), optional :: start (:)
  7691. integer, intent(in), optional :: count (:)
  7692. integer, intent(in), optional :: stride(:)
  7693. integer, intent(in), optional :: map (:)
  7694. ! --- const --------------------------------------
  7695. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_6d'
  7696. ! --- external -----------------------------------
  7697. #ifdef with_hdf4
  7698. integer(hdf4_wpi), external :: sfWData
  7699. #endif
  7700. ! --- local --------------------------------------
  7701. type(MDF_File), pointer :: filep
  7702. type(MDF_Var), pointer :: varp
  7703. integer :: iftype
  7704. integer :: ftype
  7705. #ifdef with_hdf4
  7706. integer :: hdf4_offset(MAX_RANK)
  7707. integer :: hdf4_stride(MAX_RANK)
  7708. integer :: hdf4_count(MAX_RANK)
  7709. #endif
  7710. #ifdef with_hdf5_beta
  7711. !integer(HID_T) :: hdf5_type_id
  7712. integer(HID_T) :: hdf5_file_space_id
  7713. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  7714. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  7715. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  7716. #endif
  7717. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  7718. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  7719. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  7720. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  7721. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  7722. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  7723. ! --- begin --------------------------------------
  7724. ! pointer to file structure:
  7725. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  7726. IF_NOT_OK_RETURN(status=1)
  7727. ! pointer to variable structure:
  7728. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  7729. IF_NOT_OK_RETURN(status=1)
  7730. ! check ...
  7731. if ( size(shape(values)) > varp%ndim ) then
  7732. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  7733. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  7734. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  7735. TRACEBACK; status=1; return
  7736. end if
  7737. ! check ...
  7738. if ( present(start ) ) then
  7739. if ( size(start ) /= varp%ndim ) then
  7740. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7741. write (gol,'(" size start : ",i6)') size(start ); call goErr
  7742. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7743. TRACEBACK; status=1; return
  7744. end if
  7745. end if
  7746. if ( present(count ) ) then
  7747. if ( size(count ) /= varp%ndim ) then
  7748. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7749. write (gol,'(" size count : ",i6)') size(count ); call goErr
  7750. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7751. TRACEBACK; status=1; return
  7752. end if
  7753. end if
  7754. if ( present(stride ) ) then
  7755. if ( size(stride ) /= varp%ndim ) then
  7756. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7757. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  7758. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7759. TRACEBACK; status=1; return
  7760. end if
  7761. end if
  7762. if ( present(map ) ) then
  7763. if ( size(map ) /= varp%ndim ) then
  7764. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  7765. write (gol,'(" size map : ",i6)') size(map ); call goErr
  7766. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  7767. TRACEBACK; status=1; return
  7768. end if
  7769. end if
  7770. ! loop over file types:
  7771. do iftype = 1, filep%nftype
  7772. ! current type:
  7773. ftype = filep%ftypes(iftype)
  7774. ! select appropriate routine for each type:
  7775. select case ( ftype )
  7776. #ifdef with_hdf4
  7777. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7778. case ( MDF_HDF4 )
  7779. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7780. ! check ...
  7781. if ( present(map ) ) then
  7782. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  7783. TRACEBACK; status=1; return
  7784. end if
  7785. ! fill offset (zero based!) and stride with default values:
  7786. hdf4_offset = 0
  7787. hdf4_stride = 1
  7788. ! count is by default the shape; padd with singleton dimensions:
  7789. hdf4_count = 1; hdf4_count(1:6) = shape(values)
  7790. ! replace by optional arguments if necessary:
  7791. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  7792. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  7793. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  7794. ! test target type;
  7795. ! convert to required kind before entering sfWData,
  7796. ! otherwise segmentation faults on some machines ...
  7797. select case ( varp%xtype )
  7798. case ( MDF_BYTE )
  7799. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7800. values_int1 = int(values,kind=1)
  7801. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7802. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  7803. deallocate( values_int1 )
  7804. case ( MDF_SHORT )
  7805. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7806. values_int2 = int(values,kind=2)
  7807. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7808. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  7809. deallocate( values_int2 )
  7810. case ( MDF_INT )
  7811. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7812. values_int4 = int(values,kind=4)
  7813. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7814. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  7815. deallocate( values_int4 )
  7816. case ( MDF_FLOAT )
  7817. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7818. values_real4 = real(values,kind=4)
  7819. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7820. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  7821. deallocate( values_real4 )
  7822. case ( MDF_DOUBLE )
  7823. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7824. values_real8 = real(values,kind=8)
  7825. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  7826. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  7827. deallocate( values_real8 )
  7828. case default
  7829. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  7830. TRACEBACK; status=1; return
  7831. end select
  7832. if ( status == FAIL ) then
  7833. write (gol,'("writing hdf4 data set:")'); call goErr
  7834. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  7835. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  7836. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  7837. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  7838. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  7839. write (gol,'(" size : ",i12)') size(values); call goErr
  7840. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  7841. TRACEBACK; status=1; return
  7842. end if
  7843. #endif
  7844. #ifdef with_hdf5_beta
  7845. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7846. case ( MDF_HDF5 )
  7847. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7848. ! check ...
  7849. if ( present(map ) ) then
  7850. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  7851. TRACEBACK; status=1; return
  7852. end if
  7853. ! fill offset (zero based!), stride, and count :
  7854. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  7855. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  7856. hdf5_count = 1 ! default singleton dimension
  7857. if ( present(count) ) then
  7858. hdf5_count(1:varp%ndim) = count
  7859. else
  7860. hdf5_count(1:6) = shape(values)
  7861. end if
  7862. ! new dimension:
  7863. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  7864. ! target data space in file:
  7865. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  7866. IF_NOT_OK_RETURN(status=1)
  7867. ! chunked dataset ?
  7868. if ( varp%hdf5_chunked ) then
  7869. ! reset extend:
  7870. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  7871. IF_NOT_OK_RETURN(status=1)
  7872. end if
  7873. ! select hyperslab:
  7874. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  7875. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  7876. stride=hdf5_stride(1:varp%ndim) )
  7877. ! write data:
  7878. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  7879. int(shape(values),kind=HSIZE_T), status, &
  7880. file_space_id=hdf5_file_space_id )
  7881. IF_NOT_OK_RETURN(status=1)
  7882. ! release data space:
  7883. call H5SClose_f( hdf5_file_space_id, status )
  7884. IF_NOT_OK_RETURN(status=1)
  7885. #endif
  7886. #ifdef with_netcdf
  7887. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7888. case ( MDF_NETCDF, MDF_NETCDF4 )
  7889. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7890. ! test target type:
  7891. ! convert to required kind before entering NF90_Put_Var,
  7892. ! otherwise segmentation faults on some machines ...
  7893. select case ( varp%xtype )
  7894. case ( MDF_BYTE )
  7895. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7896. values_int1 = int(values,kind=1)
  7897. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  7898. start, count, stride, map )
  7899. IF_NF90_NOT_OK_RETURN(status=1)
  7900. deallocate( values_int1 )
  7901. case ( MDF_SHORT )
  7902. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7903. values_int2 = int(values,kind=2)
  7904. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  7905. start, count, stride, map )
  7906. IF_NF90_NOT_OK_RETURN(status=1)
  7907. deallocate( values_int2 )
  7908. case ( MDF_INT )
  7909. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7910. values_int4 = int(values,kind=4)
  7911. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  7912. start, count, stride, map )
  7913. IF_NF90_NOT_OK_RETURN(status=1)
  7914. deallocate( values_int4 )
  7915. case ( MDF_FLOAT )
  7916. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7917. values_real4 = real(values,kind=4)
  7918. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  7919. start, count, stride, map )
  7920. IF_NF90_NOT_OK_RETURN(status=1)
  7921. deallocate( values_real4 )
  7922. case ( MDF_DOUBLE )
  7923. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  7924. values_real8 = real(values,kind=8)
  7925. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  7926. start, count, stride, map )
  7927. IF_NF90_NOT_OK_RETURN(status=1)
  7928. deallocate( values_real8 )
  7929. case default
  7930. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  7931. TRACEBACK; status=1; return
  7932. end select
  7933. ! just put; let netcdf library convert the right kind:
  7934. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  7935. ! start, count, stride, map )
  7936. !IF_NF90_NOT_OK_RETURN(status=1)
  7937. #endif
  7938. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7939. case default
  7940. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  7941. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  7942. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  7943. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  7944. TRACEBACK; status=1; return
  7945. end select
  7946. end do ! file types
  7947. ! ok
  7948. status = 0
  7949. end subroutine MDF_Put_Var_i1_6d
  7950. ! ***
  7951. subroutine MDF_Get_Var_i1_6d( hid, varid, values, status, &
  7952. start, count, stride, map )
  7953. #ifdef with_netcdf
  7954. use NetCDF, only : NF90_Get_Var
  7955. #endif
  7956. ! --- in/out -------------------------------------
  7957. integer, intent(in) :: hid
  7958. integer, intent(in) :: varid
  7959. integer(1), intent(out) :: values(:,:,:,:,:,:)
  7960. integer, intent(out) :: status
  7961. integer, intent(in), optional :: start (:)
  7962. integer, intent(in), optional :: count (:)
  7963. integer, intent(in), optional :: stride(:)
  7964. integer, intent(in), optional :: map (:)
  7965. ! --- const --------------------------------------
  7966. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_6d'
  7967. ! --- external -----------------------------------
  7968. #ifdef with_hdf4
  7969. integer(hdf4_wpi), external :: sfRData
  7970. #endif
  7971. ! --- local --------------------------------------
  7972. type(MDF_File), pointer :: filep
  7973. type(MDF_Var), pointer :: varp
  7974. integer :: iftype
  7975. integer :: ftype
  7976. #ifdef with_hdf4
  7977. integer :: hdf4_offset(MAX_RANK)
  7978. integer :: hdf4_stride(MAX_RANK)
  7979. integer :: hdf4_count(MAX_RANK)
  7980. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  7981. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  7982. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  7983. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  7984. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  7985. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  7986. #endif
  7987. ! --- begin --------------------------------------
  7988. ! pointer to file structure:
  7989. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  7990. IF_NOT_OK_RETURN(status=1)
  7991. ! pointer to variable structure:
  7992. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  7993. IF_NOT_OK_RETURN(status=1)
  7994. ! check ...
  7995. if ( size(shape(values)) > varp%ndim ) then
  7996. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  7997. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  7998. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  7999. TRACEBACK; status=1; return
  8000. end if
  8001. ! check ...
  8002. if ( present(start ) ) then
  8003. if ( size(start ) /= varp%ndim ) then
  8004. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8005. write (gol,'(" size start : ",i6)') size(start ); call goErr
  8006. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8007. TRACEBACK; status=1; return
  8008. end if
  8009. end if
  8010. if ( present(count ) ) then
  8011. if ( size(count ) /= varp%ndim ) then
  8012. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8013. write (gol,'(" size count : ",i6)') size(count ); call goErr
  8014. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8015. TRACEBACK; status=1; return
  8016. end if
  8017. end if
  8018. if ( present(stride ) ) then
  8019. if ( size(stride ) /= varp%ndim ) then
  8020. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8021. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  8022. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8023. TRACEBACK; status=1; return
  8024. end if
  8025. end if
  8026. if ( present(map ) ) then
  8027. if ( size(map ) /= varp%ndim ) then
  8028. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8029. write (gol,'(" size map : ",i6)') size(map ); call goErr
  8030. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8031. TRACEBACK; status=1; return
  8032. end if
  8033. end if
  8034. ! loop over file types:
  8035. do iftype = 1, filep%nftype
  8036. ! current type:
  8037. ftype = filep%ftypes(iftype)
  8038. ! select appropriate routine for each type:
  8039. select case ( ftype )
  8040. #ifdef with_hdf4
  8041. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8042. case ( MDF_HDF4 )
  8043. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8044. ! check ...
  8045. if ( present(map ) ) then
  8046. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  8047. TRACEBACK; status=1; return
  8048. end if
  8049. ! fill offset (zero based!), stride, and count :
  8050. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  8051. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  8052. hdf4_count = 1 ! default singleton dimension
  8053. hdf4_count(1:6) = shape(values)
  8054. ! test source type:
  8055. select case ( varp%hdf4_xtype )
  8056. case ( DFNT_INT8 )
  8057. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8058. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  8059. values = int(values_int1,kind=1)
  8060. deallocate( values_int1 )
  8061. case ( DFNT_INT16 )
  8062. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8063. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  8064. values = int(values_int2,kind=1)
  8065. deallocate( values_int2 )
  8066. case ( DFNT_INT32 )
  8067. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8068. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  8069. values = int(values_int4,kind=1)
  8070. deallocate( values_int4 )
  8071. case ( DFNT_INT64 )
  8072. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8073. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  8074. values = int(values_int8,kind=1)
  8075. deallocate( values_int8 )
  8076. case ( DFNT_FLOAT32 )
  8077. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8078. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  8079. values = int(values_real4,kind=1)
  8080. deallocate( values_real4 )
  8081. case ( DFNT_FLOAT64 )
  8082. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  8083. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  8084. values = int(values_real8,kind=1)
  8085. deallocate( values_real8 )
  8086. case default
  8087. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  8088. TRACEBACK; status=1; return
  8089. end select
  8090. if ( status == FAIL ) then
  8091. write (gol,'("reading hdf4 data set:")'); call goErr
  8092. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  8093. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  8094. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  8095. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  8096. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  8097. write (gol,'(" size : ",i6)') size(values); call goErr
  8098. TRACEBACK; status=1; return
  8099. end if
  8100. #endif
  8101. #ifdef with_netcdf
  8102. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8103. case ( MDF_NETCDF, MDF_NETCDF4 )
  8104. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8105. ! read values, converted automatically:
  8106. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  8107. start, count, stride, map )
  8108. IF_NF90_NOT_OK_RETURN(status=1)
  8109. #endif
  8110. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8111. case default
  8112. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8113. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  8114. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  8115. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  8116. TRACEBACK; status=1; return
  8117. end select
  8118. end do ! file types
  8119. ! ok
  8120. status = 0
  8121. end subroutine MDF_Get_Var_i1_6d
  8122. ! ***
  8123. subroutine MDF_Put_Var_i1_7d( hid, varid, values, status, &
  8124. start, count, stride, map )
  8125. #ifdef with_hdf5_beta
  8126. use HDF5, only : HID_T, HSIZE_T
  8127. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  8128. use HDF5, only : H5T_NATIVE_CHARACTER
  8129. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  8130. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  8131. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  8132. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  8133. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  8134. #endif
  8135. #ifdef with_netcdf
  8136. use NetCDF, only : NF90_Put_Var
  8137. #endif
  8138. ! --- in/out -------------------------------------
  8139. integer, intent(in) :: hid
  8140. integer, intent(in) :: varid
  8141. integer(1), intent(in) :: values(:,:,:,:,:,:,:)
  8142. integer, intent(out) :: status
  8143. integer, intent(in), optional :: start (:)
  8144. integer, intent(in), optional :: count (:)
  8145. integer, intent(in), optional :: stride(:)
  8146. integer, intent(in), optional :: map (:)
  8147. ! --- const --------------------------------------
  8148. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_7d'
  8149. ! --- external -----------------------------------
  8150. #ifdef with_hdf4
  8151. integer(hdf4_wpi), external :: sfWData
  8152. #endif
  8153. ! --- local --------------------------------------
  8154. type(MDF_File), pointer :: filep
  8155. type(MDF_Var), pointer :: varp
  8156. integer :: iftype
  8157. integer :: ftype
  8158. #ifdef with_hdf4
  8159. integer :: hdf4_offset(MAX_RANK)
  8160. integer :: hdf4_stride(MAX_RANK)
  8161. integer :: hdf4_count(MAX_RANK)
  8162. #endif
  8163. #ifdef with_hdf5_beta
  8164. !integer(HID_T) :: hdf5_type_id
  8165. integer(HID_T) :: hdf5_file_space_id
  8166. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  8167. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  8168. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  8169. #endif
  8170. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  8171. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  8172. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  8173. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  8174. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  8175. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  8176. ! --- begin --------------------------------------
  8177. ! pointer to file structure:
  8178. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  8179. IF_NOT_OK_RETURN(status=1)
  8180. ! pointer to variable structure:
  8181. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  8182. IF_NOT_OK_RETURN(status=1)
  8183. ! check ...
  8184. if ( size(shape(values)) > varp%ndim ) then
  8185. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  8186. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  8187. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  8188. TRACEBACK; status=1; return
  8189. end if
  8190. ! check ...
  8191. if ( present(start ) ) then
  8192. if ( size(start ) /= varp%ndim ) then
  8193. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8194. write (gol,'(" size start : ",i6)') size(start ); call goErr
  8195. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8196. TRACEBACK; status=1; return
  8197. end if
  8198. end if
  8199. if ( present(count ) ) then
  8200. if ( size(count ) /= varp%ndim ) then
  8201. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8202. write (gol,'(" size count : ",i6)') size(count ); call goErr
  8203. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8204. TRACEBACK; status=1; return
  8205. end if
  8206. end if
  8207. if ( present(stride ) ) then
  8208. if ( size(stride ) /= varp%ndim ) then
  8209. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8210. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  8211. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8212. TRACEBACK; status=1; return
  8213. end if
  8214. end if
  8215. if ( present(map ) ) then
  8216. if ( size(map ) /= varp%ndim ) then
  8217. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8218. write (gol,'(" size map : ",i6)') size(map ); call goErr
  8219. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8220. TRACEBACK; status=1; return
  8221. end if
  8222. end if
  8223. ! loop over file types:
  8224. do iftype = 1, filep%nftype
  8225. ! current type:
  8226. ftype = filep%ftypes(iftype)
  8227. ! select appropriate routine for each type:
  8228. select case ( ftype )
  8229. #ifdef with_hdf4
  8230. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8231. case ( MDF_HDF4 )
  8232. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8233. ! check ...
  8234. if ( present(map ) ) then
  8235. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  8236. TRACEBACK; status=1; return
  8237. end if
  8238. ! fill offset (zero based!) and stride with default values:
  8239. hdf4_offset = 0
  8240. hdf4_stride = 1
  8241. ! count is by default the shape; padd with singleton dimensions:
  8242. hdf4_count = 1; hdf4_count(1:7) = shape(values)
  8243. ! replace by optional arguments if necessary:
  8244. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  8245. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  8246. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  8247. ! test target type;
  8248. ! convert to required kind before entering sfWData,
  8249. ! otherwise segmentation faults on some machines ...
  8250. select case ( varp%xtype )
  8251. case ( MDF_BYTE )
  8252. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8253. values_int1 = int(values,kind=1)
  8254. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8255. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  8256. deallocate( values_int1 )
  8257. case ( MDF_SHORT )
  8258. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8259. values_int2 = int(values,kind=2)
  8260. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8261. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  8262. deallocate( values_int2 )
  8263. case ( MDF_INT )
  8264. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8265. values_int4 = int(values,kind=4)
  8266. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8267. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  8268. deallocate( values_int4 )
  8269. case ( MDF_FLOAT )
  8270. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8271. values_real4 = real(values,kind=4)
  8272. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8273. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  8274. deallocate( values_real4 )
  8275. case ( MDF_DOUBLE )
  8276. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8277. values_real8 = real(values,kind=8)
  8278. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8279. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  8280. deallocate( values_real8 )
  8281. case default
  8282. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  8283. TRACEBACK; status=1; return
  8284. end select
  8285. if ( status == FAIL ) then
  8286. write (gol,'("writing hdf4 data set:")'); call goErr
  8287. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  8288. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  8289. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  8290. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  8291. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  8292. write (gol,'(" size : ",i12)') size(values); call goErr
  8293. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  8294. TRACEBACK; status=1; return
  8295. end if
  8296. #endif
  8297. #ifdef with_hdf5_beta
  8298. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8299. case ( MDF_HDF5 )
  8300. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8301. ! check ...
  8302. if ( present(map ) ) then
  8303. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  8304. TRACEBACK; status=1; return
  8305. end if
  8306. ! fill offset (zero based!), stride, and count :
  8307. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  8308. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  8309. hdf5_count = 1 ! default singleton dimension
  8310. if ( present(count) ) then
  8311. hdf5_count(1:varp%ndim) = count
  8312. else
  8313. hdf5_count(1:7) = shape(values)
  8314. end if
  8315. ! new dimension:
  8316. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  8317. ! target data space in file:
  8318. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  8319. IF_NOT_OK_RETURN(status=1)
  8320. ! chunked dataset ?
  8321. if ( varp%hdf5_chunked ) then
  8322. ! reset extend:
  8323. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  8324. IF_NOT_OK_RETURN(status=1)
  8325. end if
  8326. ! select hyperslab:
  8327. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  8328. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  8329. stride=hdf5_stride(1:varp%ndim) )
  8330. ! write data:
  8331. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  8332. int(shape(values),kind=HSIZE_T), status, &
  8333. file_space_id=hdf5_file_space_id )
  8334. IF_NOT_OK_RETURN(status=1)
  8335. ! release data space:
  8336. call H5SClose_f( hdf5_file_space_id, status )
  8337. IF_NOT_OK_RETURN(status=1)
  8338. #endif
  8339. #ifdef with_netcdf
  8340. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8341. case ( MDF_NETCDF, MDF_NETCDF4 )
  8342. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8343. ! test target type:
  8344. ! convert to required kind before entering NF90_Put_Var,
  8345. ! otherwise segmentation faults on some machines ...
  8346. select case ( varp%xtype )
  8347. case ( MDF_BYTE )
  8348. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8349. values_int1 = int(values,kind=1)
  8350. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  8351. start, count, stride, map )
  8352. IF_NF90_NOT_OK_RETURN(status=1)
  8353. deallocate( values_int1 )
  8354. case ( MDF_SHORT )
  8355. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8356. values_int2 = int(values,kind=2)
  8357. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  8358. start, count, stride, map )
  8359. IF_NF90_NOT_OK_RETURN(status=1)
  8360. deallocate( values_int2 )
  8361. case ( MDF_INT )
  8362. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8363. values_int4 = int(values,kind=4)
  8364. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  8365. start, count, stride, map )
  8366. IF_NF90_NOT_OK_RETURN(status=1)
  8367. deallocate( values_int4 )
  8368. case ( MDF_FLOAT )
  8369. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8370. values_real4 = real(values,kind=4)
  8371. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  8372. start, count, stride, map )
  8373. IF_NF90_NOT_OK_RETURN(status=1)
  8374. deallocate( values_real4 )
  8375. case ( MDF_DOUBLE )
  8376. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8377. values_real8 = real(values,kind=8)
  8378. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  8379. start, count, stride, map )
  8380. IF_NF90_NOT_OK_RETURN(status=1)
  8381. deallocate( values_real8 )
  8382. case default
  8383. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  8384. TRACEBACK; status=1; return
  8385. end select
  8386. ! just put; let netcdf library convert the right kind:
  8387. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  8388. ! start, count, stride, map )
  8389. !IF_NF90_NOT_OK_RETURN(status=1)
  8390. #endif
  8391. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8392. case default
  8393. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8394. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  8395. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  8396. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  8397. TRACEBACK; status=1; return
  8398. end select
  8399. end do ! file types
  8400. ! ok
  8401. status = 0
  8402. end subroutine MDF_Put_Var_i1_7d
  8403. ! ***
  8404. subroutine MDF_Get_Var_i1_7d( hid, varid, values, status, &
  8405. start, count, stride, map )
  8406. #ifdef with_netcdf
  8407. use NetCDF, only : NF90_Get_Var
  8408. #endif
  8409. ! --- in/out -------------------------------------
  8410. integer, intent(in) :: hid
  8411. integer, intent(in) :: varid
  8412. integer(1), intent(out) :: values(:,:,:,:,:,:,:)
  8413. integer, intent(out) :: status
  8414. integer, intent(in), optional :: start (:)
  8415. integer, intent(in), optional :: count (:)
  8416. integer, intent(in), optional :: stride(:)
  8417. integer, intent(in), optional :: map (:)
  8418. ! --- const --------------------------------------
  8419. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_7d'
  8420. ! --- external -----------------------------------
  8421. #ifdef with_hdf4
  8422. integer(hdf4_wpi), external :: sfRData
  8423. #endif
  8424. ! --- local --------------------------------------
  8425. type(MDF_File), pointer :: filep
  8426. type(MDF_Var), pointer :: varp
  8427. integer :: iftype
  8428. integer :: ftype
  8429. #ifdef with_hdf4
  8430. integer :: hdf4_offset(MAX_RANK)
  8431. integer :: hdf4_stride(MAX_RANK)
  8432. integer :: hdf4_count(MAX_RANK)
  8433. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  8434. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  8435. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  8436. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  8437. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  8438. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  8439. #endif
  8440. ! --- begin --------------------------------------
  8441. ! pointer to file structure:
  8442. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  8443. IF_NOT_OK_RETURN(status=1)
  8444. ! pointer to variable structure:
  8445. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  8446. IF_NOT_OK_RETURN(status=1)
  8447. ! check ...
  8448. if ( size(shape(values)) > varp%ndim ) then
  8449. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  8450. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  8451. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  8452. TRACEBACK; status=1; return
  8453. end if
  8454. ! check ...
  8455. if ( present(start ) ) then
  8456. if ( size(start ) /= varp%ndim ) then
  8457. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8458. write (gol,'(" size start : ",i6)') size(start ); call goErr
  8459. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8460. TRACEBACK; status=1; return
  8461. end if
  8462. end if
  8463. if ( present(count ) ) then
  8464. if ( size(count ) /= varp%ndim ) then
  8465. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8466. write (gol,'(" size count : ",i6)') size(count ); call goErr
  8467. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8468. TRACEBACK; status=1; return
  8469. end if
  8470. end if
  8471. if ( present(stride ) ) then
  8472. if ( size(stride ) /= varp%ndim ) then
  8473. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8474. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  8475. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8476. TRACEBACK; status=1; return
  8477. end if
  8478. end if
  8479. if ( present(map ) ) then
  8480. if ( size(map ) /= varp%ndim ) then
  8481. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8482. write (gol,'(" size map : ",i6)') size(map ); call goErr
  8483. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8484. TRACEBACK; status=1; return
  8485. end if
  8486. end if
  8487. ! loop over file types:
  8488. do iftype = 1, filep%nftype
  8489. ! current type:
  8490. ftype = filep%ftypes(iftype)
  8491. ! select appropriate routine for each type:
  8492. select case ( ftype )
  8493. #ifdef with_hdf4
  8494. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8495. case ( MDF_HDF4 )
  8496. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8497. ! check ...
  8498. if ( present(map ) ) then
  8499. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  8500. TRACEBACK; status=1; return
  8501. end if
  8502. ! fill offset (zero based!), stride, and count :
  8503. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  8504. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  8505. hdf4_count = 1 ! default singleton dimension
  8506. hdf4_count(1:7) = shape(values)
  8507. ! test source type:
  8508. select case ( varp%hdf4_xtype )
  8509. case ( DFNT_INT8 )
  8510. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8511. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  8512. values = int(values_int1,kind=1)
  8513. deallocate( values_int1 )
  8514. case ( DFNT_INT16 )
  8515. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8516. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  8517. values = int(values_int2,kind=1)
  8518. deallocate( values_int2 )
  8519. case ( DFNT_INT32 )
  8520. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8521. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  8522. values = int(values_int4,kind=1)
  8523. deallocate( values_int4 )
  8524. case ( DFNT_INT64 )
  8525. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8526. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  8527. values = int(values_int8,kind=1)
  8528. deallocate( values_int8 )
  8529. case ( DFNT_FLOAT32 )
  8530. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8531. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  8532. values = int(values_real4,kind=1)
  8533. deallocate( values_real4 )
  8534. case ( DFNT_FLOAT64 )
  8535. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  8536. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  8537. values = int(values_real8,kind=1)
  8538. deallocate( values_real8 )
  8539. case default
  8540. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  8541. TRACEBACK; status=1; return
  8542. end select
  8543. if ( status == FAIL ) then
  8544. write (gol,'("reading hdf4 data set:")'); call goErr
  8545. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  8546. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  8547. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  8548. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  8549. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  8550. write (gol,'(" size : ",i6)') size(values); call goErr
  8551. TRACEBACK; status=1; return
  8552. end if
  8553. #endif
  8554. #ifdef with_netcdf
  8555. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8556. case ( MDF_NETCDF, MDF_NETCDF4 )
  8557. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8558. ! read values, converted automatically:
  8559. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  8560. start, count, stride, map )
  8561. IF_NF90_NOT_OK_RETURN(status=1)
  8562. #endif
  8563. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8564. case default
  8565. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8566. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  8567. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  8568. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  8569. TRACEBACK; status=1; return
  8570. end select
  8571. end do ! file types
  8572. ! ok
  8573. status = 0
  8574. end subroutine MDF_Get_Var_i1_7d
  8575. ! ***
  8576. subroutine MDF_Put_Var_i2_1d( hid, varid, values, status, &
  8577. start, count, stride, map )
  8578. #ifdef with_hdf5_beta
  8579. use HDF5, only : HID_T, HSIZE_T
  8580. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  8581. use HDF5, only : H5T_NATIVE_CHARACTER
  8582. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  8583. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  8584. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  8585. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  8586. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  8587. #endif
  8588. #ifdef with_netcdf
  8589. use NetCDF, only : NF90_Put_Var
  8590. #endif
  8591. ! --- in/out -------------------------------------
  8592. integer, intent(in) :: hid
  8593. integer, intent(in) :: varid
  8594. integer(2), intent(in) :: values(:)
  8595. integer, intent(out) :: status
  8596. integer, intent(in), optional :: start (:)
  8597. integer, intent(in), optional :: count (:)
  8598. integer, intent(in), optional :: stride(:)
  8599. integer, intent(in), optional :: map (:)
  8600. ! --- const --------------------------------------
  8601. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_1d'
  8602. ! --- external -----------------------------------
  8603. #ifdef with_hdf4
  8604. integer(hdf4_wpi), external :: sfWData
  8605. #endif
  8606. ! --- local --------------------------------------
  8607. type(MDF_File), pointer :: filep
  8608. type(MDF_Var), pointer :: varp
  8609. integer :: iftype
  8610. integer :: ftype
  8611. #ifdef with_hdf4
  8612. integer :: hdf4_offset(MAX_RANK)
  8613. integer :: hdf4_stride(MAX_RANK)
  8614. integer :: hdf4_count(MAX_RANK)
  8615. #endif
  8616. #ifdef with_hdf5_beta
  8617. !integer(HID_T) :: hdf5_type_id
  8618. integer(HID_T) :: hdf5_file_space_id
  8619. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  8620. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  8621. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  8622. #endif
  8623. integer(1), allocatable :: values_int1(:)
  8624. integer(2), allocatable :: values_int2(:)
  8625. integer(4), allocatable :: values_int4(:)
  8626. integer(8), allocatable :: values_int8(:)
  8627. real(4), allocatable :: values_real4(:)
  8628. real(8), allocatable :: values_real8(:)
  8629. ! --- begin --------------------------------------
  8630. ! pointer to file structure:
  8631. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  8632. IF_NOT_OK_RETURN(status=1)
  8633. ! pointer to variable structure:
  8634. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  8635. IF_NOT_OK_RETURN(status=1)
  8636. ! check ...
  8637. if ( size(shape(values)) > varp%ndim ) then
  8638. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  8639. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  8640. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  8641. TRACEBACK; status=1; return
  8642. end if
  8643. ! check ...
  8644. if ( present(start ) ) then
  8645. if ( size(start ) /= varp%ndim ) then
  8646. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8647. write (gol,'(" size start : ",i6)') size(start ); call goErr
  8648. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8649. TRACEBACK; status=1; return
  8650. end if
  8651. end if
  8652. if ( present(count ) ) then
  8653. if ( size(count ) /= varp%ndim ) then
  8654. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8655. write (gol,'(" size count : ",i6)') size(count ); call goErr
  8656. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8657. TRACEBACK; status=1; return
  8658. end if
  8659. end if
  8660. if ( present(stride ) ) then
  8661. if ( size(stride ) /= varp%ndim ) then
  8662. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8663. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  8664. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8665. TRACEBACK; status=1; return
  8666. end if
  8667. end if
  8668. if ( present(map ) ) then
  8669. if ( size(map ) /= varp%ndim ) then
  8670. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8671. write (gol,'(" size map : ",i6)') size(map ); call goErr
  8672. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8673. TRACEBACK; status=1; return
  8674. end if
  8675. end if
  8676. ! loop over file types:
  8677. do iftype = 1, filep%nftype
  8678. ! current type:
  8679. ftype = filep%ftypes(iftype)
  8680. ! select appropriate routine for each type:
  8681. select case ( ftype )
  8682. #ifdef with_hdf4
  8683. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8684. case ( MDF_HDF4 )
  8685. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8686. ! check ...
  8687. if ( present(map ) ) then
  8688. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  8689. TRACEBACK; status=1; return
  8690. end if
  8691. ! fill offset (zero based!) and stride with default values:
  8692. hdf4_offset = 0
  8693. hdf4_stride = 1
  8694. ! count is by default the shape; padd with singleton dimensions:
  8695. hdf4_count = 1; hdf4_count(1:1) = shape(values)
  8696. ! replace by optional arguments if necessary:
  8697. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  8698. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  8699. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  8700. ! test target type;
  8701. ! convert to required kind before entering sfWData,
  8702. ! otherwise segmentation faults on some machines ...
  8703. select case ( varp%xtype )
  8704. case ( MDF_BYTE )
  8705. allocate( values_int1(size(values,1)) )
  8706. values_int1 = int(values,kind=1)
  8707. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8708. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  8709. deallocate( values_int1 )
  8710. case ( MDF_SHORT )
  8711. allocate( values_int2(size(values,1)) )
  8712. values_int2 = int(values,kind=2)
  8713. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8714. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  8715. deallocate( values_int2 )
  8716. case ( MDF_INT )
  8717. allocate( values_int4(size(values,1)) )
  8718. values_int4 = int(values,kind=4)
  8719. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8720. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  8721. deallocate( values_int4 )
  8722. case ( MDF_FLOAT )
  8723. allocate( values_real4(size(values,1)) )
  8724. values_real4 = real(values,kind=4)
  8725. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8726. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  8727. deallocate( values_real4 )
  8728. case ( MDF_DOUBLE )
  8729. allocate( values_real8(size(values,1)) )
  8730. values_real8 = real(values,kind=8)
  8731. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  8732. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  8733. deallocate( values_real8 )
  8734. case default
  8735. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  8736. TRACEBACK; status=1; return
  8737. end select
  8738. if ( status == FAIL ) then
  8739. write (gol,'("writing hdf4 data set:")'); call goErr
  8740. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  8741. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  8742. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  8743. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  8744. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  8745. write (gol,'(" size : ",i12)') size(values); call goErr
  8746. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  8747. TRACEBACK; status=1; return
  8748. end if
  8749. #endif
  8750. #ifdef with_hdf5_beta
  8751. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8752. case ( MDF_HDF5 )
  8753. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8754. ! check ...
  8755. if ( present(map ) ) then
  8756. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  8757. TRACEBACK; status=1; return
  8758. end if
  8759. ! fill offset (zero based!), stride, and count :
  8760. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  8761. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  8762. hdf5_count = 1 ! default singleton dimension
  8763. if ( present(count) ) then
  8764. hdf5_count(1:varp%ndim) = count
  8765. else
  8766. hdf5_count(1:1) = shape(values)
  8767. end if
  8768. ! new dimension:
  8769. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  8770. ! target data space in file:
  8771. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  8772. IF_NOT_OK_RETURN(status=1)
  8773. ! chunked dataset ?
  8774. if ( varp%hdf5_chunked ) then
  8775. ! reset extend:
  8776. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  8777. IF_NOT_OK_RETURN(status=1)
  8778. end if
  8779. ! select hyperslab:
  8780. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  8781. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  8782. stride=hdf5_stride(1:varp%ndim) )
  8783. ! write data:
  8784. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  8785. int(shape(values),kind=HSIZE_T), status, &
  8786. file_space_id=hdf5_file_space_id )
  8787. IF_NOT_OK_RETURN(status=1)
  8788. ! release data space:
  8789. call H5SClose_f( hdf5_file_space_id, status )
  8790. IF_NOT_OK_RETURN(status=1)
  8791. #endif
  8792. #ifdef with_netcdf
  8793. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8794. case ( MDF_NETCDF, MDF_NETCDF4 )
  8795. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8796. ! test target type:
  8797. ! convert to required kind before entering NF90_Put_Var,
  8798. ! otherwise segmentation faults on some machines ...
  8799. select case ( varp%xtype )
  8800. case ( MDF_BYTE )
  8801. allocate( values_int1(size(values,1)) )
  8802. values_int1 = int(values,kind=1)
  8803. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  8804. start, count, stride, map )
  8805. IF_NF90_NOT_OK_RETURN(status=1)
  8806. deallocate( values_int1 )
  8807. case ( MDF_SHORT )
  8808. allocate( values_int2(size(values,1)) )
  8809. values_int2 = int(values,kind=2)
  8810. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  8811. start, count, stride, map )
  8812. IF_NF90_NOT_OK_RETURN(status=1)
  8813. deallocate( values_int2 )
  8814. case ( MDF_INT )
  8815. allocate( values_int4(size(values,1)) )
  8816. values_int4 = int(values,kind=4)
  8817. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  8818. start, count, stride, map )
  8819. IF_NF90_NOT_OK_RETURN(status=1)
  8820. deallocate( values_int4 )
  8821. case ( MDF_FLOAT )
  8822. allocate( values_real4(size(values,1)) )
  8823. values_real4 = real(values,kind=4)
  8824. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  8825. start, count, stride, map )
  8826. IF_NF90_NOT_OK_RETURN(status=1)
  8827. deallocate( values_real4 )
  8828. case ( MDF_DOUBLE )
  8829. allocate( values_real8(size(values,1)) )
  8830. values_real8 = real(values,kind=8)
  8831. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  8832. start, count, stride, map )
  8833. IF_NF90_NOT_OK_RETURN(status=1)
  8834. deallocate( values_real8 )
  8835. case default
  8836. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  8837. TRACEBACK; status=1; return
  8838. end select
  8839. ! just put; let netcdf library convert the right kind:
  8840. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  8841. ! start, count, stride, map )
  8842. !IF_NF90_NOT_OK_RETURN(status=1)
  8843. #endif
  8844. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8845. case default
  8846. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8847. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  8848. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  8849. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  8850. TRACEBACK; status=1; return
  8851. end select
  8852. end do ! file types
  8853. ! ok
  8854. status = 0
  8855. end subroutine MDF_Put_Var_i2_1d
  8856. ! ***
  8857. subroutine MDF_Get_Var_i2_1d( hid, varid, values, status, &
  8858. start, count, stride, map )
  8859. #ifdef with_netcdf
  8860. use NetCDF, only : NF90_Get_Var
  8861. #endif
  8862. ! --- in/out -------------------------------------
  8863. integer, intent(in) :: hid
  8864. integer, intent(in) :: varid
  8865. integer(2), intent(out) :: values(:)
  8866. integer, intent(out) :: status
  8867. integer, intent(in), optional :: start (:)
  8868. integer, intent(in), optional :: count (:)
  8869. integer, intent(in), optional :: stride(:)
  8870. integer, intent(in), optional :: map (:)
  8871. ! --- const --------------------------------------
  8872. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_1d'
  8873. ! --- external -----------------------------------
  8874. #ifdef with_hdf4
  8875. integer(hdf4_wpi), external :: sfRData
  8876. #endif
  8877. ! --- local --------------------------------------
  8878. type(MDF_File), pointer :: filep
  8879. type(MDF_Var), pointer :: varp
  8880. integer :: iftype
  8881. integer :: ftype
  8882. #ifdef with_hdf4
  8883. integer :: hdf4_offset(MAX_RANK)
  8884. integer :: hdf4_stride(MAX_RANK)
  8885. integer :: hdf4_count(MAX_RANK)
  8886. integer(1), allocatable :: values_int1(:)
  8887. integer(2), allocatable :: values_int2(:)
  8888. integer(4), allocatable :: values_int4(:)
  8889. integer(8), allocatable :: values_int8(:)
  8890. real(4), allocatable :: values_real4(:)
  8891. real(8), allocatable :: values_real8(:)
  8892. #endif
  8893. ! --- begin --------------------------------------
  8894. ! pointer to file structure:
  8895. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  8896. IF_NOT_OK_RETURN(status=1)
  8897. ! pointer to variable structure:
  8898. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  8899. IF_NOT_OK_RETURN(status=1)
  8900. ! check ...
  8901. if ( size(shape(values)) > varp%ndim ) then
  8902. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  8903. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  8904. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  8905. TRACEBACK; status=1; return
  8906. end if
  8907. ! check ...
  8908. if ( present(start ) ) then
  8909. if ( size(start ) /= varp%ndim ) then
  8910. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8911. write (gol,'(" size start : ",i6)') size(start ); call goErr
  8912. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8913. TRACEBACK; status=1; return
  8914. end if
  8915. end if
  8916. if ( present(count ) ) then
  8917. if ( size(count ) /= varp%ndim ) then
  8918. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8919. write (gol,'(" size count : ",i6)') size(count ); call goErr
  8920. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8921. TRACEBACK; status=1; return
  8922. end if
  8923. end if
  8924. if ( present(stride ) ) then
  8925. if ( size(stride ) /= varp%ndim ) then
  8926. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8927. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  8928. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8929. TRACEBACK; status=1; return
  8930. end if
  8931. end if
  8932. if ( present(map ) ) then
  8933. if ( size(map ) /= varp%ndim ) then
  8934. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  8935. write (gol,'(" size map : ",i6)') size(map ); call goErr
  8936. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  8937. TRACEBACK; status=1; return
  8938. end if
  8939. end if
  8940. ! loop over file types:
  8941. do iftype = 1, filep%nftype
  8942. ! current type:
  8943. ftype = filep%ftypes(iftype)
  8944. ! select appropriate routine for each type:
  8945. select case ( ftype )
  8946. #ifdef with_hdf4
  8947. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8948. case ( MDF_HDF4 )
  8949. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  8950. ! check ...
  8951. if ( present(map ) ) then
  8952. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  8953. TRACEBACK; status=1; return
  8954. end if
  8955. ! fill offset (zero based!), stride, and count :
  8956. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  8957. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  8958. hdf4_count = 1 ! default singleton dimension
  8959. hdf4_count(1:1) = shape(values)
  8960. ! test source type:
  8961. select case ( varp%hdf4_xtype )
  8962. case ( DFNT_INT8 )
  8963. allocate( values_int1(size(values,1)) )
  8964. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  8965. values = int(values_int1,kind=2)
  8966. deallocate( values_int1 )
  8967. case ( DFNT_INT16 )
  8968. allocate( values_int2(size(values,1)) )
  8969. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  8970. values = int(values_int2,kind=2)
  8971. deallocate( values_int2 )
  8972. case ( DFNT_INT32 )
  8973. allocate( values_int4(size(values,1)) )
  8974. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  8975. values = int(values_int4,kind=2)
  8976. deallocate( values_int4 )
  8977. case ( DFNT_INT64 )
  8978. allocate( values_int8(size(values,1)) )
  8979. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  8980. values = int(values_int8,kind=2)
  8981. deallocate( values_int8 )
  8982. case ( DFNT_FLOAT32 )
  8983. allocate( values_real4(size(values,1)) )
  8984. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  8985. values = int(values_real4,kind=2)
  8986. deallocate( values_real4 )
  8987. case ( DFNT_FLOAT64 )
  8988. allocate( values_real8(size(values,1)) )
  8989. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  8990. values = int(values_real8,kind=2)
  8991. deallocate( values_real8 )
  8992. case default
  8993. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  8994. TRACEBACK; status=1; return
  8995. end select
  8996. if ( status == FAIL ) then
  8997. write (gol,'("reading hdf4 data set:")'); call goErr
  8998. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  8999. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  9000. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  9001. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  9002. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  9003. write (gol,'(" size : ",i6)') size(values); call goErr
  9004. TRACEBACK; status=1; return
  9005. end if
  9006. #endif
  9007. #ifdef with_netcdf
  9008. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9009. case ( MDF_NETCDF, MDF_NETCDF4 )
  9010. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9011. ! read values, converted automatically:
  9012. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  9013. start, count, stride, map )
  9014. IF_NF90_NOT_OK_RETURN(status=1)
  9015. #endif
  9016. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9017. case default
  9018. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9019. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  9020. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  9021. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  9022. TRACEBACK; status=1; return
  9023. end select
  9024. end do ! file types
  9025. ! ok
  9026. status = 0
  9027. end subroutine MDF_Get_Var_i2_1d
  9028. ! ***
  9029. subroutine MDF_Put_Var_i2_2d( hid, varid, values, status, &
  9030. start, count, stride, map )
  9031. #ifdef with_hdf5_beta
  9032. use HDF5, only : HID_T, HSIZE_T
  9033. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  9034. use HDF5, only : H5T_NATIVE_CHARACTER
  9035. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  9036. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  9037. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  9038. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  9039. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  9040. #endif
  9041. #ifdef with_netcdf
  9042. use NetCDF, only : NF90_Put_Var
  9043. #endif
  9044. ! --- in/out -------------------------------------
  9045. integer, intent(in) :: hid
  9046. integer, intent(in) :: varid
  9047. integer(2), intent(in) :: values(:,:)
  9048. integer, intent(out) :: status
  9049. integer, intent(in), optional :: start (:)
  9050. integer, intent(in), optional :: count (:)
  9051. integer, intent(in), optional :: stride(:)
  9052. integer, intent(in), optional :: map (:)
  9053. ! --- const --------------------------------------
  9054. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_2d'
  9055. ! --- external -----------------------------------
  9056. #ifdef with_hdf4
  9057. integer(hdf4_wpi), external :: sfWData
  9058. #endif
  9059. ! --- local --------------------------------------
  9060. type(MDF_File), pointer :: filep
  9061. type(MDF_Var), pointer :: varp
  9062. integer :: iftype
  9063. integer :: ftype
  9064. #ifdef with_hdf4
  9065. integer :: hdf4_offset(MAX_RANK)
  9066. integer :: hdf4_stride(MAX_RANK)
  9067. integer :: hdf4_count(MAX_RANK)
  9068. #endif
  9069. #ifdef with_hdf5_beta
  9070. !integer(HID_T) :: hdf5_type_id
  9071. integer(HID_T) :: hdf5_file_space_id
  9072. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  9073. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  9074. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  9075. #endif
  9076. integer(1), allocatable :: values_int1(:,:)
  9077. integer(2), allocatable :: values_int2(:,:)
  9078. integer(4), allocatable :: values_int4(:,:)
  9079. integer(8), allocatable :: values_int8(:,:)
  9080. real(4), allocatable :: values_real4(:,:)
  9081. real(8), allocatable :: values_real8(:,:)
  9082. ! --- begin --------------------------------------
  9083. ! pointer to file structure:
  9084. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  9085. IF_NOT_OK_RETURN(status=1)
  9086. ! pointer to variable structure:
  9087. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  9088. IF_NOT_OK_RETURN(status=1)
  9089. ! check ...
  9090. if ( size(shape(values)) > varp%ndim ) then
  9091. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  9092. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  9093. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  9094. TRACEBACK; status=1; return
  9095. end if
  9096. ! check ...
  9097. if ( present(start ) ) then
  9098. if ( size(start ) /= varp%ndim ) then
  9099. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9100. write (gol,'(" size start : ",i6)') size(start ); call goErr
  9101. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9102. TRACEBACK; status=1; return
  9103. end if
  9104. end if
  9105. if ( present(count ) ) then
  9106. if ( size(count ) /= varp%ndim ) then
  9107. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9108. write (gol,'(" size count : ",i6)') size(count ); call goErr
  9109. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9110. TRACEBACK; status=1; return
  9111. end if
  9112. end if
  9113. if ( present(stride ) ) then
  9114. if ( size(stride ) /= varp%ndim ) then
  9115. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9116. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  9117. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9118. TRACEBACK; status=1; return
  9119. end if
  9120. end if
  9121. if ( present(map ) ) then
  9122. if ( size(map ) /= varp%ndim ) then
  9123. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9124. write (gol,'(" size map : ",i6)') size(map ); call goErr
  9125. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9126. TRACEBACK; status=1; return
  9127. end if
  9128. end if
  9129. ! loop over file types:
  9130. do iftype = 1, filep%nftype
  9131. ! current type:
  9132. ftype = filep%ftypes(iftype)
  9133. ! select appropriate routine for each type:
  9134. select case ( ftype )
  9135. #ifdef with_hdf4
  9136. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9137. case ( MDF_HDF4 )
  9138. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9139. ! check ...
  9140. if ( present(map ) ) then
  9141. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  9142. TRACEBACK; status=1; return
  9143. end if
  9144. ! fill offset (zero based!) and stride with default values:
  9145. hdf4_offset = 0
  9146. hdf4_stride = 1
  9147. ! count is by default the shape; padd with singleton dimensions:
  9148. hdf4_count = 1; hdf4_count(1:2) = shape(values)
  9149. ! replace by optional arguments if necessary:
  9150. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  9151. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  9152. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  9153. ! test target type;
  9154. ! convert to required kind before entering sfWData,
  9155. ! otherwise segmentation faults on some machines ...
  9156. select case ( varp%xtype )
  9157. case ( MDF_BYTE )
  9158. allocate( values_int1(size(values,1),size(values,2)) )
  9159. values_int1 = int(values,kind=1)
  9160. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9161. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  9162. deallocate( values_int1 )
  9163. case ( MDF_SHORT )
  9164. allocate( values_int2(size(values,1),size(values,2)) )
  9165. values_int2 = int(values,kind=2)
  9166. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9167. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  9168. deallocate( values_int2 )
  9169. case ( MDF_INT )
  9170. allocate( values_int4(size(values,1),size(values,2)) )
  9171. values_int4 = int(values,kind=4)
  9172. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9173. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  9174. deallocate( values_int4 )
  9175. case ( MDF_FLOAT )
  9176. allocate( values_real4(size(values,1),size(values,2)) )
  9177. values_real4 = real(values,kind=4)
  9178. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9179. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  9180. deallocate( values_real4 )
  9181. case ( MDF_DOUBLE )
  9182. allocate( values_real8(size(values,1),size(values,2)) )
  9183. values_real8 = real(values,kind=8)
  9184. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9185. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  9186. deallocate( values_real8 )
  9187. case default
  9188. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  9189. TRACEBACK; status=1; return
  9190. end select
  9191. if ( status == FAIL ) then
  9192. write (gol,'("writing hdf4 data set:")'); call goErr
  9193. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  9194. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  9195. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  9196. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  9197. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  9198. write (gol,'(" size : ",i12)') size(values); call goErr
  9199. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  9200. TRACEBACK; status=1; return
  9201. end if
  9202. #endif
  9203. #ifdef with_hdf5_beta
  9204. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9205. case ( MDF_HDF5 )
  9206. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9207. ! check ...
  9208. if ( present(map ) ) then
  9209. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  9210. TRACEBACK; status=1; return
  9211. end if
  9212. ! fill offset (zero based!), stride, and count :
  9213. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  9214. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  9215. hdf5_count = 1 ! default singleton dimension
  9216. if ( present(count) ) then
  9217. hdf5_count(1:varp%ndim) = count
  9218. else
  9219. hdf5_count(1:2) = shape(values)
  9220. end if
  9221. ! new dimension:
  9222. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  9223. ! target data space in file:
  9224. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  9225. IF_NOT_OK_RETURN(status=1)
  9226. ! chunked dataset ?
  9227. if ( varp%hdf5_chunked ) then
  9228. ! reset extend:
  9229. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  9230. IF_NOT_OK_RETURN(status=1)
  9231. end if
  9232. ! select hyperslab:
  9233. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  9234. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  9235. stride=hdf5_stride(1:varp%ndim) )
  9236. ! write data:
  9237. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  9238. int(shape(values),kind=HSIZE_T), status, &
  9239. file_space_id=hdf5_file_space_id )
  9240. IF_NOT_OK_RETURN(status=1)
  9241. ! release data space:
  9242. call H5SClose_f( hdf5_file_space_id, status )
  9243. IF_NOT_OK_RETURN(status=1)
  9244. #endif
  9245. #ifdef with_netcdf
  9246. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9247. case ( MDF_NETCDF, MDF_NETCDF4 )
  9248. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9249. ! test target type:
  9250. ! convert to required kind before entering NF90_Put_Var,
  9251. ! otherwise segmentation faults on some machines ...
  9252. select case ( varp%xtype )
  9253. case ( MDF_BYTE )
  9254. allocate( values_int1(size(values,1),size(values,2)) )
  9255. values_int1 = int(values,kind=1)
  9256. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  9257. start, count, stride, map )
  9258. IF_NF90_NOT_OK_RETURN(status=1)
  9259. deallocate( values_int1 )
  9260. case ( MDF_SHORT )
  9261. allocate( values_int2(size(values,1),size(values,2)) )
  9262. values_int2 = int(values,kind=2)
  9263. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  9264. start, count, stride, map )
  9265. IF_NF90_NOT_OK_RETURN(status=1)
  9266. deallocate( values_int2 )
  9267. case ( MDF_INT )
  9268. allocate( values_int4(size(values,1),size(values,2)) )
  9269. values_int4 = int(values,kind=4)
  9270. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  9271. start, count, stride, map )
  9272. IF_NF90_NOT_OK_RETURN(status=1)
  9273. deallocate( values_int4 )
  9274. case ( MDF_FLOAT )
  9275. allocate( values_real4(size(values,1),size(values,2)) )
  9276. values_real4 = real(values,kind=4)
  9277. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  9278. start, count, stride, map )
  9279. IF_NF90_NOT_OK_RETURN(status=1)
  9280. deallocate( values_real4 )
  9281. case ( MDF_DOUBLE )
  9282. allocate( values_real8(size(values,1),size(values,2)) )
  9283. values_real8 = real(values,kind=8)
  9284. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  9285. start, count, stride, map )
  9286. IF_NF90_NOT_OK_RETURN(status=1)
  9287. deallocate( values_real8 )
  9288. case default
  9289. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  9290. TRACEBACK; status=1; return
  9291. end select
  9292. ! just put; let netcdf library convert the right kind:
  9293. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  9294. ! start, count, stride, map )
  9295. !IF_NF90_NOT_OK_RETURN(status=1)
  9296. #endif
  9297. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9298. case default
  9299. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9300. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  9301. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  9302. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  9303. TRACEBACK; status=1; return
  9304. end select
  9305. end do ! file types
  9306. ! ok
  9307. status = 0
  9308. end subroutine MDF_Put_Var_i2_2d
  9309. ! ***
  9310. subroutine MDF_Get_Var_i2_2d( hid, varid, values, status, &
  9311. start, count, stride, map )
  9312. #ifdef with_netcdf
  9313. use NetCDF, only : NF90_Get_Var
  9314. #endif
  9315. ! --- in/out -------------------------------------
  9316. integer, intent(in) :: hid
  9317. integer, intent(in) :: varid
  9318. integer(2), intent(out) :: values(:,:)
  9319. integer, intent(out) :: status
  9320. integer, intent(in), optional :: start (:)
  9321. integer, intent(in), optional :: count (:)
  9322. integer, intent(in), optional :: stride(:)
  9323. integer, intent(in), optional :: map (:)
  9324. ! --- const --------------------------------------
  9325. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_2d'
  9326. ! --- external -----------------------------------
  9327. #ifdef with_hdf4
  9328. integer(hdf4_wpi), external :: sfRData
  9329. #endif
  9330. ! --- local --------------------------------------
  9331. type(MDF_File), pointer :: filep
  9332. type(MDF_Var), pointer :: varp
  9333. integer :: iftype
  9334. integer :: ftype
  9335. #ifdef with_hdf4
  9336. integer :: hdf4_offset(MAX_RANK)
  9337. integer :: hdf4_stride(MAX_RANK)
  9338. integer :: hdf4_count(MAX_RANK)
  9339. integer(1), allocatable :: values_int1(:,:)
  9340. integer(2), allocatable :: values_int2(:,:)
  9341. integer(4), allocatable :: values_int4(:,:)
  9342. integer(8), allocatable :: values_int8(:,:)
  9343. real(4), allocatable :: values_real4(:,:)
  9344. real(8), allocatable :: values_real8(:,:)
  9345. #endif
  9346. ! --- begin --------------------------------------
  9347. ! pointer to file structure:
  9348. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  9349. IF_NOT_OK_RETURN(status=1)
  9350. ! pointer to variable structure:
  9351. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  9352. IF_NOT_OK_RETURN(status=1)
  9353. ! check ...
  9354. if ( size(shape(values)) > varp%ndim ) then
  9355. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  9356. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  9357. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  9358. TRACEBACK; status=1; return
  9359. end if
  9360. ! check ...
  9361. if ( present(start ) ) then
  9362. if ( size(start ) /= varp%ndim ) then
  9363. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9364. write (gol,'(" size start : ",i6)') size(start ); call goErr
  9365. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9366. TRACEBACK; status=1; return
  9367. end if
  9368. end if
  9369. if ( present(count ) ) then
  9370. if ( size(count ) /= varp%ndim ) then
  9371. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9372. write (gol,'(" size count : ",i6)') size(count ); call goErr
  9373. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9374. TRACEBACK; status=1; return
  9375. end if
  9376. end if
  9377. if ( present(stride ) ) then
  9378. if ( size(stride ) /= varp%ndim ) then
  9379. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9380. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  9381. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9382. TRACEBACK; status=1; return
  9383. end if
  9384. end if
  9385. if ( present(map ) ) then
  9386. if ( size(map ) /= varp%ndim ) then
  9387. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9388. write (gol,'(" size map : ",i6)') size(map ); call goErr
  9389. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9390. TRACEBACK; status=1; return
  9391. end if
  9392. end if
  9393. ! loop over file types:
  9394. do iftype = 1, filep%nftype
  9395. ! current type:
  9396. ftype = filep%ftypes(iftype)
  9397. ! select appropriate routine for each type:
  9398. select case ( ftype )
  9399. #ifdef with_hdf4
  9400. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9401. case ( MDF_HDF4 )
  9402. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9403. ! check ...
  9404. if ( present(map ) ) then
  9405. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  9406. TRACEBACK; status=1; return
  9407. end if
  9408. ! fill offset (zero based!), stride, and count :
  9409. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  9410. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  9411. hdf4_count = 1 ! default singleton dimension
  9412. hdf4_count(1:2) = shape(values)
  9413. ! test source type:
  9414. select case ( varp%hdf4_xtype )
  9415. case ( DFNT_INT8 )
  9416. allocate( values_int1(size(values,1),size(values,2)) )
  9417. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  9418. values = int(values_int1,kind=2)
  9419. deallocate( values_int1 )
  9420. case ( DFNT_INT16 )
  9421. allocate( values_int2(size(values,1),size(values,2)) )
  9422. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  9423. values = int(values_int2,kind=2)
  9424. deallocate( values_int2 )
  9425. case ( DFNT_INT32 )
  9426. allocate( values_int4(size(values,1),size(values,2)) )
  9427. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  9428. values = int(values_int4,kind=2)
  9429. deallocate( values_int4 )
  9430. case ( DFNT_INT64 )
  9431. allocate( values_int8(size(values,1),size(values,2)) )
  9432. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  9433. values = int(values_int8,kind=2)
  9434. deallocate( values_int8 )
  9435. case ( DFNT_FLOAT32 )
  9436. allocate( values_real4(size(values,1),size(values,2)) )
  9437. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  9438. values = int(values_real4,kind=2)
  9439. deallocate( values_real4 )
  9440. case ( DFNT_FLOAT64 )
  9441. allocate( values_real8(size(values,1),size(values,2)) )
  9442. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  9443. values = int(values_real8,kind=2)
  9444. deallocate( values_real8 )
  9445. case default
  9446. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  9447. TRACEBACK; status=1; return
  9448. end select
  9449. if ( status == FAIL ) then
  9450. write (gol,'("reading hdf4 data set:")'); call goErr
  9451. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  9452. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  9453. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  9454. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  9455. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  9456. write (gol,'(" size : ",i6)') size(values); call goErr
  9457. TRACEBACK; status=1; return
  9458. end if
  9459. #endif
  9460. #ifdef with_netcdf
  9461. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9462. case ( MDF_NETCDF, MDF_NETCDF4 )
  9463. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9464. ! read values, converted automatically:
  9465. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  9466. start, count, stride, map )
  9467. IF_NF90_NOT_OK_RETURN(status=1)
  9468. #endif
  9469. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9470. case default
  9471. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9472. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  9473. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  9474. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  9475. TRACEBACK; status=1; return
  9476. end select
  9477. end do ! file types
  9478. ! ok
  9479. status = 0
  9480. end subroutine MDF_Get_Var_i2_2d
  9481. ! ***
  9482. subroutine MDF_Put_Var_i2_3d( hid, varid, values, status, &
  9483. start, count, stride, map )
  9484. #ifdef with_hdf5_beta
  9485. use HDF5, only : HID_T, HSIZE_T
  9486. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  9487. use HDF5, only : H5T_NATIVE_CHARACTER
  9488. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  9489. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  9490. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  9491. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  9492. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  9493. #endif
  9494. #ifdef with_netcdf
  9495. use NetCDF, only : NF90_Put_Var
  9496. #endif
  9497. ! --- in/out -------------------------------------
  9498. integer, intent(in) :: hid
  9499. integer, intent(in) :: varid
  9500. integer(2), intent(in) :: values(:,:,:)
  9501. integer, intent(out) :: status
  9502. integer, intent(in), optional :: start (:)
  9503. integer, intent(in), optional :: count (:)
  9504. integer, intent(in), optional :: stride(:)
  9505. integer, intent(in), optional :: map (:)
  9506. ! --- const --------------------------------------
  9507. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_3d'
  9508. ! --- external -----------------------------------
  9509. #ifdef with_hdf4
  9510. integer(hdf4_wpi), external :: sfWData
  9511. #endif
  9512. ! --- local --------------------------------------
  9513. type(MDF_File), pointer :: filep
  9514. type(MDF_Var), pointer :: varp
  9515. integer :: iftype
  9516. integer :: ftype
  9517. #ifdef with_hdf4
  9518. integer :: hdf4_offset(MAX_RANK)
  9519. integer :: hdf4_stride(MAX_RANK)
  9520. integer :: hdf4_count(MAX_RANK)
  9521. #endif
  9522. #ifdef with_hdf5_beta
  9523. !integer(HID_T) :: hdf5_type_id
  9524. integer(HID_T) :: hdf5_file_space_id
  9525. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  9526. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  9527. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  9528. #endif
  9529. integer(1), allocatable :: values_int1(:,:,:)
  9530. integer(2), allocatable :: values_int2(:,:,:)
  9531. integer(4), allocatable :: values_int4(:,:,:)
  9532. integer(8), allocatable :: values_int8(:,:,:)
  9533. real(4), allocatable :: values_real4(:,:,:)
  9534. real(8), allocatable :: values_real8(:,:,:)
  9535. ! --- begin --------------------------------------
  9536. ! pointer to file structure:
  9537. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  9538. IF_NOT_OK_RETURN(status=1)
  9539. ! pointer to variable structure:
  9540. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  9541. IF_NOT_OK_RETURN(status=1)
  9542. ! check ...
  9543. if ( size(shape(values)) > varp%ndim ) then
  9544. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  9545. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  9546. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  9547. TRACEBACK; status=1; return
  9548. end if
  9549. ! check ...
  9550. if ( present(start ) ) then
  9551. if ( size(start ) /= varp%ndim ) then
  9552. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9553. write (gol,'(" size start : ",i6)') size(start ); call goErr
  9554. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9555. TRACEBACK; status=1; return
  9556. end if
  9557. end if
  9558. if ( present(count ) ) then
  9559. if ( size(count ) /= varp%ndim ) then
  9560. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9561. write (gol,'(" size count : ",i6)') size(count ); call goErr
  9562. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9563. TRACEBACK; status=1; return
  9564. end if
  9565. end if
  9566. if ( present(stride ) ) then
  9567. if ( size(stride ) /= varp%ndim ) then
  9568. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9569. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  9570. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9571. TRACEBACK; status=1; return
  9572. end if
  9573. end if
  9574. if ( present(map ) ) then
  9575. if ( size(map ) /= varp%ndim ) then
  9576. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9577. write (gol,'(" size map : ",i6)') size(map ); call goErr
  9578. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9579. TRACEBACK; status=1; return
  9580. end if
  9581. end if
  9582. ! loop over file types:
  9583. do iftype = 1, filep%nftype
  9584. ! current type:
  9585. ftype = filep%ftypes(iftype)
  9586. ! select appropriate routine for each type:
  9587. select case ( ftype )
  9588. #ifdef with_hdf4
  9589. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9590. case ( MDF_HDF4 )
  9591. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9592. ! check ...
  9593. if ( present(map ) ) then
  9594. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  9595. TRACEBACK; status=1; return
  9596. end if
  9597. ! fill offset (zero based!) and stride with default values:
  9598. hdf4_offset = 0
  9599. hdf4_stride = 1
  9600. ! count is by default the shape; padd with singleton dimensions:
  9601. hdf4_count = 1; hdf4_count(1:3) = shape(values)
  9602. ! replace by optional arguments if necessary:
  9603. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  9604. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  9605. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  9606. ! test target type;
  9607. ! convert to required kind before entering sfWData,
  9608. ! otherwise segmentation faults on some machines ...
  9609. select case ( varp%xtype )
  9610. case ( MDF_BYTE )
  9611. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  9612. values_int1 = int(values,kind=1)
  9613. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9614. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  9615. deallocate( values_int1 )
  9616. case ( MDF_SHORT )
  9617. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  9618. values_int2 = int(values,kind=2)
  9619. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9620. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  9621. deallocate( values_int2 )
  9622. case ( MDF_INT )
  9623. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  9624. values_int4 = int(values,kind=4)
  9625. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9626. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  9627. deallocate( values_int4 )
  9628. case ( MDF_FLOAT )
  9629. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  9630. values_real4 = real(values,kind=4)
  9631. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9632. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  9633. deallocate( values_real4 )
  9634. case ( MDF_DOUBLE )
  9635. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  9636. values_real8 = real(values,kind=8)
  9637. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  9638. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  9639. deallocate( values_real8 )
  9640. case default
  9641. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  9642. TRACEBACK; status=1; return
  9643. end select
  9644. if ( status == FAIL ) then
  9645. write (gol,'("writing hdf4 data set:")'); call goErr
  9646. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  9647. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  9648. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  9649. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  9650. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  9651. write (gol,'(" size : ",i12)') size(values); call goErr
  9652. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  9653. TRACEBACK; status=1; return
  9654. end if
  9655. #endif
  9656. #ifdef with_hdf5_beta
  9657. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9658. case ( MDF_HDF5 )
  9659. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9660. ! check ...
  9661. if ( present(map ) ) then
  9662. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  9663. TRACEBACK; status=1; return
  9664. end if
  9665. ! fill offset (zero based!), stride, and count :
  9666. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  9667. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  9668. hdf5_count = 1 ! default singleton dimension
  9669. if ( present(count) ) then
  9670. hdf5_count(1:varp%ndim) = count
  9671. else
  9672. hdf5_count(1:3) = shape(values)
  9673. end if
  9674. ! new dimension:
  9675. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  9676. ! target data space in file:
  9677. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  9678. IF_NOT_OK_RETURN(status=1)
  9679. ! chunked dataset ?
  9680. if ( varp%hdf5_chunked ) then
  9681. ! reset extend:
  9682. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  9683. IF_NOT_OK_RETURN(status=1)
  9684. end if
  9685. ! select hyperslab:
  9686. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  9687. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  9688. stride=hdf5_stride(1:varp%ndim) )
  9689. ! write data:
  9690. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  9691. int(shape(values),kind=HSIZE_T), status, &
  9692. file_space_id=hdf5_file_space_id )
  9693. IF_NOT_OK_RETURN(status=1)
  9694. ! release data space:
  9695. call H5SClose_f( hdf5_file_space_id, status )
  9696. IF_NOT_OK_RETURN(status=1)
  9697. #endif
  9698. #ifdef with_netcdf
  9699. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9700. case ( MDF_NETCDF, MDF_NETCDF4 )
  9701. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9702. ! test target type:
  9703. ! convert to required kind before entering NF90_Put_Var,
  9704. ! otherwise segmentation faults on some machines ...
  9705. select case ( varp%xtype )
  9706. case ( MDF_BYTE )
  9707. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  9708. values_int1 = int(values,kind=1)
  9709. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  9710. start, count, stride, map )
  9711. IF_NF90_NOT_OK_RETURN(status=1)
  9712. deallocate( values_int1 )
  9713. case ( MDF_SHORT )
  9714. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  9715. values_int2 = int(values,kind=2)
  9716. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  9717. start, count, stride, map )
  9718. IF_NF90_NOT_OK_RETURN(status=1)
  9719. deallocate( values_int2 )
  9720. case ( MDF_INT )
  9721. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  9722. values_int4 = int(values,kind=4)
  9723. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  9724. start, count, stride, map )
  9725. IF_NF90_NOT_OK_RETURN(status=1)
  9726. deallocate( values_int4 )
  9727. case ( MDF_FLOAT )
  9728. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  9729. values_real4 = real(values,kind=4)
  9730. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  9731. start, count, stride, map )
  9732. IF_NF90_NOT_OK_RETURN(status=1)
  9733. deallocate( values_real4 )
  9734. case ( MDF_DOUBLE )
  9735. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  9736. values_real8 = real(values,kind=8)
  9737. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  9738. start, count, stride, map )
  9739. IF_NF90_NOT_OK_RETURN(status=1)
  9740. deallocate( values_real8 )
  9741. case default
  9742. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  9743. TRACEBACK; status=1; return
  9744. end select
  9745. ! just put; let netcdf library convert the right kind:
  9746. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  9747. ! start, count, stride, map )
  9748. !IF_NF90_NOT_OK_RETURN(status=1)
  9749. #endif
  9750. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9751. case default
  9752. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9753. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  9754. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  9755. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  9756. TRACEBACK; status=1; return
  9757. end select
  9758. end do ! file types
  9759. ! ok
  9760. status = 0
  9761. end subroutine MDF_Put_Var_i2_3d
  9762. ! ***
  9763. subroutine MDF_Get_Var_i2_3d( hid, varid, values, status, &
  9764. start, count, stride, map )
  9765. #ifdef with_netcdf
  9766. use NetCDF, only : NF90_Get_Var
  9767. #endif
  9768. ! --- in/out -------------------------------------
  9769. integer, intent(in) :: hid
  9770. integer, intent(in) :: varid
  9771. integer(2), intent(out) :: values(:,:,:)
  9772. integer, intent(out) :: status
  9773. integer, intent(in), optional :: start (:)
  9774. integer, intent(in), optional :: count (:)
  9775. integer, intent(in), optional :: stride(:)
  9776. integer, intent(in), optional :: map (:)
  9777. ! --- const --------------------------------------
  9778. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_3d'
  9779. ! --- external -----------------------------------
  9780. #ifdef with_hdf4
  9781. integer(hdf4_wpi), external :: sfRData
  9782. #endif
  9783. ! --- local --------------------------------------
  9784. type(MDF_File), pointer :: filep
  9785. type(MDF_Var), pointer :: varp
  9786. integer :: iftype
  9787. integer :: ftype
  9788. #ifdef with_hdf4
  9789. integer :: hdf4_offset(MAX_RANK)
  9790. integer :: hdf4_stride(MAX_RANK)
  9791. integer :: hdf4_count(MAX_RANK)
  9792. integer(1), allocatable :: values_int1(:,:,:)
  9793. integer(2), allocatable :: values_int2(:,:,:)
  9794. integer(4), allocatable :: values_int4(:,:,:)
  9795. integer(8), allocatable :: values_int8(:,:,:)
  9796. real(4), allocatable :: values_real4(:,:,:)
  9797. real(8), allocatable :: values_real8(:,:,:)
  9798. #endif
  9799. ! --- begin --------------------------------------
  9800. ! pointer to file structure:
  9801. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  9802. IF_NOT_OK_RETURN(status=1)
  9803. ! pointer to variable structure:
  9804. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  9805. IF_NOT_OK_RETURN(status=1)
  9806. ! check ...
  9807. if ( size(shape(values)) > varp%ndim ) then
  9808. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  9809. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  9810. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  9811. TRACEBACK; status=1; return
  9812. end if
  9813. ! check ...
  9814. if ( present(start ) ) then
  9815. if ( size(start ) /= varp%ndim ) then
  9816. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9817. write (gol,'(" size start : ",i6)') size(start ); call goErr
  9818. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9819. TRACEBACK; status=1; return
  9820. end if
  9821. end if
  9822. if ( present(count ) ) then
  9823. if ( size(count ) /= varp%ndim ) then
  9824. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9825. write (gol,'(" size count : ",i6)') size(count ); call goErr
  9826. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9827. TRACEBACK; status=1; return
  9828. end if
  9829. end if
  9830. if ( present(stride ) ) then
  9831. if ( size(stride ) /= varp%ndim ) then
  9832. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9833. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  9834. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9835. TRACEBACK; status=1; return
  9836. end if
  9837. end if
  9838. if ( present(map ) ) then
  9839. if ( size(map ) /= varp%ndim ) then
  9840. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  9841. write (gol,'(" size map : ",i6)') size(map ); call goErr
  9842. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  9843. TRACEBACK; status=1; return
  9844. end if
  9845. end if
  9846. ! loop over file types:
  9847. do iftype = 1, filep%nftype
  9848. ! current type:
  9849. ftype = filep%ftypes(iftype)
  9850. ! select appropriate routine for each type:
  9851. select case ( ftype )
  9852. #ifdef with_hdf4
  9853. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9854. case ( MDF_HDF4 )
  9855. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9856. ! check ...
  9857. if ( present(map ) ) then
  9858. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  9859. TRACEBACK; status=1; return
  9860. end if
  9861. ! fill offset (zero based!), stride, and count :
  9862. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  9863. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  9864. hdf4_count = 1 ! default singleton dimension
  9865. hdf4_count(1:3) = shape(values)
  9866. ! test source type:
  9867. select case ( varp%hdf4_xtype )
  9868. case ( DFNT_INT8 )
  9869. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  9870. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  9871. values = int(values_int1,kind=2)
  9872. deallocate( values_int1 )
  9873. case ( DFNT_INT16 )
  9874. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  9875. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  9876. values = int(values_int2,kind=2)
  9877. deallocate( values_int2 )
  9878. case ( DFNT_INT32 )
  9879. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  9880. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  9881. values = int(values_int4,kind=2)
  9882. deallocate( values_int4 )
  9883. case ( DFNT_INT64 )
  9884. allocate( values_int8(size(values,1),size(values,2),size(values,3)) )
  9885. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  9886. values = int(values_int8,kind=2)
  9887. deallocate( values_int8 )
  9888. case ( DFNT_FLOAT32 )
  9889. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  9890. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  9891. values = int(values_real4,kind=2)
  9892. deallocate( values_real4 )
  9893. case ( DFNT_FLOAT64 )
  9894. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  9895. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  9896. values = int(values_real8,kind=2)
  9897. deallocate( values_real8 )
  9898. case default
  9899. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  9900. TRACEBACK; status=1; return
  9901. end select
  9902. if ( status == FAIL ) then
  9903. write (gol,'("reading hdf4 data set:")'); call goErr
  9904. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  9905. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  9906. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  9907. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  9908. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  9909. write (gol,'(" size : ",i6)') size(values); call goErr
  9910. TRACEBACK; status=1; return
  9911. end if
  9912. #endif
  9913. #ifdef with_netcdf
  9914. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9915. case ( MDF_NETCDF, MDF_NETCDF4 )
  9916. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9917. ! read values, converted automatically:
  9918. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  9919. start, count, stride, map )
  9920. IF_NF90_NOT_OK_RETURN(status=1)
  9921. #endif
  9922. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9923. case default
  9924. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  9925. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  9926. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  9927. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  9928. TRACEBACK; status=1; return
  9929. end select
  9930. end do ! file types
  9931. ! ok
  9932. status = 0
  9933. end subroutine MDF_Get_Var_i2_3d
  9934. ! ***
  9935. subroutine MDF_Put_Var_i2_4d( hid, varid, values, status, &
  9936. start, count, stride, map )
  9937. #ifdef with_hdf5_beta
  9938. use HDF5, only : HID_T, HSIZE_T
  9939. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  9940. use HDF5, only : H5T_NATIVE_CHARACTER
  9941. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  9942. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  9943. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  9944. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  9945. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  9946. #endif
  9947. #ifdef with_netcdf
  9948. use NetCDF, only : NF90_Put_Var
  9949. #endif
  9950. ! --- in/out -------------------------------------
  9951. integer, intent(in) :: hid
  9952. integer, intent(in) :: varid
  9953. integer(2), intent(in) :: values(:,:,:,:)
  9954. integer, intent(out) :: status
  9955. integer, intent(in), optional :: start (:)
  9956. integer, intent(in), optional :: count (:)
  9957. integer, intent(in), optional :: stride(:)
  9958. integer, intent(in), optional :: map (:)
  9959. ! --- const --------------------------------------
  9960. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_4d'
  9961. ! --- external -----------------------------------
  9962. #ifdef with_hdf4
  9963. integer(hdf4_wpi), external :: sfWData
  9964. #endif
  9965. ! --- local --------------------------------------
  9966. type(MDF_File), pointer :: filep
  9967. type(MDF_Var), pointer :: varp
  9968. integer :: iftype
  9969. integer :: ftype
  9970. #ifdef with_hdf4
  9971. integer :: hdf4_offset(MAX_RANK)
  9972. integer :: hdf4_stride(MAX_RANK)
  9973. integer :: hdf4_count(MAX_RANK)
  9974. #endif
  9975. #ifdef with_hdf5_beta
  9976. !integer(HID_T) :: hdf5_type_id
  9977. integer(HID_T) :: hdf5_file_space_id
  9978. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  9979. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  9980. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  9981. #endif
  9982. integer(1), allocatable :: values_int1(:,:,:,:)
  9983. integer(2), allocatable :: values_int2(:,:,:,:)
  9984. integer(4), allocatable :: values_int4(:,:,:,:)
  9985. integer(8), allocatable :: values_int8(:,:,:,:)
  9986. real(4), allocatable :: values_real4(:,:,:,:)
  9987. real(8), allocatable :: values_real8(:,:,:,:)
  9988. ! --- begin --------------------------------------
  9989. ! pointer to file structure:
  9990. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  9991. IF_NOT_OK_RETURN(status=1)
  9992. ! pointer to variable structure:
  9993. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  9994. IF_NOT_OK_RETURN(status=1)
  9995. ! check ...
  9996. if ( size(shape(values)) > varp%ndim ) then
  9997. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  9998. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  9999. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  10000. TRACEBACK; status=1; return
  10001. end if
  10002. ! check ...
  10003. if ( present(start ) ) then
  10004. if ( size(start ) /= varp%ndim ) then
  10005. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10006. write (gol,'(" size start : ",i6)') size(start ); call goErr
  10007. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10008. TRACEBACK; status=1; return
  10009. end if
  10010. end if
  10011. if ( present(count ) ) then
  10012. if ( size(count ) /= varp%ndim ) then
  10013. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10014. write (gol,'(" size count : ",i6)') size(count ); call goErr
  10015. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10016. TRACEBACK; status=1; return
  10017. end if
  10018. end if
  10019. if ( present(stride ) ) then
  10020. if ( size(stride ) /= varp%ndim ) then
  10021. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10022. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  10023. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10024. TRACEBACK; status=1; return
  10025. end if
  10026. end if
  10027. if ( present(map ) ) then
  10028. if ( size(map ) /= varp%ndim ) then
  10029. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10030. write (gol,'(" size map : ",i6)') size(map ); call goErr
  10031. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10032. TRACEBACK; status=1; return
  10033. end if
  10034. end if
  10035. ! loop over file types:
  10036. do iftype = 1, filep%nftype
  10037. ! current type:
  10038. ftype = filep%ftypes(iftype)
  10039. ! select appropriate routine for each type:
  10040. select case ( ftype )
  10041. #ifdef with_hdf4
  10042. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10043. case ( MDF_HDF4 )
  10044. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10045. ! check ...
  10046. if ( present(map ) ) then
  10047. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  10048. TRACEBACK; status=1; return
  10049. end if
  10050. ! fill offset (zero based!) and stride with default values:
  10051. hdf4_offset = 0
  10052. hdf4_stride = 1
  10053. ! count is by default the shape; padd with singleton dimensions:
  10054. hdf4_count = 1; hdf4_count(1:4) = shape(values)
  10055. ! replace by optional arguments if necessary:
  10056. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  10057. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  10058. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  10059. ! test target type;
  10060. ! convert to required kind before entering sfWData,
  10061. ! otherwise segmentation faults on some machines ...
  10062. select case ( varp%xtype )
  10063. case ( MDF_BYTE )
  10064. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10065. values_int1 = int(values,kind=1)
  10066. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10067. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  10068. deallocate( values_int1 )
  10069. case ( MDF_SHORT )
  10070. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10071. values_int2 = int(values,kind=2)
  10072. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10073. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  10074. deallocate( values_int2 )
  10075. case ( MDF_INT )
  10076. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10077. values_int4 = int(values,kind=4)
  10078. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10079. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  10080. deallocate( values_int4 )
  10081. case ( MDF_FLOAT )
  10082. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10083. values_real4 = real(values,kind=4)
  10084. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10085. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  10086. deallocate( values_real4 )
  10087. case ( MDF_DOUBLE )
  10088. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10089. values_real8 = real(values,kind=8)
  10090. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10091. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  10092. deallocate( values_real8 )
  10093. case default
  10094. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  10095. TRACEBACK; status=1; return
  10096. end select
  10097. if ( status == FAIL ) then
  10098. write (gol,'("writing hdf4 data set:")'); call goErr
  10099. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  10100. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  10101. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  10102. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  10103. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  10104. write (gol,'(" size : ",i12)') size(values); call goErr
  10105. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  10106. TRACEBACK; status=1; return
  10107. end if
  10108. #endif
  10109. #ifdef with_hdf5_beta
  10110. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10111. case ( MDF_HDF5 )
  10112. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10113. ! check ...
  10114. if ( present(map ) ) then
  10115. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  10116. TRACEBACK; status=1; return
  10117. end if
  10118. ! fill offset (zero based!), stride, and count :
  10119. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  10120. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  10121. hdf5_count = 1 ! default singleton dimension
  10122. if ( present(count) ) then
  10123. hdf5_count(1:varp%ndim) = count
  10124. else
  10125. hdf5_count(1:4) = shape(values)
  10126. end if
  10127. ! new dimension:
  10128. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  10129. ! target data space in file:
  10130. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  10131. IF_NOT_OK_RETURN(status=1)
  10132. ! chunked dataset ?
  10133. if ( varp%hdf5_chunked ) then
  10134. ! reset extend:
  10135. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  10136. IF_NOT_OK_RETURN(status=1)
  10137. end if
  10138. ! select hyperslab:
  10139. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  10140. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  10141. stride=hdf5_stride(1:varp%ndim) )
  10142. ! write data:
  10143. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  10144. int(shape(values),kind=HSIZE_T), status, &
  10145. file_space_id=hdf5_file_space_id )
  10146. IF_NOT_OK_RETURN(status=1)
  10147. ! release data space:
  10148. call H5SClose_f( hdf5_file_space_id, status )
  10149. IF_NOT_OK_RETURN(status=1)
  10150. #endif
  10151. #ifdef with_netcdf
  10152. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10153. case ( MDF_NETCDF, MDF_NETCDF4 )
  10154. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10155. ! test target type:
  10156. ! convert to required kind before entering NF90_Put_Var,
  10157. ! otherwise segmentation faults on some machines ...
  10158. select case ( varp%xtype )
  10159. case ( MDF_BYTE )
  10160. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10161. values_int1 = int(values,kind=1)
  10162. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  10163. start, count, stride, map )
  10164. IF_NF90_NOT_OK_RETURN(status=1)
  10165. deallocate( values_int1 )
  10166. case ( MDF_SHORT )
  10167. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10168. values_int2 = int(values,kind=2)
  10169. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  10170. start, count, stride, map )
  10171. IF_NF90_NOT_OK_RETURN(status=1)
  10172. deallocate( values_int2 )
  10173. case ( MDF_INT )
  10174. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10175. values_int4 = int(values,kind=4)
  10176. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  10177. start, count, stride, map )
  10178. IF_NF90_NOT_OK_RETURN(status=1)
  10179. deallocate( values_int4 )
  10180. case ( MDF_FLOAT )
  10181. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10182. values_real4 = real(values,kind=4)
  10183. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  10184. start, count, stride, map )
  10185. IF_NF90_NOT_OK_RETURN(status=1)
  10186. deallocate( values_real4 )
  10187. case ( MDF_DOUBLE )
  10188. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10189. values_real8 = real(values,kind=8)
  10190. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  10191. start, count, stride, map )
  10192. IF_NF90_NOT_OK_RETURN(status=1)
  10193. deallocate( values_real8 )
  10194. case default
  10195. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  10196. TRACEBACK; status=1; return
  10197. end select
  10198. ! just put; let netcdf library convert the right kind:
  10199. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  10200. ! start, count, stride, map )
  10201. !IF_NF90_NOT_OK_RETURN(status=1)
  10202. #endif
  10203. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10204. case default
  10205. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10206. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  10207. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  10208. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  10209. TRACEBACK; status=1; return
  10210. end select
  10211. end do ! file types
  10212. ! ok
  10213. status = 0
  10214. end subroutine MDF_Put_Var_i2_4d
  10215. ! ***
  10216. subroutine MDF_Get_Var_i2_4d( hid, varid, values, status, &
  10217. start, count, stride, map )
  10218. #ifdef with_netcdf
  10219. use NetCDF, only : NF90_Get_Var
  10220. #endif
  10221. ! --- in/out -------------------------------------
  10222. integer, intent(in) :: hid
  10223. integer, intent(in) :: varid
  10224. integer(2), intent(out) :: values(:,:,:,:)
  10225. integer, intent(out) :: status
  10226. integer, intent(in), optional :: start (:)
  10227. integer, intent(in), optional :: count (:)
  10228. integer, intent(in), optional :: stride(:)
  10229. integer, intent(in), optional :: map (:)
  10230. ! --- const --------------------------------------
  10231. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_4d'
  10232. ! --- external -----------------------------------
  10233. #ifdef with_hdf4
  10234. integer(hdf4_wpi), external :: sfRData
  10235. #endif
  10236. ! --- local --------------------------------------
  10237. type(MDF_File), pointer :: filep
  10238. type(MDF_Var), pointer :: varp
  10239. integer :: iftype
  10240. integer :: ftype
  10241. #ifdef with_hdf4
  10242. integer :: hdf4_offset(MAX_RANK)
  10243. integer :: hdf4_stride(MAX_RANK)
  10244. integer :: hdf4_count(MAX_RANK)
  10245. integer(1), allocatable :: values_int1(:,:,:,:)
  10246. integer(2), allocatable :: values_int2(:,:,:,:)
  10247. integer(4), allocatable :: values_int4(:,:,:,:)
  10248. integer(8), allocatable :: values_int8(:,:,:,:)
  10249. real(4), allocatable :: values_real4(:,:,:,:)
  10250. real(8), allocatable :: values_real8(:,:,:,:)
  10251. #endif
  10252. ! --- begin --------------------------------------
  10253. ! pointer to file structure:
  10254. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  10255. IF_NOT_OK_RETURN(status=1)
  10256. ! pointer to variable structure:
  10257. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  10258. IF_NOT_OK_RETURN(status=1)
  10259. ! check ...
  10260. if ( size(shape(values)) > varp%ndim ) then
  10261. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  10262. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  10263. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  10264. TRACEBACK; status=1; return
  10265. end if
  10266. ! check ...
  10267. if ( present(start ) ) then
  10268. if ( size(start ) /= varp%ndim ) then
  10269. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10270. write (gol,'(" size start : ",i6)') size(start ); call goErr
  10271. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10272. TRACEBACK; status=1; return
  10273. end if
  10274. end if
  10275. if ( present(count ) ) then
  10276. if ( size(count ) /= varp%ndim ) then
  10277. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10278. write (gol,'(" size count : ",i6)') size(count ); call goErr
  10279. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10280. TRACEBACK; status=1; return
  10281. end if
  10282. end if
  10283. if ( present(stride ) ) then
  10284. if ( size(stride ) /= varp%ndim ) then
  10285. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10286. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  10287. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10288. TRACEBACK; status=1; return
  10289. end if
  10290. end if
  10291. if ( present(map ) ) then
  10292. if ( size(map ) /= varp%ndim ) then
  10293. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10294. write (gol,'(" size map : ",i6)') size(map ); call goErr
  10295. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10296. TRACEBACK; status=1; return
  10297. end if
  10298. end if
  10299. ! loop over file types:
  10300. do iftype = 1, filep%nftype
  10301. ! current type:
  10302. ftype = filep%ftypes(iftype)
  10303. ! select appropriate routine for each type:
  10304. select case ( ftype )
  10305. #ifdef with_hdf4
  10306. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10307. case ( MDF_HDF4 )
  10308. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10309. ! check ...
  10310. if ( present(map ) ) then
  10311. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  10312. TRACEBACK; status=1; return
  10313. end if
  10314. ! fill offset (zero based!), stride, and count :
  10315. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  10316. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  10317. hdf4_count = 1 ! default singleton dimension
  10318. hdf4_count(1:4) = shape(values)
  10319. ! test source type:
  10320. select case ( varp%hdf4_xtype )
  10321. case ( DFNT_INT8 )
  10322. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10323. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  10324. values = int(values_int1,kind=2)
  10325. deallocate( values_int1 )
  10326. case ( DFNT_INT16 )
  10327. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10328. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  10329. values = int(values_int2,kind=2)
  10330. deallocate( values_int2 )
  10331. case ( DFNT_INT32 )
  10332. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10333. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  10334. values = int(values_int4,kind=2)
  10335. deallocate( values_int4 )
  10336. case ( DFNT_INT64 )
  10337. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10338. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  10339. values = int(values_int8,kind=2)
  10340. deallocate( values_int8 )
  10341. case ( DFNT_FLOAT32 )
  10342. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10343. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  10344. values = int(values_real4,kind=2)
  10345. deallocate( values_real4 )
  10346. case ( DFNT_FLOAT64 )
  10347. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  10348. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  10349. values = int(values_real8,kind=2)
  10350. deallocate( values_real8 )
  10351. case default
  10352. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  10353. TRACEBACK; status=1; return
  10354. end select
  10355. if ( status == FAIL ) then
  10356. write (gol,'("reading hdf4 data set:")'); call goErr
  10357. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  10358. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  10359. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  10360. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  10361. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  10362. write (gol,'(" size : ",i6)') size(values); call goErr
  10363. TRACEBACK; status=1; return
  10364. end if
  10365. #endif
  10366. #ifdef with_netcdf
  10367. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10368. case ( MDF_NETCDF, MDF_NETCDF4 )
  10369. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10370. ! read values, converted automatically:
  10371. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  10372. start, count, stride, map )
  10373. IF_NF90_NOT_OK_RETURN(status=1)
  10374. #endif
  10375. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10376. case default
  10377. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10378. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  10379. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  10380. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  10381. TRACEBACK; status=1; return
  10382. end select
  10383. end do ! file types
  10384. ! ok
  10385. status = 0
  10386. end subroutine MDF_Get_Var_i2_4d
  10387. ! ***
  10388. subroutine MDF_Put_Var_i2_5d( hid, varid, values, status, &
  10389. start, count, stride, map )
  10390. #ifdef with_hdf5_beta
  10391. use HDF5, only : HID_T, HSIZE_T
  10392. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  10393. use HDF5, only : H5T_NATIVE_CHARACTER
  10394. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  10395. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  10396. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  10397. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  10398. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  10399. #endif
  10400. #ifdef with_netcdf
  10401. use NetCDF, only : NF90_Put_Var
  10402. #endif
  10403. ! --- in/out -------------------------------------
  10404. integer, intent(in) :: hid
  10405. integer, intent(in) :: varid
  10406. integer(2), intent(in) :: values(:,:,:,:,:)
  10407. integer, intent(out) :: status
  10408. integer, intent(in), optional :: start (:)
  10409. integer, intent(in), optional :: count (:)
  10410. integer, intent(in), optional :: stride(:)
  10411. integer, intent(in), optional :: map (:)
  10412. ! --- const --------------------------------------
  10413. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_5d'
  10414. ! --- external -----------------------------------
  10415. #ifdef with_hdf4
  10416. integer(hdf4_wpi), external :: sfWData
  10417. #endif
  10418. ! --- local --------------------------------------
  10419. type(MDF_File), pointer :: filep
  10420. type(MDF_Var), pointer :: varp
  10421. integer :: iftype
  10422. integer :: ftype
  10423. #ifdef with_hdf4
  10424. integer :: hdf4_offset(MAX_RANK)
  10425. integer :: hdf4_stride(MAX_RANK)
  10426. integer :: hdf4_count(MAX_RANK)
  10427. #endif
  10428. #ifdef with_hdf5_beta
  10429. !integer(HID_T) :: hdf5_type_id
  10430. integer(HID_T) :: hdf5_file_space_id
  10431. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  10432. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  10433. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  10434. #endif
  10435. integer(1), allocatable :: values_int1(:,:,:,:,:)
  10436. integer(2), allocatable :: values_int2(:,:,:,:,:)
  10437. integer(4), allocatable :: values_int4(:,:,:,:,:)
  10438. integer(8), allocatable :: values_int8(:,:,:,:,:)
  10439. real(4), allocatable :: values_real4(:,:,:,:,:)
  10440. real(8), allocatable :: values_real8(:,:,:,:,:)
  10441. ! --- begin --------------------------------------
  10442. ! pointer to file structure:
  10443. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  10444. IF_NOT_OK_RETURN(status=1)
  10445. ! pointer to variable structure:
  10446. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  10447. IF_NOT_OK_RETURN(status=1)
  10448. ! check ...
  10449. if ( size(shape(values)) > varp%ndim ) then
  10450. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  10451. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  10452. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  10453. TRACEBACK; status=1; return
  10454. end if
  10455. ! check ...
  10456. if ( present(start ) ) then
  10457. if ( size(start ) /= varp%ndim ) then
  10458. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10459. write (gol,'(" size start : ",i6)') size(start ); call goErr
  10460. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10461. TRACEBACK; status=1; return
  10462. end if
  10463. end if
  10464. if ( present(count ) ) then
  10465. if ( size(count ) /= varp%ndim ) then
  10466. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10467. write (gol,'(" size count : ",i6)') size(count ); call goErr
  10468. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10469. TRACEBACK; status=1; return
  10470. end if
  10471. end if
  10472. if ( present(stride ) ) then
  10473. if ( size(stride ) /= varp%ndim ) then
  10474. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10475. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  10476. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10477. TRACEBACK; status=1; return
  10478. end if
  10479. end if
  10480. if ( present(map ) ) then
  10481. if ( size(map ) /= varp%ndim ) then
  10482. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10483. write (gol,'(" size map : ",i6)') size(map ); call goErr
  10484. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10485. TRACEBACK; status=1; return
  10486. end if
  10487. end if
  10488. ! loop over file types:
  10489. do iftype = 1, filep%nftype
  10490. ! current type:
  10491. ftype = filep%ftypes(iftype)
  10492. ! select appropriate routine for each type:
  10493. select case ( ftype )
  10494. #ifdef with_hdf4
  10495. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10496. case ( MDF_HDF4 )
  10497. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10498. ! check ...
  10499. if ( present(map ) ) then
  10500. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  10501. TRACEBACK; status=1; return
  10502. end if
  10503. ! fill offset (zero based!) and stride with default values:
  10504. hdf4_offset = 0
  10505. hdf4_stride = 1
  10506. ! count is by default the shape; padd with singleton dimensions:
  10507. hdf4_count = 1; hdf4_count(1:5) = shape(values)
  10508. ! replace by optional arguments if necessary:
  10509. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  10510. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  10511. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  10512. ! test target type;
  10513. ! convert to required kind before entering sfWData,
  10514. ! otherwise segmentation faults on some machines ...
  10515. select case ( varp%xtype )
  10516. case ( MDF_BYTE )
  10517. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10518. values_int1 = int(values,kind=1)
  10519. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10520. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  10521. deallocate( values_int1 )
  10522. case ( MDF_SHORT )
  10523. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10524. values_int2 = int(values,kind=2)
  10525. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10526. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  10527. deallocate( values_int2 )
  10528. case ( MDF_INT )
  10529. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10530. values_int4 = int(values,kind=4)
  10531. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10532. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  10533. deallocate( values_int4 )
  10534. case ( MDF_FLOAT )
  10535. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10536. values_real4 = real(values,kind=4)
  10537. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10538. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  10539. deallocate( values_real4 )
  10540. case ( MDF_DOUBLE )
  10541. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10542. values_real8 = real(values,kind=8)
  10543. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10544. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  10545. deallocate( values_real8 )
  10546. case default
  10547. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  10548. TRACEBACK; status=1; return
  10549. end select
  10550. if ( status == FAIL ) then
  10551. write (gol,'("writing hdf4 data set:")'); call goErr
  10552. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  10553. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  10554. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  10555. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  10556. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  10557. write (gol,'(" size : ",i12)') size(values); call goErr
  10558. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  10559. TRACEBACK; status=1; return
  10560. end if
  10561. #endif
  10562. #ifdef with_hdf5_beta
  10563. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10564. case ( MDF_HDF5 )
  10565. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10566. ! check ...
  10567. if ( present(map ) ) then
  10568. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  10569. TRACEBACK; status=1; return
  10570. end if
  10571. ! fill offset (zero based!), stride, and count :
  10572. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  10573. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  10574. hdf5_count = 1 ! default singleton dimension
  10575. if ( present(count) ) then
  10576. hdf5_count(1:varp%ndim) = count
  10577. else
  10578. hdf5_count(1:5) = shape(values)
  10579. end if
  10580. ! new dimension:
  10581. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  10582. ! target data space in file:
  10583. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  10584. IF_NOT_OK_RETURN(status=1)
  10585. ! chunked dataset ?
  10586. if ( varp%hdf5_chunked ) then
  10587. ! reset extend:
  10588. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  10589. IF_NOT_OK_RETURN(status=1)
  10590. end if
  10591. ! select hyperslab:
  10592. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  10593. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  10594. stride=hdf5_stride(1:varp%ndim) )
  10595. ! write data:
  10596. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  10597. int(shape(values),kind=HSIZE_T), status, &
  10598. file_space_id=hdf5_file_space_id )
  10599. IF_NOT_OK_RETURN(status=1)
  10600. ! release data space:
  10601. call H5SClose_f( hdf5_file_space_id, status )
  10602. IF_NOT_OK_RETURN(status=1)
  10603. #endif
  10604. #ifdef with_netcdf
  10605. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10606. case ( MDF_NETCDF, MDF_NETCDF4 )
  10607. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10608. ! test target type:
  10609. ! convert to required kind before entering NF90_Put_Var,
  10610. ! otherwise segmentation faults on some machines ...
  10611. select case ( varp%xtype )
  10612. case ( MDF_BYTE )
  10613. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10614. values_int1 = int(values,kind=1)
  10615. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  10616. start, count, stride, map )
  10617. IF_NF90_NOT_OK_RETURN(status=1)
  10618. deallocate( values_int1 )
  10619. case ( MDF_SHORT )
  10620. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10621. values_int2 = int(values,kind=2)
  10622. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  10623. start, count, stride, map )
  10624. IF_NF90_NOT_OK_RETURN(status=1)
  10625. deallocate( values_int2 )
  10626. case ( MDF_INT )
  10627. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10628. values_int4 = int(values,kind=4)
  10629. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  10630. start, count, stride, map )
  10631. IF_NF90_NOT_OK_RETURN(status=1)
  10632. deallocate( values_int4 )
  10633. case ( MDF_FLOAT )
  10634. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10635. values_real4 = real(values,kind=4)
  10636. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  10637. start, count, stride, map )
  10638. IF_NF90_NOT_OK_RETURN(status=1)
  10639. deallocate( values_real4 )
  10640. case ( MDF_DOUBLE )
  10641. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10642. values_real8 = real(values,kind=8)
  10643. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  10644. start, count, stride, map )
  10645. IF_NF90_NOT_OK_RETURN(status=1)
  10646. deallocate( values_real8 )
  10647. case default
  10648. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  10649. TRACEBACK; status=1; return
  10650. end select
  10651. ! just put; let netcdf library convert the right kind:
  10652. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  10653. ! start, count, stride, map )
  10654. !IF_NF90_NOT_OK_RETURN(status=1)
  10655. #endif
  10656. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10657. case default
  10658. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10659. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  10660. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  10661. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  10662. TRACEBACK; status=1; return
  10663. end select
  10664. end do ! file types
  10665. ! ok
  10666. status = 0
  10667. end subroutine MDF_Put_Var_i2_5d
  10668. ! ***
  10669. subroutine MDF_Get_Var_i2_5d( hid, varid, values, status, &
  10670. start, count, stride, map )
  10671. #ifdef with_netcdf
  10672. use NetCDF, only : NF90_Get_Var
  10673. #endif
  10674. ! --- in/out -------------------------------------
  10675. integer, intent(in) :: hid
  10676. integer, intent(in) :: varid
  10677. integer(2), intent(out) :: values(:,:,:,:,:)
  10678. integer, intent(out) :: status
  10679. integer, intent(in), optional :: start (:)
  10680. integer, intent(in), optional :: count (:)
  10681. integer, intent(in), optional :: stride(:)
  10682. integer, intent(in), optional :: map (:)
  10683. ! --- const --------------------------------------
  10684. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_5d'
  10685. ! --- external -----------------------------------
  10686. #ifdef with_hdf4
  10687. integer(hdf4_wpi), external :: sfRData
  10688. #endif
  10689. ! --- local --------------------------------------
  10690. type(MDF_File), pointer :: filep
  10691. type(MDF_Var), pointer :: varp
  10692. integer :: iftype
  10693. integer :: ftype
  10694. #ifdef with_hdf4
  10695. integer :: hdf4_offset(MAX_RANK)
  10696. integer :: hdf4_stride(MAX_RANK)
  10697. integer :: hdf4_count(MAX_RANK)
  10698. integer(1), allocatable :: values_int1(:,:,:,:,:)
  10699. integer(2), allocatable :: values_int2(:,:,:,:,:)
  10700. integer(4), allocatable :: values_int4(:,:,:,:,:)
  10701. integer(8), allocatable :: values_int8(:,:,:,:,:)
  10702. real(4), allocatable :: values_real4(:,:,:,:,:)
  10703. real(8), allocatable :: values_real8(:,:,:,:,:)
  10704. #endif
  10705. ! --- begin --------------------------------------
  10706. ! pointer to file structure:
  10707. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  10708. IF_NOT_OK_RETURN(status=1)
  10709. ! pointer to variable structure:
  10710. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  10711. IF_NOT_OK_RETURN(status=1)
  10712. ! check ...
  10713. if ( size(shape(values)) > varp%ndim ) then
  10714. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  10715. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  10716. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  10717. TRACEBACK; status=1; return
  10718. end if
  10719. ! check ...
  10720. if ( present(start ) ) then
  10721. if ( size(start ) /= varp%ndim ) then
  10722. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10723. write (gol,'(" size start : ",i6)') size(start ); call goErr
  10724. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10725. TRACEBACK; status=1; return
  10726. end if
  10727. end if
  10728. if ( present(count ) ) then
  10729. if ( size(count ) /= varp%ndim ) then
  10730. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10731. write (gol,'(" size count : ",i6)') size(count ); call goErr
  10732. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10733. TRACEBACK; status=1; return
  10734. end if
  10735. end if
  10736. if ( present(stride ) ) then
  10737. if ( size(stride ) /= varp%ndim ) then
  10738. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10739. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  10740. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10741. TRACEBACK; status=1; return
  10742. end if
  10743. end if
  10744. if ( present(map ) ) then
  10745. if ( size(map ) /= varp%ndim ) then
  10746. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10747. write (gol,'(" size map : ",i6)') size(map ); call goErr
  10748. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10749. TRACEBACK; status=1; return
  10750. end if
  10751. end if
  10752. ! loop over file types:
  10753. do iftype = 1, filep%nftype
  10754. ! current type:
  10755. ftype = filep%ftypes(iftype)
  10756. ! select appropriate routine for each type:
  10757. select case ( ftype )
  10758. #ifdef with_hdf4
  10759. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10760. case ( MDF_HDF4 )
  10761. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10762. ! check ...
  10763. if ( present(map ) ) then
  10764. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  10765. TRACEBACK; status=1; return
  10766. end if
  10767. ! fill offset (zero based!), stride, and count :
  10768. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  10769. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  10770. hdf4_count = 1 ! default singleton dimension
  10771. hdf4_count(1:5) = shape(values)
  10772. ! test source type:
  10773. select case ( varp%hdf4_xtype )
  10774. case ( DFNT_INT8 )
  10775. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10776. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  10777. values = int(values_int1,kind=2)
  10778. deallocate( values_int1 )
  10779. case ( DFNT_INT16 )
  10780. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10781. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  10782. values = int(values_int2,kind=2)
  10783. deallocate( values_int2 )
  10784. case ( DFNT_INT32 )
  10785. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10786. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  10787. values = int(values_int4,kind=2)
  10788. deallocate( values_int4 )
  10789. case ( DFNT_INT64 )
  10790. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10791. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  10792. values = int(values_int8,kind=2)
  10793. deallocate( values_int8 )
  10794. case ( DFNT_FLOAT32 )
  10795. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10796. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  10797. values = int(values_real4,kind=2)
  10798. deallocate( values_real4 )
  10799. case ( DFNT_FLOAT64 )
  10800. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  10801. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  10802. values = int(values_real8,kind=2)
  10803. deallocate( values_real8 )
  10804. case default
  10805. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  10806. TRACEBACK; status=1; return
  10807. end select
  10808. if ( status == FAIL ) then
  10809. write (gol,'("reading hdf4 data set:")'); call goErr
  10810. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  10811. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  10812. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  10813. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  10814. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  10815. write (gol,'(" size : ",i6)') size(values); call goErr
  10816. TRACEBACK; status=1; return
  10817. end if
  10818. #endif
  10819. #ifdef with_netcdf
  10820. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10821. case ( MDF_NETCDF, MDF_NETCDF4 )
  10822. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10823. ! read values, converted automatically:
  10824. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  10825. start, count, stride, map )
  10826. IF_NF90_NOT_OK_RETURN(status=1)
  10827. #endif
  10828. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10829. case default
  10830. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10831. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  10832. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  10833. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  10834. TRACEBACK; status=1; return
  10835. end select
  10836. end do ! file types
  10837. ! ok
  10838. status = 0
  10839. end subroutine MDF_Get_Var_i2_5d
  10840. ! ***
  10841. subroutine MDF_Put_Var_i2_6d( hid, varid, values, status, &
  10842. start, count, stride, map )
  10843. #ifdef with_hdf5_beta
  10844. use HDF5, only : HID_T, HSIZE_T
  10845. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  10846. use HDF5, only : H5T_NATIVE_CHARACTER
  10847. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  10848. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  10849. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  10850. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  10851. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  10852. #endif
  10853. #ifdef with_netcdf
  10854. use NetCDF, only : NF90_Put_Var
  10855. #endif
  10856. ! --- in/out -------------------------------------
  10857. integer, intent(in) :: hid
  10858. integer, intent(in) :: varid
  10859. integer(2), intent(in) :: values(:,:,:,:,:,:)
  10860. integer, intent(out) :: status
  10861. integer, intent(in), optional :: start (:)
  10862. integer, intent(in), optional :: count (:)
  10863. integer, intent(in), optional :: stride(:)
  10864. integer, intent(in), optional :: map (:)
  10865. ! --- const --------------------------------------
  10866. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_6d'
  10867. ! --- external -----------------------------------
  10868. #ifdef with_hdf4
  10869. integer(hdf4_wpi), external :: sfWData
  10870. #endif
  10871. ! --- local --------------------------------------
  10872. type(MDF_File), pointer :: filep
  10873. type(MDF_Var), pointer :: varp
  10874. integer :: iftype
  10875. integer :: ftype
  10876. #ifdef with_hdf4
  10877. integer :: hdf4_offset(MAX_RANK)
  10878. integer :: hdf4_stride(MAX_RANK)
  10879. integer :: hdf4_count(MAX_RANK)
  10880. #endif
  10881. #ifdef with_hdf5_beta
  10882. !integer(HID_T) :: hdf5_type_id
  10883. integer(HID_T) :: hdf5_file_space_id
  10884. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  10885. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  10886. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  10887. #endif
  10888. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  10889. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  10890. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  10891. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  10892. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  10893. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  10894. ! --- begin --------------------------------------
  10895. ! pointer to file structure:
  10896. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  10897. IF_NOT_OK_RETURN(status=1)
  10898. ! pointer to variable structure:
  10899. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  10900. IF_NOT_OK_RETURN(status=1)
  10901. ! check ...
  10902. if ( size(shape(values)) > varp%ndim ) then
  10903. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  10904. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  10905. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  10906. TRACEBACK; status=1; return
  10907. end if
  10908. ! check ...
  10909. if ( present(start ) ) then
  10910. if ( size(start ) /= varp%ndim ) then
  10911. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10912. write (gol,'(" size start : ",i6)') size(start ); call goErr
  10913. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10914. TRACEBACK; status=1; return
  10915. end if
  10916. end if
  10917. if ( present(count ) ) then
  10918. if ( size(count ) /= varp%ndim ) then
  10919. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10920. write (gol,'(" size count : ",i6)') size(count ); call goErr
  10921. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10922. TRACEBACK; status=1; return
  10923. end if
  10924. end if
  10925. if ( present(stride ) ) then
  10926. if ( size(stride ) /= varp%ndim ) then
  10927. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10928. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  10929. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10930. TRACEBACK; status=1; return
  10931. end if
  10932. end if
  10933. if ( present(map ) ) then
  10934. if ( size(map ) /= varp%ndim ) then
  10935. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  10936. write (gol,'(" size map : ",i6)') size(map ); call goErr
  10937. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  10938. TRACEBACK; status=1; return
  10939. end if
  10940. end if
  10941. ! loop over file types:
  10942. do iftype = 1, filep%nftype
  10943. ! current type:
  10944. ftype = filep%ftypes(iftype)
  10945. ! select appropriate routine for each type:
  10946. select case ( ftype )
  10947. #ifdef with_hdf4
  10948. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10949. case ( MDF_HDF4 )
  10950. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  10951. ! check ...
  10952. if ( present(map ) ) then
  10953. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  10954. TRACEBACK; status=1; return
  10955. end if
  10956. ! fill offset (zero based!) and stride with default values:
  10957. hdf4_offset = 0
  10958. hdf4_stride = 1
  10959. ! count is by default the shape; padd with singleton dimensions:
  10960. hdf4_count = 1; hdf4_count(1:6) = shape(values)
  10961. ! replace by optional arguments if necessary:
  10962. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  10963. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  10964. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  10965. ! test target type;
  10966. ! convert to required kind before entering sfWData,
  10967. ! otherwise segmentation faults on some machines ...
  10968. select case ( varp%xtype )
  10969. case ( MDF_BYTE )
  10970. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  10971. values_int1 = int(values,kind=1)
  10972. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10973. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  10974. deallocate( values_int1 )
  10975. case ( MDF_SHORT )
  10976. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  10977. values_int2 = int(values,kind=2)
  10978. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10979. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  10980. deallocate( values_int2 )
  10981. case ( MDF_INT )
  10982. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  10983. values_int4 = int(values,kind=4)
  10984. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10985. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  10986. deallocate( values_int4 )
  10987. case ( MDF_FLOAT )
  10988. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  10989. values_real4 = real(values,kind=4)
  10990. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10991. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  10992. deallocate( values_real4 )
  10993. case ( MDF_DOUBLE )
  10994. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  10995. values_real8 = real(values,kind=8)
  10996. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  10997. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  10998. deallocate( values_real8 )
  10999. case default
  11000. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  11001. TRACEBACK; status=1; return
  11002. end select
  11003. if ( status == FAIL ) then
  11004. write (gol,'("writing hdf4 data set:")'); call goErr
  11005. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  11006. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  11007. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  11008. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  11009. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  11010. write (gol,'(" size : ",i12)') size(values); call goErr
  11011. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  11012. TRACEBACK; status=1; return
  11013. end if
  11014. #endif
  11015. #ifdef with_hdf5_beta
  11016. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11017. case ( MDF_HDF5 )
  11018. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11019. ! check ...
  11020. if ( present(map ) ) then
  11021. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  11022. TRACEBACK; status=1; return
  11023. end if
  11024. ! fill offset (zero based!), stride, and count :
  11025. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  11026. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  11027. hdf5_count = 1 ! default singleton dimension
  11028. if ( present(count) ) then
  11029. hdf5_count(1:varp%ndim) = count
  11030. else
  11031. hdf5_count(1:6) = shape(values)
  11032. end if
  11033. ! new dimension:
  11034. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  11035. ! target data space in file:
  11036. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  11037. IF_NOT_OK_RETURN(status=1)
  11038. ! chunked dataset ?
  11039. if ( varp%hdf5_chunked ) then
  11040. ! reset extend:
  11041. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  11042. IF_NOT_OK_RETURN(status=1)
  11043. end if
  11044. ! select hyperslab:
  11045. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  11046. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  11047. stride=hdf5_stride(1:varp%ndim) )
  11048. ! write data:
  11049. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  11050. int(shape(values),kind=HSIZE_T), status, &
  11051. file_space_id=hdf5_file_space_id )
  11052. IF_NOT_OK_RETURN(status=1)
  11053. ! release data space:
  11054. call H5SClose_f( hdf5_file_space_id, status )
  11055. IF_NOT_OK_RETURN(status=1)
  11056. #endif
  11057. #ifdef with_netcdf
  11058. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11059. case ( MDF_NETCDF, MDF_NETCDF4 )
  11060. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11061. ! test target type:
  11062. ! convert to required kind before entering NF90_Put_Var,
  11063. ! otherwise segmentation faults on some machines ...
  11064. select case ( varp%xtype )
  11065. case ( MDF_BYTE )
  11066. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11067. values_int1 = int(values,kind=1)
  11068. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  11069. start, count, stride, map )
  11070. IF_NF90_NOT_OK_RETURN(status=1)
  11071. deallocate( values_int1 )
  11072. case ( MDF_SHORT )
  11073. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11074. values_int2 = int(values,kind=2)
  11075. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  11076. start, count, stride, map )
  11077. IF_NF90_NOT_OK_RETURN(status=1)
  11078. deallocate( values_int2 )
  11079. case ( MDF_INT )
  11080. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11081. values_int4 = int(values,kind=4)
  11082. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  11083. start, count, stride, map )
  11084. IF_NF90_NOT_OK_RETURN(status=1)
  11085. deallocate( values_int4 )
  11086. case ( MDF_FLOAT )
  11087. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11088. values_real4 = real(values,kind=4)
  11089. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  11090. start, count, stride, map )
  11091. IF_NF90_NOT_OK_RETURN(status=1)
  11092. deallocate( values_real4 )
  11093. case ( MDF_DOUBLE )
  11094. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11095. values_real8 = real(values,kind=8)
  11096. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  11097. start, count, stride, map )
  11098. IF_NF90_NOT_OK_RETURN(status=1)
  11099. deallocate( values_real8 )
  11100. case default
  11101. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  11102. TRACEBACK; status=1; return
  11103. end select
  11104. ! just put; let netcdf library convert the right kind:
  11105. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  11106. ! start, count, stride, map )
  11107. !IF_NF90_NOT_OK_RETURN(status=1)
  11108. #endif
  11109. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11110. case default
  11111. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11112. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  11113. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  11114. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  11115. TRACEBACK; status=1; return
  11116. end select
  11117. end do ! file types
  11118. ! ok
  11119. status = 0
  11120. end subroutine MDF_Put_Var_i2_6d
  11121. ! ***
  11122. subroutine MDF_Get_Var_i2_6d( hid, varid, values, status, &
  11123. start, count, stride, map )
  11124. #ifdef with_netcdf
  11125. use NetCDF, only : NF90_Get_Var
  11126. #endif
  11127. ! --- in/out -------------------------------------
  11128. integer, intent(in) :: hid
  11129. integer, intent(in) :: varid
  11130. integer(2), intent(out) :: values(:,:,:,:,:,:)
  11131. integer, intent(out) :: status
  11132. integer, intent(in), optional :: start (:)
  11133. integer, intent(in), optional :: count (:)
  11134. integer, intent(in), optional :: stride(:)
  11135. integer, intent(in), optional :: map (:)
  11136. ! --- const --------------------------------------
  11137. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_6d'
  11138. ! --- external -----------------------------------
  11139. #ifdef with_hdf4
  11140. integer(hdf4_wpi), external :: sfRData
  11141. #endif
  11142. ! --- local --------------------------------------
  11143. type(MDF_File), pointer :: filep
  11144. type(MDF_Var), pointer :: varp
  11145. integer :: iftype
  11146. integer :: ftype
  11147. #ifdef with_hdf4
  11148. integer :: hdf4_offset(MAX_RANK)
  11149. integer :: hdf4_stride(MAX_RANK)
  11150. integer :: hdf4_count(MAX_RANK)
  11151. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  11152. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  11153. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  11154. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  11155. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  11156. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  11157. #endif
  11158. ! --- begin --------------------------------------
  11159. ! pointer to file structure:
  11160. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  11161. IF_NOT_OK_RETURN(status=1)
  11162. ! pointer to variable structure:
  11163. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  11164. IF_NOT_OK_RETURN(status=1)
  11165. ! check ...
  11166. if ( size(shape(values)) > varp%ndim ) then
  11167. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  11168. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  11169. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  11170. TRACEBACK; status=1; return
  11171. end if
  11172. ! check ...
  11173. if ( present(start ) ) then
  11174. if ( size(start ) /= varp%ndim ) then
  11175. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11176. write (gol,'(" size start : ",i6)') size(start ); call goErr
  11177. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11178. TRACEBACK; status=1; return
  11179. end if
  11180. end if
  11181. if ( present(count ) ) then
  11182. if ( size(count ) /= varp%ndim ) then
  11183. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11184. write (gol,'(" size count : ",i6)') size(count ); call goErr
  11185. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11186. TRACEBACK; status=1; return
  11187. end if
  11188. end if
  11189. if ( present(stride ) ) then
  11190. if ( size(stride ) /= varp%ndim ) then
  11191. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11192. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  11193. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11194. TRACEBACK; status=1; return
  11195. end if
  11196. end if
  11197. if ( present(map ) ) then
  11198. if ( size(map ) /= varp%ndim ) then
  11199. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11200. write (gol,'(" size map : ",i6)') size(map ); call goErr
  11201. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11202. TRACEBACK; status=1; return
  11203. end if
  11204. end if
  11205. ! loop over file types:
  11206. do iftype = 1, filep%nftype
  11207. ! current type:
  11208. ftype = filep%ftypes(iftype)
  11209. ! select appropriate routine for each type:
  11210. select case ( ftype )
  11211. #ifdef with_hdf4
  11212. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11213. case ( MDF_HDF4 )
  11214. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11215. ! check ...
  11216. if ( present(map ) ) then
  11217. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  11218. TRACEBACK; status=1; return
  11219. end if
  11220. ! fill offset (zero based!), stride, and count :
  11221. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  11222. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  11223. hdf4_count = 1 ! default singleton dimension
  11224. hdf4_count(1:6) = shape(values)
  11225. ! test source type:
  11226. select case ( varp%hdf4_xtype )
  11227. case ( DFNT_INT8 )
  11228. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11229. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  11230. values = int(values_int1,kind=2)
  11231. deallocate( values_int1 )
  11232. case ( DFNT_INT16 )
  11233. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11234. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  11235. values = int(values_int2,kind=2)
  11236. deallocate( values_int2 )
  11237. case ( DFNT_INT32 )
  11238. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11239. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  11240. values = int(values_int4,kind=2)
  11241. deallocate( values_int4 )
  11242. case ( DFNT_INT64 )
  11243. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11244. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  11245. values = int(values_int8,kind=2)
  11246. deallocate( values_int8 )
  11247. case ( DFNT_FLOAT32 )
  11248. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11249. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  11250. values = int(values_real4,kind=2)
  11251. deallocate( values_real4 )
  11252. case ( DFNT_FLOAT64 )
  11253. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  11254. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  11255. values = int(values_real8,kind=2)
  11256. deallocate( values_real8 )
  11257. case default
  11258. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  11259. TRACEBACK; status=1; return
  11260. end select
  11261. if ( status == FAIL ) then
  11262. write (gol,'("reading hdf4 data set:")'); call goErr
  11263. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  11264. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  11265. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  11266. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  11267. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  11268. write (gol,'(" size : ",i6)') size(values); call goErr
  11269. TRACEBACK; status=1; return
  11270. end if
  11271. #endif
  11272. #ifdef with_netcdf
  11273. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11274. case ( MDF_NETCDF, MDF_NETCDF4 )
  11275. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11276. ! read values, converted automatically:
  11277. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  11278. start, count, stride, map )
  11279. IF_NF90_NOT_OK_RETURN(status=1)
  11280. #endif
  11281. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11282. case default
  11283. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11284. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  11285. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  11286. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  11287. TRACEBACK; status=1; return
  11288. end select
  11289. end do ! file types
  11290. ! ok
  11291. status = 0
  11292. end subroutine MDF_Get_Var_i2_6d
  11293. ! ***
  11294. subroutine MDF_Put_Var_i2_7d( hid, varid, values, status, &
  11295. start, count, stride, map )
  11296. #ifdef with_hdf5_beta
  11297. use HDF5, only : HID_T, HSIZE_T
  11298. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  11299. use HDF5, only : H5T_NATIVE_CHARACTER
  11300. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  11301. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  11302. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  11303. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  11304. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  11305. #endif
  11306. #ifdef with_netcdf
  11307. use NetCDF, only : NF90_Put_Var
  11308. #endif
  11309. ! --- in/out -------------------------------------
  11310. integer, intent(in) :: hid
  11311. integer, intent(in) :: varid
  11312. integer(2), intent(in) :: values(:,:,:,:,:,:,:)
  11313. integer, intent(out) :: status
  11314. integer, intent(in), optional :: start (:)
  11315. integer, intent(in), optional :: count (:)
  11316. integer, intent(in), optional :: stride(:)
  11317. integer, intent(in), optional :: map (:)
  11318. ! --- const --------------------------------------
  11319. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_7d'
  11320. ! --- external -----------------------------------
  11321. #ifdef with_hdf4
  11322. integer(hdf4_wpi), external :: sfWData
  11323. #endif
  11324. ! --- local --------------------------------------
  11325. type(MDF_File), pointer :: filep
  11326. type(MDF_Var), pointer :: varp
  11327. integer :: iftype
  11328. integer :: ftype
  11329. #ifdef with_hdf4
  11330. integer :: hdf4_offset(MAX_RANK)
  11331. integer :: hdf4_stride(MAX_RANK)
  11332. integer :: hdf4_count(MAX_RANK)
  11333. #endif
  11334. #ifdef with_hdf5_beta
  11335. !integer(HID_T) :: hdf5_type_id
  11336. integer(HID_T) :: hdf5_file_space_id
  11337. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  11338. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  11339. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  11340. #endif
  11341. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  11342. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  11343. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  11344. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  11345. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  11346. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  11347. ! --- begin --------------------------------------
  11348. ! pointer to file structure:
  11349. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  11350. IF_NOT_OK_RETURN(status=1)
  11351. ! pointer to variable structure:
  11352. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  11353. IF_NOT_OK_RETURN(status=1)
  11354. ! check ...
  11355. if ( size(shape(values)) > varp%ndim ) then
  11356. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  11357. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  11358. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  11359. TRACEBACK; status=1; return
  11360. end if
  11361. ! check ...
  11362. if ( present(start ) ) then
  11363. if ( size(start ) /= varp%ndim ) then
  11364. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11365. write (gol,'(" size start : ",i6)') size(start ); call goErr
  11366. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11367. TRACEBACK; status=1; return
  11368. end if
  11369. end if
  11370. if ( present(count ) ) then
  11371. if ( size(count ) /= varp%ndim ) then
  11372. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11373. write (gol,'(" size count : ",i6)') size(count ); call goErr
  11374. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11375. TRACEBACK; status=1; return
  11376. end if
  11377. end if
  11378. if ( present(stride ) ) then
  11379. if ( size(stride ) /= varp%ndim ) then
  11380. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11381. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  11382. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11383. TRACEBACK; status=1; return
  11384. end if
  11385. end if
  11386. if ( present(map ) ) then
  11387. if ( size(map ) /= varp%ndim ) then
  11388. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11389. write (gol,'(" size map : ",i6)') size(map ); call goErr
  11390. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11391. TRACEBACK; status=1; return
  11392. end if
  11393. end if
  11394. ! loop over file types:
  11395. do iftype = 1, filep%nftype
  11396. ! current type:
  11397. ftype = filep%ftypes(iftype)
  11398. ! select appropriate routine for each type:
  11399. select case ( ftype )
  11400. #ifdef with_hdf4
  11401. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11402. case ( MDF_HDF4 )
  11403. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11404. ! check ...
  11405. if ( present(map ) ) then
  11406. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  11407. TRACEBACK; status=1; return
  11408. end if
  11409. ! fill offset (zero based!) and stride with default values:
  11410. hdf4_offset = 0
  11411. hdf4_stride = 1
  11412. ! count is by default the shape; padd with singleton dimensions:
  11413. hdf4_count = 1; hdf4_count(1:7) = shape(values)
  11414. ! replace by optional arguments if necessary:
  11415. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  11416. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  11417. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  11418. ! test target type;
  11419. ! convert to required kind before entering sfWData,
  11420. ! otherwise segmentation faults on some machines ...
  11421. select case ( varp%xtype )
  11422. case ( MDF_BYTE )
  11423. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11424. values_int1 = int(values,kind=1)
  11425. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11426. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  11427. deallocate( values_int1 )
  11428. case ( MDF_SHORT )
  11429. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11430. values_int2 = int(values,kind=2)
  11431. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11432. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  11433. deallocate( values_int2 )
  11434. case ( MDF_INT )
  11435. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11436. values_int4 = int(values,kind=4)
  11437. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11438. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  11439. deallocate( values_int4 )
  11440. case ( MDF_FLOAT )
  11441. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11442. values_real4 = real(values,kind=4)
  11443. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11444. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  11445. deallocate( values_real4 )
  11446. case ( MDF_DOUBLE )
  11447. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11448. values_real8 = real(values,kind=8)
  11449. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11450. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  11451. deallocate( values_real8 )
  11452. case default
  11453. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  11454. TRACEBACK; status=1; return
  11455. end select
  11456. if ( status == FAIL ) then
  11457. write (gol,'("writing hdf4 data set:")'); call goErr
  11458. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  11459. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  11460. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  11461. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  11462. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  11463. write (gol,'(" size : ",i12)') size(values); call goErr
  11464. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  11465. TRACEBACK; status=1; return
  11466. end if
  11467. #endif
  11468. #ifdef with_hdf5_beta
  11469. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11470. case ( MDF_HDF5 )
  11471. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11472. ! check ...
  11473. if ( present(map ) ) then
  11474. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  11475. TRACEBACK; status=1; return
  11476. end if
  11477. ! fill offset (zero based!), stride, and count :
  11478. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  11479. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  11480. hdf5_count = 1 ! default singleton dimension
  11481. if ( present(count) ) then
  11482. hdf5_count(1:varp%ndim) = count
  11483. else
  11484. hdf5_count(1:7) = shape(values)
  11485. end if
  11486. ! new dimension:
  11487. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  11488. ! target data space in file:
  11489. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  11490. IF_NOT_OK_RETURN(status=1)
  11491. ! chunked dataset ?
  11492. if ( varp%hdf5_chunked ) then
  11493. ! reset extend:
  11494. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  11495. IF_NOT_OK_RETURN(status=1)
  11496. end if
  11497. ! select hyperslab:
  11498. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  11499. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  11500. stride=hdf5_stride(1:varp%ndim) )
  11501. ! write data:
  11502. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), &
  11503. int(shape(values),kind=HSIZE_T), status, &
  11504. file_space_id=hdf5_file_space_id )
  11505. IF_NOT_OK_RETURN(status=1)
  11506. ! release data space:
  11507. call H5SClose_f( hdf5_file_space_id, status )
  11508. IF_NOT_OK_RETURN(status=1)
  11509. #endif
  11510. #ifdef with_netcdf
  11511. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11512. case ( MDF_NETCDF, MDF_NETCDF4 )
  11513. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11514. ! test target type:
  11515. ! convert to required kind before entering NF90_Put_Var,
  11516. ! otherwise segmentation faults on some machines ...
  11517. select case ( varp%xtype )
  11518. case ( MDF_BYTE )
  11519. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11520. values_int1 = int(values,kind=1)
  11521. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  11522. start, count, stride, map )
  11523. IF_NF90_NOT_OK_RETURN(status=1)
  11524. deallocate( values_int1 )
  11525. case ( MDF_SHORT )
  11526. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11527. values_int2 = int(values,kind=2)
  11528. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  11529. start, count, stride, map )
  11530. IF_NF90_NOT_OK_RETURN(status=1)
  11531. deallocate( values_int2 )
  11532. case ( MDF_INT )
  11533. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11534. values_int4 = int(values,kind=4)
  11535. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  11536. start, count, stride, map )
  11537. IF_NF90_NOT_OK_RETURN(status=1)
  11538. deallocate( values_int4 )
  11539. case ( MDF_FLOAT )
  11540. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11541. values_real4 = real(values,kind=4)
  11542. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  11543. start, count, stride, map )
  11544. IF_NF90_NOT_OK_RETURN(status=1)
  11545. deallocate( values_real4 )
  11546. case ( MDF_DOUBLE )
  11547. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11548. values_real8 = real(values,kind=8)
  11549. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  11550. start, count, stride, map )
  11551. IF_NF90_NOT_OK_RETURN(status=1)
  11552. deallocate( values_real8 )
  11553. case default
  11554. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  11555. TRACEBACK; status=1; return
  11556. end select
  11557. ! just put; let netcdf library convert the right kind:
  11558. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  11559. ! start, count, stride, map )
  11560. !IF_NF90_NOT_OK_RETURN(status=1)
  11561. #endif
  11562. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11563. case default
  11564. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11565. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  11566. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  11567. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  11568. TRACEBACK; status=1; return
  11569. end select
  11570. end do ! file types
  11571. ! ok
  11572. status = 0
  11573. end subroutine MDF_Put_Var_i2_7d
  11574. ! ***
  11575. subroutine MDF_Get_Var_i2_7d( hid, varid, values, status, &
  11576. start, count, stride, map )
  11577. #ifdef with_netcdf
  11578. use NetCDF, only : NF90_Get_Var
  11579. #endif
  11580. ! --- in/out -------------------------------------
  11581. integer, intent(in) :: hid
  11582. integer, intent(in) :: varid
  11583. integer(2), intent(out) :: values(:,:,:,:,:,:,:)
  11584. integer, intent(out) :: status
  11585. integer, intent(in), optional :: start (:)
  11586. integer, intent(in), optional :: count (:)
  11587. integer, intent(in), optional :: stride(:)
  11588. integer, intent(in), optional :: map (:)
  11589. ! --- const --------------------------------------
  11590. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_7d'
  11591. ! --- external -----------------------------------
  11592. #ifdef with_hdf4
  11593. integer(hdf4_wpi), external :: sfRData
  11594. #endif
  11595. ! --- local --------------------------------------
  11596. type(MDF_File), pointer :: filep
  11597. type(MDF_Var), pointer :: varp
  11598. integer :: iftype
  11599. integer :: ftype
  11600. #ifdef with_hdf4
  11601. integer :: hdf4_offset(MAX_RANK)
  11602. integer :: hdf4_stride(MAX_RANK)
  11603. integer :: hdf4_count(MAX_RANK)
  11604. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  11605. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  11606. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  11607. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  11608. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  11609. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  11610. #endif
  11611. ! --- begin --------------------------------------
  11612. ! pointer to file structure:
  11613. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  11614. IF_NOT_OK_RETURN(status=1)
  11615. ! pointer to variable structure:
  11616. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  11617. IF_NOT_OK_RETURN(status=1)
  11618. ! check ...
  11619. if ( size(shape(values)) > varp%ndim ) then
  11620. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  11621. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  11622. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  11623. TRACEBACK; status=1; return
  11624. end if
  11625. ! check ...
  11626. if ( present(start ) ) then
  11627. if ( size(start ) /= varp%ndim ) then
  11628. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11629. write (gol,'(" size start : ",i6)') size(start ); call goErr
  11630. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11631. TRACEBACK; status=1; return
  11632. end if
  11633. end if
  11634. if ( present(count ) ) then
  11635. if ( size(count ) /= varp%ndim ) then
  11636. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11637. write (gol,'(" size count : ",i6)') size(count ); call goErr
  11638. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11639. TRACEBACK; status=1; return
  11640. end if
  11641. end if
  11642. if ( present(stride ) ) then
  11643. if ( size(stride ) /= varp%ndim ) then
  11644. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11645. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  11646. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11647. TRACEBACK; status=1; return
  11648. end if
  11649. end if
  11650. if ( present(map ) ) then
  11651. if ( size(map ) /= varp%ndim ) then
  11652. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11653. write (gol,'(" size map : ",i6)') size(map ); call goErr
  11654. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11655. TRACEBACK; status=1; return
  11656. end if
  11657. end if
  11658. ! loop over file types:
  11659. do iftype = 1, filep%nftype
  11660. ! current type:
  11661. ftype = filep%ftypes(iftype)
  11662. ! select appropriate routine for each type:
  11663. select case ( ftype )
  11664. #ifdef with_hdf4
  11665. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11666. case ( MDF_HDF4 )
  11667. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11668. ! check ...
  11669. if ( present(map ) ) then
  11670. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  11671. TRACEBACK; status=1; return
  11672. end if
  11673. ! fill offset (zero based!), stride, and count :
  11674. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  11675. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  11676. hdf4_count = 1 ! default singleton dimension
  11677. hdf4_count(1:7) = shape(values)
  11678. ! test source type:
  11679. select case ( varp%hdf4_xtype )
  11680. case ( DFNT_INT8 )
  11681. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11682. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  11683. values = int(values_int1,kind=2)
  11684. deallocate( values_int1 )
  11685. case ( DFNT_INT16 )
  11686. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11687. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  11688. values = int(values_int2,kind=2)
  11689. deallocate( values_int2 )
  11690. case ( DFNT_INT32 )
  11691. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11692. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  11693. values = int(values_int4,kind=2)
  11694. deallocate( values_int4 )
  11695. case ( DFNT_INT64 )
  11696. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11697. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  11698. values = int(values_int8,kind=2)
  11699. deallocate( values_int8 )
  11700. case ( DFNT_FLOAT32 )
  11701. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11702. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  11703. values = int(values_real4,kind=2)
  11704. deallocate( values_real4 )
  11705. case ( DFNT_FLOAT64 )
  11706. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  11707. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  11708. values = int(values_real8,kind=2)
  11709. deallocate( values_real8 )
  11710. case default
  11711. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  11712. TRACEBACK; status=1; return
  11713. end select
  11714. if ( status == FAIL ) then
  11715. write (gol,'("reading hdf4 data set:")'); call goErr
  11716. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  11717. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  11718. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  11719. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  11720. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  11721. write (gol,'(" size : ",i6)') size(values); call goErr
  11722. TRACEBACK; status=1; return
  11723. end if
  11724. #endif
  11725. #ifdef with_netcdf
  11726. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11727. case ( MDF_NETCDF, MDF_NETCDF4 )
  11728. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11729. ! read values, converted automatically:
  11730. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  11731. start, count, stride, map )
  11732. IF_NF90_NOT_OK_RETURN(status=1)
  11733. #endif
  11734. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11735. case default
  11736. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11737. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  11738. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  11739. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  11740. TRACEBACK; status=1; return
  11741. end select
  11742. end do ! file types
  11743. ! ok
  11744. status = 0
  11745. end subroutine MDF_Get_Var_i2_7d
  11746. ! ***
  11747. subroutine MDF_Put_Var_i4_1d( hid, varid, values, status, &
  11748. start, count, stride, map )
  11749. #ifdef with_hdf5_beta
  11750. use HDF5, only : HID_T, HSIZE_T
  11751. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  11752. use HDF5, only : H5T_NATIVE_CHARACTER
  11753. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  11754. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  11755. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  11756. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  11757. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  11758. #endif
  11759. #ifdef with_netcdf
  11760. use NetCDF, only : NF90_Put_Var
  11761. #endif
  11762. ! --- in/out -------------------------------------
  11763. integer, intent(in) :: hid
  11764. integer, intent(in) :: varid
  11765. integer(4), intent(in) :: values(:)
  11766. integer, intent(out) :: status
  11767. integer, intent(in), optional :: start (:)
  11768. integer, intent(in), optional :: count (:)
  11769. integer, intent(in), optional :: stride(:)
  11770. integer, intent(in), optional :: map (:)
  11771. ! --- const --------------------------------------
  11772. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_1d'
  11773. ! --- external -----------------------------------
  11774. #ifdef with_hdf4
  11775. integer(hdf4_wpi), external :: sfWData
  11776. #endif
  11777. ! --- local --------------------------------------
  11778. type(MDF_File), pointer :: filep
  11779. type(MDF_Var), pointer :: varp
  11780. integer :: iftype
  11781. integer :: ftype
  11782. #ifdef with_hdf4
  11783. integer :: hdf4_offset(MAX_RANK)
  11784. integer :: hdf4_stride(MAX_RANK)
  11785. integer :: hdf4_count(MAX_RANK)
  11786. #endif
  11787. #ifdef with_hdf5_beta
  11788. !integer(HID_T) :: hdf5_type_id
  11789. integer(HID_T) :: hdf5_file_space_id
  11790. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  11791. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  11792. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  11793. #endif
  11794. integer(1), allocatable :: values_int1(:)
  11795. integer(2), allocatable :: values_int2(:)
  11796. integer(4), allocatable :: values_int4(:)
  11797. integer(8), allocatable :: values_int8(:)
  11798. real(4), allocatable :: values_real4(:)
  11799. real(8), allocatable :: values_real8(:)
  11800. ! --- begin --------------------------------------
  11801. ! pointer to file structure:
  11802. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  11803. IF_NOT_OK_RETURN(status=1)
  11804. ! pointer to variable structure:
  11805. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  11806. IF_NOT_OK_RETURN(status=1)
  11807. ! check ...
  11808. if ( size(shape(values)) > varp%ndim ) then
  11809. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  11810. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  11811. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  11812. TRACEBACK; status=1; return
  11813. end if
  11814. ! check ...
  11815. if ( present(start ) ) then
  11816. if ( size(start ) /= varp%ndim ) then
  11817. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11818. write (gol,'(" size start : ",i6)') size(start ); call goErr
  11819. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11820. TRACEBACK; status=1; return
  11821. end if
  11822. end if
  11823. if ( present(count ) ) then
  11824. if ( size(count ) /= varp%ndim ) then
  11825. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11826. write (gol,'(" size count : ",i6)') size(count ); call goErr
  11827. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11828. TRACEBACK; status=1; return
  11829. end if
  11830. end if
  11831. if ( present(stride ) ) then
  11832. if ( size(stride ) /= varp%ndim ) then
  11833. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11834. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  11835. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11836. TRACEBACK; status=1; return
  11837. end if
  11838. end if
  11839. if ( present(map ) ) then
  11840. if ( size(map ) /= varp%ndim ) then
  11841. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  11842. write (gol,'(" size map : ",i6)') size(map ); call goErr
  11843. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  11844. TRACEBACK; status=1; return
  11845. end if
  11846. end if
  11847. ! loop over file types:
  11848. do iftype = 1, filep%nftype
  11849. ! current type:
  11850. ftype = filep%ftypes(iftype)
  11851. ! select appropriate routine for each type:
  11852. select case ( ftype )
  11853. #ifdef with_hdf4
  11854. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11855. case ( MDF_HDF4 )
  11856. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11857. ! check ...
  11858. if ( present(map ) ) then
  11859. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  11860. TRACEBACK; status=1; return
  11861. end if
  11862. ! fill offset (zero based!) and stride with default values:
  11863. hdf4_offset = 0
  11864. hdf4_stride = 1
  11865. ! count is by default the shape; padd with singleton dimensions:
  11866. hdf4_count = 1; hdf4_count(1:1) = shape(values)
  11867. ! replace by optional arguments if necessary:
  11868. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  11869. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  11870. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  11871. ! test target type;
  11872. ! convert to required kind before entering sfWData,
  11873. ! otherwise segmentation faults on some machines ...
  11874. select case ( varp%xtype )
  11875. case ( MDF_BYTE )
  11876. allocate( values_int1(size(values,1)) )
  11877. values_int1 = int(values,kind=1)
  11878. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11879. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  11880. deallocate( values_int1 )
  11881. case ( MDF_SHORT )
  11882. allocate( values_int2(size(values,1)) )
  11883. values_int2 = int(values,kind=2)
  11884. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11885. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  11886. deallocate( values_int2 )
  11887. case ( MDF_INT )
  11888. allocate( values_int4(size(values,1)) )
  11889. values_int4 = int(values,kind=4)
  11890. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11891. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  11892. deallocate( values_int4 )
  11893. case ( MDF_FLOAT )
  11894. allocate( values_real4(size(values,1)) )
  11895. values_real4 = real(values,kind=4)
  11896. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11897. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  11898. deallocate( values_real4 )
  11899. case ( MDF_DOUBLE )
  11900. allocate( values_real8(size(values,1)) )
  11901. values_real8 = real(values,kind=8)
  11902. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  11903. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  11904. deallocate( values_real8 )
  11905. case default
  11906. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  11907. TRACEBACK; status=1; return
  11908. end select
  11909. if ( status == FAIL ) then
  11910. write (gol,'("writing hdf4 data set:")'); call goErr
  11911. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  11912. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  11913. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  11914. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  11915. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  11916. write (gol,'(" size : ",i12)') size(values); call goErr
  11917. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  11918. TRACEBACK; status=1; return
  11919. end if
  11920. #endif
  11921. #ifdef with_hdf5_beta
  11922. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11923. case ( MDF_HDF5 )
  11924. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11925. ! check ...
  11926. if ( present(map ) ) then
  11927. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  11928. TRACEBACK; status=1; return
  11929. end if
  11930. ! fill offset (zero based!), stride, and count :
  11931. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  11932. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  11933. hdf5_count = 1 ! default singleton dimension
  11934. if ( present(count) ) then
  11935. hdf5_count(1:varp%ndim) = count
  11936. else
  11937. hdf5_count(1:1) = shape(values)
  11938. end if
  11939. ! new dimension:
  11940. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  11941. ! target data space in file:
  11942. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  11943. IF_NOT_OK_RETURN(status=1)
  11944. ! chunked dataset ?
  11945. if ( varp%hdf5_chunked ) then
  11946. ! reset extend:
  11947. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  11948. IF_NOT_OK_RETURN(status=1)
  11949. end if
  11950. ! select hyperslab:
  11951. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  11952. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  11953. stride=hdf5_stride(1:varp%ndim) )
  11954. ! write data:
  11955. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  11956. int(shape(values),kind=HSIZE_T), status, &
  11957. file_space_id=hdf5_file_space_id )
  11958. IF_NOT_OK_RETURN(status=1)
  11959. ! release data space:
  11960. call H5SClose_f( hdf5_file_space_id, status )
  11961. IF_NOT_OK_RETURN(status=1)
  11962. #endif
  11963. #ifdef with_netcdf
  11964. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11965. case ( MDF_NETCDF, MDF_NETCDF4 )
  11966. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  11967. ! test target type:
  11968. ! convert to required kind before entering NF90_Put_Var,
  11969. ! otherwise segmentation faults on some machines ...
  11970. select case ( varp%xtype )
  11971. case ( MDF_BYTE )
  11972. allocate( values_int1(size(values,1)) )
  11973. values_int1 = int(values,kind=1)
  11974. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  11975. start, count, stride, map )
  11976. IF_NF90_NOT_OK_RETURN(status=1)
  11977. deallocate( values_int1 )
  11978. case ( MDF_SHORT )
  11979. allocate( values_int2(size(values,1)) )
  11980. values_int2 = int(values,kind=2)
  11981. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  11982. start, count, stride, map )
  11983. IF_NF90_NOT_OK_RETURN(status=1)
  11984. deallocate( values_int2 )
  11985. case ( MDF_INT )
  11986. allocate( values_int4(size(values,1)) )
  11987. values_int4 = int(values,kind=4)
  11988. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  11989. start, count, stride, map )
  11990. IF_NF90_NOT_OK_RETURN(status=1)
  11991. deallocate( values_int4 )
  11992. case ( MDF_FLOAT )
  11993. allocate( values_real4(size(values,1)) )
  11994. values_real4 = real(values,kind=4)
  11995. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  11996. start, count, stride, map )
  11997. IF_NF90_NOT_OK_RETURN(status=1)
  11998. deallocate( values_real4 )
  11999. case ( MDF_DOUBLE )
  12000. allocate( values_real8(size(values,1)) )
  12001. values_real8 = real(values,kind=8)
  12002. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  12003. start, count, stride, map )
  12004. IF_NF90_NOT_OK_RETURN(status=1)
  12005. deallocate( values_real8 )
  12006. case default
  12007. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  12008. TRACEBACK; status=1; return
  12009. end select
  12010. ! just put; let netcdf library convert the right kind:
  12011. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  12012. ! start, count, stride, map )
  12013. !IF_NF90_NOT_OK_RETURN(status=1)
  12014. #endif
  12015. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12016. case default
  12017. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12018. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  12019. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  12020. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  12021. TRACEBACK; status=1; return
  12022. end select
  12023. end do ! file types
  12024. ! ok
  12025. status = 0
  12026. end subroutine MDF_Put_Var_i4_1d
  12027. ! ***
  12028. subroutine MDF_Get_Var_i4_1d( hid, varid, values, status, &
  12029. start, count, stride, map )
  12030. #ifdef with_netcdf
  12031. use NetCDF, only : NF90_Get_Var
  12032. #endif
  12033. ! --- in/out -------------------------------------
  12034. integer, intent(in) :: hid
  12035. integer, intent(in) :: varid
  12036. integer(4), intent(out) :: values(:)
  12037. integer, intent(out) :: status
  12038. integer, intent(in), optional :: start (:)
  12039. integer, intent(in), optional :: count (:)
  12040. integer, intent(in), optional :: stride(:)
  12041. integer, intent(in), optional :: map (:)
  12042. ! --- const --------------------------------------
  12043. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_1d'
  12044. ! --- external -----------------------------------
  12045. #ifdef with_hdf4
  12046. integer(hdf4_wpi), external :: sfRData
  12047. #endif
  12048. ! --- local --------------------------------------
  12049. type(MDF_File), pointer :: filep
  12050. type(MDF_Var), pointer :: varp
  12051. integer :: iftype
  12052. integer :: ftype
  12053. #ifdef with_hdf4
  12054. integer :: hdf4_offset(MAX_RANK)
  12055. integer :: hdf4_stride(MAX_RANK)
  12056. integer :: hdf4_count(MAX_RANK)
  12057. integer(1), allocatable :: values_int1(:)
  12058. integer(2), allocatable :: values_int2(:)
  12059. integer(4), allocatable :: values_int4(:)
  12060. integer(8), allocatable :: values_int8(:)
  12061. real(4), allocatable :: values_real4(:)
  12062. real(8), allocatable :: values_real8(:)
  12063. #endif
  12064. ! --- begin --------------------------------------
  12065. ! pointer to file structure:
  12066. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  12067. IF_NOT_OK_RETURN(status=1)
  12068. ! pointer to variable structure:
  12069. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  12070. IF_NOT_OK_RETURN(status=1)
  12071. ! check ...
  12072. if ( size(shape(values)) > varp%ndim ) then
  12073. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  12074. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  12075. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  12076. TRACEBACK; status=1; return
  12077. end if
  12078. ! check ...
  12079. if ( present(start ) ) then
  12080. if ( size(start ) /= varp%ndim ) then
  12081. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12082. write (gol,'(" size start : ",i6)') size(start ); call goErr
  12083. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12084. TRACEBACK; status=1; return
  12085. end if
  12086. end if
  12087. if ( present(count ) ) then
  12088. if ( size(count ) /= varp%ndim ) then
  12089. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12090. write (gol,'(" size count : ",i6)') size(count ); call goErr
  12091. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12092. TRACEBACK; status=1; return
  12093. end if
  12094. end if
  12095. if ( present(stride ) ) then
  12096. if ( size(stride ) /= varp%ndim ) then
  12097. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12098. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  12099. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12100. TRACEBACK; status=1; return
  12101. end if
  12102. end if
  12103. if ( present(map ) ) then
  12104. if ( size(map ) /= varp%ndim ) then
  12105. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12106. write (gol,'(" size map : ",i6)') size(map ); call goErr
  12107. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12108. TRACEBACK; status=1; return
  12109. end if
  12110. end if
  12111. ! loop over file types:
  12112. do iftype = 1, filep%nftype
  12113. ! current type:
  12114. ftype = filep%ftypes(iftype)
  12115. ! select appropriate routine for each type:
  12116. select case ( ftype )
  12117. #ifdef with_hdf4
  12118. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12119. case ( MDF_HDF4 )
  12120. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12121. ! check ...
  12122. if ( present(map ) ) then
  12123. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  12124. TRACEBACK; status=1; return
  12125. end if
  12126. ! fill offset (zero based!), stride, and count :
  12127. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  12128. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  12129. hdf4_count = 1 ! default singleton dimension
  12130. hdf4_count(1:1) = shape(values)
  12131. ! test source type:
  12132. select case ( varp%hdf4_xtype )
  12133. case ( DFNT_INT8 )
  12134. allocate( values_int1(size(values,1)) )
  12135. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  12136. values = int(values_int1,kind=4)
  12137. deallocate( values_int1 )
  12138. case ( DFNT_INT16 )
  12139. allocate( values_int2(size(values,1)) )
  12140. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  12141. values = int(values_int2,kind=4)
  12142. deallocate( values_int2 )
  12143. case ( DFNT_INT32 )
  12144. allocate( values_int4(size(values,1)) )
  12145. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  12146. values = int(values_int4,kind=4)
  12147. deallocate( values_int4 )
  12148. case ( DFNT_INT64 )
  12149. allocate( values_int8(size(values,1)) )
  12150. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  12151. values = int(values_int8,kind=4)
  12152. deallocate( values_int8 )
  12153. case ( DFNT_FLOAT32 )
  12154. allocate( values_real4(size(values,1)) )
  12155. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  12156. values = int(values_real4,kind=4)
  12157. deallocate( values_real4 )
  12158. case ( DFNT_FLOAT64 )
  12159. allocate( values_real8(size(values,1)) )
  12160. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  12161. values = int(values_real8,kind=4)
  12162. deallocate( values_real8 )
  12163. case default
  12164. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  12165. TRACEBACK; status=1; return
  12166. end select
  12167. if ( status == FAIL ) then
  12168. write (gol,'("reading hdf4 data set:")'); call goErr
  12169. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  12170. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  12171. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  12172. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  12173. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  12174. write (gol,'(" size : ",i6)') size(values); call goErr
  12175. TRACEBACK; status=1; return
  12176. end if
  12177. #endif
  12178. #ifdef with_netcdf
  12179. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12180. case ( MDF_NETCDF, MDF_NETCDF4 )
  12181. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12182. ! read values, converted automatically:
  12183. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  12184. start, count, stride, map )
  12185. IF_NF90_NOT_OK_RETURN(status=1)
  12186. #endif
  12187. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12188. case default
  12189. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12190. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  12191. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  12192. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  12193. TRACEBACK; status=1; return
  12194. end select
  12195. end do ! file types
  12196. ! ok
  12197. status = 0
  12198. end subroutine MDF_Get_Var_i4_1d
  12199. ! ***
  12200. subroutine MDF_Put_Var_i4_2d( hid, varid, values, status, &
  12201. start, count, stride, map )
  12202. #ifdef with_hdf5_beta
  12203. use HDF5, only : HID_T, HSIZE_T
  12204. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  12205. use HDF5, only : H5T_NATIVE_CHARACTER
  12206. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  12207. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  12208. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  12209. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  12210. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  12211. #endif
  12212. #ifdef with_netcdf
  12213. use NetCDF, only : NF90_Put_Var
  12214. #endif
  12215. ! --- in/out -------------------------------------
  12216. integer, intent(in) :: hid
  12217. integer, intent(in) :: varid
  12218. integer(4), intent(in) :: values(:,:)
  12219. integer, intent(out) :: status
  12220. integer, intent(in), optional :: start (:)
  12221. integer, intent(in), optional :: count (:)
  12222. integer, intent(in), optional :: stride(:)
  12223. integer, intent(in), optional :: map (:)
  12224. ! --- const --------------------------------------
  12225. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_2d'
  12226. ! --- external -----------------------------------
  12227. #ifdef with_hdf4
  12228. integer(hdf4_wpi), external :: sfWData
  12229. #endif
  12230. ! --- local --------------------------------------
  12231. type(MDF_File), pointer :: filep
  12232. type(MDF_Var), pointer :: varp
  12233. integer :: iftype
  12234. integer :: ftype
  12235. #ifdef with_hdf4
  12236. integer :: hdf4_offset(MAX_RANK)
  12237. integer :: hdf4_stride(MAX_RANK)
  12238. integer :: hdf4_count(MAX_RANK)
  12239. #endif
  12240. #ifdef with_hdf5_beta
  12241. !integer(HID_T) :: hdf5_type_id
  12242. integer(HID_T) :: hdf5_file_space_id
  12243. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  12244. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  12245. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  12246. #endif
  12247. integer(1), allocatable :: values_int1(:,:)
  12248. integer(2), allocatable :: values_int2(:,:)
  12249. integer(4), allocatable :: values_int4(:,:)
  12250. integer(8), allocatable :: values_int8(:,:)
  12251. real(4), allocatable :: values_real4(:,:)
  12252. real(8), allocatable :: values_real8(:,:)
  12253. ! --- begin --------------------------------------
  12254. ! pointer to file structure:
  12255. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  12256. IF_NOT_OK_RETURN(status=1)
  12257. ! pointer to variable structure:
  12258. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  12259. IF_NOT_OK_RETURN(status=1)
  12260. ! check ...
  12261. if ( size(shape(values)) > varp%ndim ) then
  12262. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  12263. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  12264. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  12265. TRACEBACK; status=1; return
  12266. end if
  12267. ! check ...
  12268. if ( present(start ) ) then
  12269. if ( size(start ) /= varp%ndim ) then
  12270. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12271. write (gol,'(" size start : ",i6)') size(start ); call goErr
  12272. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12273. TRACEBACK; status=1; return
  12274. end if
  12275. end if
  12276. if ( present(count ) ) then
  12277. if ( size(count ) /= varp%ndim ) then
  12278. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12279. write (gol,'(" size count : ",i6)') size(count ); call goErr
  12280. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12281. TRACEBACK; status=1; return
  12282. end if
  12283. end if
  12284. if ( present(stride ) ) then
  12285. if ( size(stride ) /= varp%ndim ) then
  12286. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12287. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  12288. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12289. TRACEBACK; status=1; return
  12290. end if
  12291. end if
  12292. if ( present(map ) ) then
  12293. if ( size(map ) /= varp%ndim ) then
  12294. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12295. write (gol,'(" size map : ",i6)') size(map ); call goErr
  12296. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12297. TRACEBACK; status=1; return
  12298. end if
  12299. end if
  12300. ! loop over file types:
  12301. do iftype = 1, filep%nftype
  12302. ! current type:
  12303. ftype = filep%ftypes(iftype)
  12304. ! select appropriate routine for each type:
  12305. select case ( ftype )
  12306. #ifdef with_hdf4
  12307. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12308. case ( MDF_HDF4 )
  12309. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12310. ! check ...
  12311. if ( present(map ) ) then
  12312. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  12313. TRACEBACK; status=1; return
  12314. end if
  12315. ! fill offset (zero based!) and stride with default values:
  12316. hdf4_offset = 0
  12317. hdf4_stride = 1
  12318. ! count is by default the shape; padd with singleton dimensions:
  12319. hdf4_count = 1; hdf4_count(1:2) = shape(values)
  12320. ! replace by optional arguments if necessary:
  12321. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  12322. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  12323. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  12324. ! test target type;
  12325. ! convert to required kind before entering sfWData,
  12326. ! otherwise segmentation faults on some machines ...
  12327. select case ( varp%xtype )
  12328. case ( MDF_BYTE )
  12329. allocate( values_int1(size(values,1),size(values,2)) )
  12330. values_int1 = int(values,kind=1)
  12331. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12332. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  12333. deallocate( values_int1 )
  12334. case ( MDF_SHORT )
  12335. allocate( values_int2(size(values,1),size(values,2)) )
  12336. values_int2 = int(values,kind=2)
  12337. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12338. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  12339. deallocate( values_int2 )
  12340. case ( MDF_INT )
  12341. allocate( values_int4(size(values,1),size(values,2)) )
  12342. values_int4 = int(values,kind=4)
  12343. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12344. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  12345. deallocate( values_int4 )
  12346. case ( MDF_FLOAT )
  12347. allocate( values_real4(size(values,1),size(values,2)) )
  12348. values_real4 = real(values,kind=4)
  12349. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12350. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  12351. deallocate( values_real4 )
  12352. case ( MDF_DOUBLE )
  12353. allocate( values_real8(size(values,1),size(values,2)) )
  12354. values_real8 = real(values,kind=8)
  12355. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12356. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  12357. deallocate( values_real8 )
  12358. case default
  12359. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  12360. TRACEBACK; status=1; return
  12361. end select
  12362. if ( status == FAIL ) then
  12363. write (gol,'("writing hdf4 data set:")'); call goErr
  12364. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  12365. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  12366. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  12367. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  12368. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  12369. write (gol,'(" size : ",i12)') size(values); call goErr
  12370. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  12371. TRACEBACK; status=1; return
  12372. end if
  12373. #endif
  12374. #ifdef with_hdf5_beta
  12375. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12376. case ( MDF_HDF5 )
  12377. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12378. ! check ...
  12379. if ( present(map ) ) then
  12380. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  12381. TRACEBACK; status=1; return
  12382. end if
  12383. ! fill offset (zero based!), stride, and count :
  12384. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  12385. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  12386. hdf5_count = 1 ! default singleton dimension
  12387. if ( present(count) ) then
  12388. hdf5_count(1:varp%ndim) = count
  12389. else
  12390. hdf5_count(1:2) = shape(values)
  12391. end if
  12392. ! new dimension:
  12393. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  12394. ! target data space in file:
  12395. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  12396. IF_NOT_OK_RETURN(status=1)
  12397. ! chunked dataset ?
  12398. if ( varp%hdf5_chunked ) then
  12399. ! reset extend:
  12400. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  12401. IF_NOT_OK_RETURN(status=1)
  12402. end if
  12403. ! select hyperslab:
  12404. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  12405. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  12406. stride=hdf5_stride(1:varp%ndim) )
  12407. ! write data:
  12408. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  12409. int(shape(values),kind=HSIZE_T), status, &
  12410. file_space_id=hdf5_file_space_id )
  12411. IF_NOT_OK_RETURN(status=1)
  12412. ! release data space:
  12413. call H5SClose_f( hdf5_file_space_id, status )
  12414. IF_NOT_OK_RETURN(status=1)
  12415. #endif
  12416. #ifdef with_netcdf
  12417. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12418. case ( MDF_NETCDF, MDF_NETCDF4 )
  12419. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12420. ! test target type:
  12421. ! convert to required kind before entering NF90_Put_Var,
  12422. ! otherwise segmentation faults on some machines ...
  12423. select case ( varp%xtype )
  12424. case ( MDF_BYTE )
  12425. allocate( values_int1(size(values,1),size(values,2)) )
  12426. values_int1 = int(values,kind=1)
  12427. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  12428. start, count, stride, map )
  12429. IF_NF90_NOT_OK_RETURN(status=1)
  12430. deallocate( values_int1 )
  12431. case ( MDF_SHORT )
  12432. allocate( values_int2(size(values,1),size(values,2)) )
  12433. values_int2 = int(values,kind=2)
  12434. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  12435. start, count, stride, map )
  12436. IF_NF90_NOT_OK_RETURN(status=1)
  12437. deallocate( values_int2 )
  12438. case ( MDF_INT )
  12439. allocate( values_int4(size(values,1),size(values,2)) )
  12440. values_int4 = int(values,kind=4)
  12441. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  12442. start, count, stride, map )
  12443. IF_NF90_NOT_OK_RETURN(status=1)
  12444. deallocate( values_int4 )
  12445. case ( MDF_FLOAT )
  12446. allocate( values_real4(size(values,1),size(values,2)) )
  12447. values_real4 = real(values,kind=4)
  12448. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  12449. start, count, stride, map )
  12450. IF_NF90_NOT_OK_RETURN(status=1)
  12451. deallocate( values_real4 )
  12452. case ( MDF_DOUBLE )
  12453. allocate( values_real8(size(values,1),size(values,2)) )
  12454. values_real8 = real(values,kind=8)
  12455. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  12456. start, count, stride, map )
  12457. IF_NF90_NOT_OK_RETURN(status=1)
  12458. deallocate( values_real8 )
  12459. case default
  12460. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  12461. TRACEBACK; status=1; return
  12462. end select
  12463. ! just put; let netcdf library convert the right kind:
  12464. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  12465. ! start, count, stride, map )
  12466. !IF_NF90_NOT_OK_RETURN(status=1)
  12467. #endif
  12468. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12469. case default
  12470. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12471. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  12472. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  12473. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  12474. TRACEBACK; status=1; return
  12475. end select
  12476. end do ! file types
  12477. ! ok
  12478. status = 0
  12479. end subroutine MDF_Put_Var_i4_2d
  12480. ! ***
  12481. subroutine MDF_Get_Var_i4_2d( hid, varid, values, status, &
  12482. start, count, stride, map )
  12483. #ifdef with_netcdf
  12484. use NetCDF, only : NF90_Get_Var
  12485. #endif
  12486. ! --- in/out -------------------------------------
  12487. integer, intent(in) :: hid
  12488. integer, intent(in) :: varid
  12489. integer(4), intent(out) :: values(:,:)
  12490. integer, intent(out) :: status
  12491. integer, intent(in), optional :: start (:)
  12492. integer, intent(in), optional :: count (:)
  12493. integer, intent(in), optional :: stride(:)
  12494. integer, intent(in), optional :: map (:)
  12495. ! --- const --------------------------------------
  12496. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_2d'
  12497. ! --- external -----------------------------------
  12498. #ifdef with_hdf4
  12499. integer(hdf4_wpi), external :: sfRData
  12500. #endif
  12501. ! --- local --------------------------------------
  12502. type(MDF_File), pointer :: filep
  12503. type(MDF_Var), pointer :: varp
  12504. integer :: iftype
  12505. integer :: ftype
  12506. #ifdef with_hdf4
  12507. integer :: hdf4_offset(MAX_RANK)
  12508. integer :: hdf4_stride(MAX_RANK)
  12509. integer :: hdf4_count(MAX_RANK)
  12510. integer(1), allocatable :: values_int1(:,:)
  12511. integer(2), allocatable :: values_int2(:,:)
  12512. integer(4), allocatable :: values_int4(:,:)
  12513. integer(8), allocatable :: values_int8(:,:)
  12514. real(4), allocatable :: values_real4(:,:)
  12515. real(8), allocatable :: values_real8(:,:)
  12516. #endif
  12517. ! --- begin --------------------------------------
  12518. ! pointer to file structure:
  12519. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  12520. IF_NOT_OK_RETURN(status=1)
  12521. ! pointer to variable structure:
  12522. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  12523. IF_NOT_OK_RETURN(status=1)
  12524. ! check ...
  12525. if ( size(shape(values)) > varp%ndim ) then
  12526. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  12527. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  12528. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  12529. TRACEBACK; status=1; return
  12530. end if
  12531. ! check ...
  12532. if ( present(start ) ) then
  12533. if ( size(start ) /= varp%ndim ) then
  12534. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12535. write (gol,'(" size start : ",i6)') size(start ); call goErr
  12536. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12537. TRACEBACK; status=1; return
  12538. end if
  12539. end if
  12540. if ( present(count ) ) then
  12541. if ( size(count ) /= varp%ndim ) then
  12542. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12543. write (gol,'(" size count : ",i6)') size(count ); call goErr
  12544. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12545. TRACEBACK; status=1; return
  12546. end if
  12547. end if
  12548. if ( present(stride ) ) then
  12549. if ( size(stride ) /= varp%ndim ) then
  12550. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12551. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  12552. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12553. TRACEBACK; status=1; return
  12554. end if
  12555. end if
  12556. if ( present(map ) ) then
  12557. if ( size(map ) /= varp%ndim ) then
  12558. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12559. write (gol,'(" size map : ",i6)') size(map ); call goErr
  12560. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12561. TRACEBACK; status=1; return
  12562. end if
  12563. end if
  12564. ! loop over file types:
  12565. do iftype = 1, filep%nftype
  12566. ! current type:
  12567. ftype = filep%ftypes(iftype)
  12568. ! select appropriate routine for each type:
  12569. select case ( ftype )
  12570. #ifdef with_hdf4
  12571. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12572. case ( MDF_HDF4 )
  12573. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12574. ! check ...
  12575. if ( present(map ) ) then
  12576. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  12577. TRACEBACK; status=1; return
  12578. end if
  12579. ! fill offset (zero based!), stride, and count :
  12580. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  12581. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  12582. hdf4_count = 1 ! default singleton dimension
  12583. hdf4_count(1:2) = shape(values)
  12584. ! test source type:
  12585. select case ( varp%hdf4_xtype )
  12586. case ( DFNT_INT8 )
  12587. allocate( values_int1(size(values,1),size(values,2)) )
  12588. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  12589. values = int(values_int1,kind=4)
  12590. deallocate( values_int1 )
  12591. case ( DFNT_INT16 )
  12592. allocate( values_int2(size(values,1),size(values,2)) )
  12593. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  12594. values = int(values_int2,kind=4)
  12595. deallocate( values_int2 )
  12596. case ( DFNT_INT32 )
  12597. allocate( values_int4(size(values,1),size(values,2)) )
  12598. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  12599. values = int(values_int4,kind=4)
  12600. deallocate( values_int4 )
  12601. case ( DFNT_INT64 )
  12602. allocate( values_int8(size(values,1),size(values,2)) )
  12603. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  12604. values = int(values_int8,kind=4)
  12605. deallocate( values_int8 )
  12606. case ( DFNT_FLOAT32 )
  12607. allocate( values_real4(size(values,1),size(values,2)) )
  12608. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  12609. values = int(values_real4,kind=4)
  12610. deallocate( values_real4 )
  12611. case ( DFNT_FLOAT64 )
  12612. allocate( values_real8(size(values,1),size(values,2)) )
  12613. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  12614. values = int(values_real8,kind=4)
  12615. deallocate( values_real8 )
  12616. case default
  12617. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  12618. TRACEBACK; status=1; return
  12619. end select
  12620. if ( status == FAIL ) then
  12621. write (gol,'("reading hdf4 data set:")'); call goErr
  12622. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  12623. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  12624. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  12625. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  12626. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  12627. write (gol,'(" size : ",i6)') size(values); call goErr
  12628. TRACEBACK; status=1; return
  12629. end if
  12630. #endif
  12631. #ifdef with_netcdf
  12632. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12633. case ( MDF_NETCDF, MDF_NETCDF4 )
  12634. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12635. ! read values, converted automatically:
  12636. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  12637. start, count, stride, map )
  12638. IF_NF90_NOT_OK_RETURN(status=1)
  12639. #endif
  12640. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12641. case default
  12642. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12643. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  12644. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  12645. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  12646. TRACEBACK; status=1; return
  12647. end select
  12648. end do ! file types
  12649. ! ok
  12650. status = 0
  12651. end subroutine MDF_Get_Var_i4_2d
  12652. ! ***
  12653. subroutine MDF_Put_Var_i4_3d( hid, varid, values, status, &
  12654. start, count, stride, map )
  12655. #ifdef with_hdf5_beta
  12656. use HDF5, only : HID_T, HSIZE_T
  12657. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  12658. use HDF5, only : H5T_NATIVE_CHARACTER
  12659. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  12660. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  12661. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  12662. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  12663. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  12664. #endif
  12665. #ifdef with_netcdf
  12666. use NetCDF, only : NF90_Put_Var
  12667. #endif
  12668. ! --- in/out -------------------------------------
  12669. integer, intent(in) :: hid
  12670. integer, intent(in) :: varid
  12671. integer(4), intent(in) :: values(:,:,:)
  12672. integer, intent(out) :: status
  12673. integer, intent(in), optional :: start (:)
  12674. integer, intent(in), optional :: count (:)
  12675. integer, intent(in), optional :: stride(:)
  12676. integer, intent(in), optional :: map (:)
  12677. ! --- const --------------------------------------
  12678. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_3d'
  12679. ! --- external -----------------------------------
  12680. #ifdef with_hdf4
  12681. integer(hdf4_wpi), external :: sfWData
  12682. #endif
  12683. ! --- local --------------------------------------
  12684. type(MDF_File), pointer :: filep
  12685. type(MDF_Var), pointer :: varp
  12686. integer :: iftype
  12687. integer :: ftype
  12688. #ifdef with_hdf4
  12689. integer :: hdf4_offset(MAX_RANK)
  12690. integer :: hdf4_stride(MAX_RANK)
  12691. integer :: hdf4_count(MAX_RANK)
  12692. #endif
  12693. #ifdef with_hdf5_beta
  12694. !integer(HID_T) :: hdf5_type_id
  12695. integer(HID_T) :: hdf5_file_space_id
  12696. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  12697. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  12698. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  12699. #endif
  12700. integer(1), allocatable :: values_int1(:,:,:)
  12701. integer(2), allocatable :: values_int2(:,:,:)
  12702. integer(4), allocatable :: values_int4(:,:,:)
  12703. integer(8), allocatable :: values_int8(:,:,:)
  12704. real(4), allocatable :: values_real4(:,:,:)
  12705. real(8), allocatable :: values_real8(:,:,:)
  12706. ! --- begin --------------------------------------
  12707. ! pointer to file structure:
  12708. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  12709. IF_NOT_OK_RETURN(status=1)
  12710. ! pointer to variable structure:
  12711. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  12712. IF_NOT_OK_RETURN(status=1)
  12713. ! check ...
  12714. if ( size(shape(values)) > varp%ndim ) then
  12715. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  12716. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  12717. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  12718. TRACEBACK; status=1; return
  12719. end if
  12720. ! check ...
  12721. if ( present(start ) ) then
  12722. if ( size(start ) /= varp%ndim ) then
  12723. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12724. write (gol,'(" size start : ",i6)') size(start ); call goErr
  12725. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12726. TRACEBACK; status=1; return
  12727. end if
  12728. end if
  12729. if ( present(count ) ) then
  12730. if ( size(count ) /= varp%ndim ) then
  12731. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12732. write (gol,'(" size count : ",i6)') size(count ); call goErr
  12733. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12734. TRACEBACK; status=1; return
  12735. end if
  12736. end if
  12737. if ( present(stride ) ) then
  12738. if ( size(stride ) /= varp%ndim ) then
  12739. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12740. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  12741. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12742. TRACEBACK; status=1; return
  12743. end if
  12744. end if
  12745. if ( present(map ) ) then
  12746. if ( size(map ) /= varp%ndim ) then
  12747. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12748. write (gol,'(" size map : ",i6)') size(map ); call goErr
  12749. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12750. TRACEBACK; status=1; return
  12751. end if
  12752. end if
  12753. ! loop over file types:
  12754. do iftype = 1, filep%nftype
  12755. ! current type:
  12756. ftype = filep%ftypes(iftype)
  12757. ! select appropriate routine for each type:
  12758. select case ( ftype )
  12759. #ifdef with_hdf4
  12760. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12761. case ( MDF_HDF4 )
  12762. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12763. ! check ...
  12764. if ( present(map ) ) then
  12765. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  12766. TRACEBACK; status=1; return
  12767. end if
  12768. ! fill offset (zero based!) and stride with default values:
  12769. hdf4_offset = 0
  12770. hdf4_stride = 1
  12771. ! count is by default the shape; padd with singleton dimensions:
  12772. hdf4_count = 1; hdf4_count(1:3) = shape(values)
  12773. ! replace by optional arguments if necessary:
  12774. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  12775. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  12776. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  12777. ! test target type;
  12778. ! convert to required kind before entering sfWData,
  12779. ! otherwise segmentation faults on some machines ...
  12780. select case ( varp%xtype )
  12781. case ( MDF_BYTE )
  12782. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  12783. values_int1 = int(values,kind=1)
  12784. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12785. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  12786. deallocate( values_int1 )
  12787. case ( MDF_SHORT )
  12788. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  12789. values_int2 = int(values,kind=2)
  12790. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12791. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  12792. deallocate( values_int2 )
  12793. case ( MDF_INT )
  12794. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  12795. values_int4 = int(values,kind=4)
  12796. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12797. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  12798. deallocate( values_int4 )
  12799. case ( MDF_FLOAT )
  12800. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  12801. values_real4 = real(values,kind=4)
  12802. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12803. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  12804. deallocate( values_real4 )
  12805. case ( MDF_DOUBLE )
  12806. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  12807. values_real8 = real(values,kind=8)
  12808. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  12809. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  12810. deallocate( values_real8 )
  12811. case default
  12812. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  12813. TRACEBACK; status=1; return
  12814. end select
  12815. if ( status == FAIL ) then
  12816. write (gol,'("writing hdf4 data set:")'); call goErr
  12817. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  12818. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  12819. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  12820. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  12821. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  12822. write (gol,'(" size : ",i12)') size(values); call goErr
  12823. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  12824. TRACEBACK; status=1; return
  12825. end if
  12826. #endif
  12827. #ifdef with_hdf5_beta
  12828. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12829. case ( MDF_HDF5 )
  12830. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12831. ! check ...
  12832. if ( present(map ) ) then
  12833. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  12834. TRACEBACK; status=1; return
  12835. end if
  12836. ! fill offset (zero based!), stride, and count :
  12837. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  12838. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  12839. hdf5_count = 1 ! default singleton dimension
  12840. if ( present(count) ) then
  12841. hdf5_count(1:varp%ndim) = count
  12842. else
  12843. hdf5_count(1:3) = shape(values)
  12844. end if
  12845. ! new dimension:
  12846. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  12847. ! target data space in file:
  12848. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  12849. IF_NOT_OK_RETURN(status=1)
  12850. ! chunked dataset ?
  12851. if ( varp%hdf5_chunked ) then
  12852. ! reset extend:
  12853. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  12854. IF_NOT_OK_RETURN(status=1)
  12855. end if
  12856. ! select hyperslab:
  12857. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  12858. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  12859. stride=hdf5_stride(1:varp%ndim) )
  12860. ! write data:
  12861. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  12862. int(shape(values),kind=HSIZE_T), status, &
  12863. file_space_id=hdf5_file_space_id )
  12864. IF_NOT_OK_RETURN(status=1)
  12865. ! release data space:
  12866. call H5SClose_f( hdf5_file_space_id, status )
  12867. IF_NOT_OK_RETURN(status=1)
  12868. #endif
  12869. #ifdef with_netcdf
  12870. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12871. case ( MDF_NETCDF, MDF_NETCDF4 )
  12872. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12873. ! test target type:
  12874. ! convert to required kind before entering NF90_Put_Var,
  12875. ! otherwise segmentation faults on some machines ...
  12876. select case ( varp%xtype )
  12877. case ( MDF_BYTE )
  12878. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  12879. values_int1 = int(values,kind=1)
  12880. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  12881. start, count, stride, map )
  12882. IF_NF90_NOT_OK_RETURN(status=1)
  12883. deallocate( values_int1 )
  12884. case ( MDF_SHORT )
  12885. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  12886. values_int2 = int(values,kind=2)
  12887. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  12888. start, count, stride, map )
  12889. IF_NF90_NOT_OK_RETURN(status=1)
  12890. deallocate( values_int2 )
  12891. case ( MDF_INT )
  12892. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  12893. values_int4 = int(values,kind=4)
  12894. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  12895. start, count, stride, map )
  12896. IF_NF90_NOT_OK_RETURN(status=1)
  12897. deallocate( values_int4 )
  12898. case ( MDF_FLOAT )
  12899. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  12900. values_real4 = real(values,kind=4)
  12901. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  12902. start, count, stride, map )
  12903. IF_NF90_NOT_OK_RETURN(status=1)
  12904. deallocate( values_real4 )
  12905. case ( MDF_DOUBLE )
  12906. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  12907. values_real8 = real(values,kind=8)
  12908. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  12909. start, count, stride, map )
  12910. IF_NF90_NOT_OK_RETURN(status=1)
  12911. deallocate( values_real8 )
  12912. case default
  12913. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  12914. TRACEBACK; status=1; return
  12915. end select
  12916. ! just put; let netcdf library convert the right kind:
  12917. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  12918. ! start, count, stride, map )
  12919. !IF_NF90_NOT_OK_RETURN(status=1)
  12920. #endif
  12921. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12922. case default
  12923. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  12924. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  12925. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  12926. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  12927. TRACEBACK; status=1; return
  12928. end select
  12929. end do ! file types
  12930. ! ok
  12931. status = 0
  12932. end subroutine MDF_Put_Var_i4_3d
  12933. ! ***
  12934. subroutine MDF_Get_Var_i4_3d( hid, varid, values, status, &
  12935. start, count, stride, map )
  12936. #ifdef with_netcdf
  12937. use NetCDF, only : NF90_Get_Var
  12938. #endif
  12939. ! --- in/out -------------------------------------
  12940. integer, intent(in) :: hid
  12941. integer, intent(in) :: varid
  12942. integer(4), intent(out) :: values(:,:,:)
  12943. integer, intent(out) :: status
  12944. integer, intent(in), optional :: start (:)
  12945. integer, intent(in), optional :: count (:)
  12946. integer, intent(in), optional :: stride(:)
  12947. integer, intent(in), optional :: map (:)
  12948. ! --- const --------------------------------------
  12949. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_3d'
  12950. ! --- external -----------------------------------
  12951. #ifdef with_hdf4
  12952. integer(hdf4_wpi), external :: sfRData
  12953. #endif
  12954. ! --- local --------------------------------------
  12955. type(MDF_File), pointer :: filep
  12956. type(MDF_Var), pointer :: varp
  12957. integer :: iftype
  12958. integer :: ftype
  12959. #ifdef with_hdf4
  12960. integer :: hdf4_offset(MAX_RANK)
  12961. integer :: hdf4_stride(MAX_RANK)
  12962. integer :: hdf4_count(MAX_RANK)
  12963. integer(1), allocatable :: values_int1(:,:,:)
  12964. integer(2), allocatable :: values_int2(:,:,:)
  12965. integer(4), allocatable :: values_int4(:,:,:)
  12966. integer(8), allocatable :: values_int8(:,:,:)
  12967. real(4), allocatable :: values_real4(:,:,:)
  12968. real(8), allocatable :: values_real8(:,:,:)
  12969. #endif
  12970. ! --- begin --------------------------------------
  12971. ! pointer to file structure:
  12972. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  12973. IF_NOT_OK_RETURN(status=1)
  12974. ! pointer to variable structure:
  12975. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  12976. IF_NOT_OK_RETURN(status=1)
  12977. ! check ...
  12978. if ( size(shape(values)) > varp%ndim ) then
  12979. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  12980. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  12981. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  12982. TRACEBACK; status=1; return
  12983. end if
  12984. ! check ...
  12985. if ( present(start ) ) then
  12986. if ( size(start ) /= varp%ndim ) then
  12987. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12988. write (gol,'(" size start : ",i6)') size(start ); call goErr
  12989. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12990. TRACEBACK; status=1; return
  12991. end if
  12992. end if
  12993. if ( present(count ) ) then
  12994. if ( size(count ) /= varp%ndim ) then
  12995. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  12996. write (gol,'(" size count : ",i6)') size(count ); call goErr
  12997. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  12998. TRACEBACK; status=1; return
  12999. end if
  13000. end if
  13001. if ( present(stride ) ) then
  13002. if ( size(stride ) /= varp%ndim ) then
  13003. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13004. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  13005. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13006. TRACEBACK; status=1; return
  13007. end if
  13008. end if
  13009. if ( present(map ) ) then
  13010. if ( size(map ) /= varp%ndim ) then
  13011. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13012. write (gol,'(" size map : ",i6)') size(map ); call goErr
  13013. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13014. TRACEBACK; status=1; return
  13015. end if
  13016. end if
  13017. ! loop over file types:
  13018. do iftype = 1, filep%nftype
  13019. ! current type:
  13020. ftype = filep%ftypes(iftype)
  13021. ! select appropriate routine for each type:
  13022. select case ( ftype )
  13023. #ifdef with_hdf4
  13024. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13025. case ( MDF_HDF4 )
  13026. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13027. ! check ...
  13028. if ( present(map ) ) then
  13029. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  13030. TRACEBACK; status=1; return
  13031. end if
  13032. ! fill offset (zero based!), stride, and count :
  13033. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  13034. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  13035. hdf4_count = 1 ! default singleton dimension
  13036. hdf4_count(1:3) = shape(values)
  13037. ! test source type:
  13038. select case ( varp%hdf4_xtype )
  13039. case ( DFNT_INT8 )
  13040. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  13041. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  13042. values = int(values_int1,kind=4)
  13043. deallocate( values_int1 )
  13044. case ( DFNT_INT16 )
  13045. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  13046. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  13047. values = int(values_int2,kind=4)
  13048. deallocate( values_int2 )
  13049. case ( DFNT_INT32 )
  13050. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  13051. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  13052. values = int(values_int4,kind=4)
  13053. deallocate( values_int4 )
  13054. case ( DFNT_INT64 )
  13055. allocate( values_int8(size(values,1),size(values,2),size(values,3)) )
  13056. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  13057. values = int(values_int8,kind=4)
  13058. deallocate( values_int8 )
  13059. case ( DFNT_FLOAT32 )
  13060. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  13061. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  13062. values = int(values_real4,kind=4)
  13063. deallocate( values_real4 )
  13064. case ( DFNT_FLOAT64 )
  13065. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  13066. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  13067. values = int(values_real8,kind=4)
  13068. deallocate( values_real8 )
  13069. case default
  13070. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  13071. TRACEBACK; status=1; return
  13072. end select
  13073. if ( status == FAIL ) then
  13074. write (gol,'("reading hdf4 data set:")'); call goErr
  13075. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  13076. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  13077. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  13078. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  13079. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  13080. write (gol,'(" size : ",i6)') size(values); call goErr
  13081. TRACEBACK; status=1; return
  13082. end if
  13083. #endif
  13084. #ifdef with_netcdf
  13085. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13086. case ( MDF_NETCDF, MDF_NETCDF4 )
  13087. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13088. ! read values, converted automatically:
  13089. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  13090. start, count, stride, map )
  13091. IF_NF90_NOT_OK_RETURN(status=1)
  13092. #endif
  13093. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13094. case default
  13095. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13096. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  13097. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  13098. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  13099. TRACEBACK; status=1; return
  13100. end select
  13101. end do ! file types
  13102. ! ok
  13103. status = 0
  13104. end subroutine MDF_Get_Var_i4_3d
  13105. ! ***
  13106. subroutine MDF_Put_Var_i4_4d( hid, varid, values, status, &
  13107. start, count, stride, map )
  13108. #ifdef with_hdf5_beta
  13109. use HDF5, only : HID_T, HSIZE_T
  13110. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  13111. use HDF5, only : H5T_NATIVE_CHARACTER
  13112. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  13113. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  13114. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  13115. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  13116. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  13117. #endif
  13118. #ifdef with_netcdf
  13119. use NetCDF, only : NF90_Put_Var
  13120. #endif
  13121. ! --- in/out -------------------------------------
  13122. integer, intent(in) :: hid
  13123. integer, intent(in) :: varid
  13124. integer(4), intent(in) :: values(:,:,:,:)
  13125. integer, intent(out) :: status
  13126. integer, intent(in), optional :: start (:)
  13127. integer, intent(in), optional :: count (:)
  13128. integer, intent(in), optional :: stride(:)
  13129. integer, intent(in), optional :: map (:)
  13130. ! --- const --------------------------------------
  13131. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_4d'
  13132. ! --- external -----------------------------------
  13133. #ifdef with_hdf4
  13134. integer(hdf4_wpi), external :: sfWData
  13135. #endif
  13136. ! --- local --------------------------------------
  13137. type(MDF_File), pointer :: filep
  13138. type(MDF_Var), pointer :: varp
  13139. integer :: iftype
  13140. integer :: ftype
  13141. #ifdef with_hdf4
  13142. integer :: hdf4_offset(MAX_RANK)
  13143. integer :: hdf4_stride(MAX_RANK)
  13144. integer :: hdf4_count(MAX_RANK)
  13145. #endif
  13146. #ifdef with_hdf5_beta
  13147. !integer(HID_T) :: hdf5_type_id
  13148. integer(HID_T) :: hdf5_file_space_id
  13149. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  13150. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  13151. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  13152. #endif
  13153. integer(1), allocatable :: values_int1(:,:,:,:)
  13154. integer(2), allocatable :: values_int2(:,:,:,:)
  13155. integer(4), allocatable :: values_int4(:,:,:,:)
  13156. integer(8), allocatable :: values_int8(:,:,:,:)
  13157. real(4), allocatable :: values_real4(:,:,:,:)
  13158. real(8), allocatable :: values_real8(:,:,:,:)
  13159. ! --- begin --------------------------------------
  13160. ! pointer to file structure:
  13161. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  13162. IF_NOT_OK_RETURN(status=1)
  13163. ! pointer to variable structure:
  13164. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  13165. IF_NOT_OK_RETURN(status=1)
  13166. ! check ...
  13167. if ( size(shape(values)) > varp%ndim ) then
  13168. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  13169. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  13170. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  13171. TRACEBACK; status=1; return
  13172. end if
  13173. ! check ...
  13174. if ( present(start ) ) then
  13175. if ( size(start ) /= varp%ndim ) then
  13176. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13177. write (gol,'(" size start : ",i6)') size(start ); call goErr
  13178. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13179. TRACEBACK; status=1; return
  13180. end if
  13181. end if
  13182. if ( present(count ) ) then
  13183. if ( size(count ) /= varp%ndim ) then
  13184. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13185. write (gol,'(" size count : ",i6)') size(count ); call goErr
  13186. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13187. TRACEBACK; status=1; return
  13188. end if
  13189. end if
  13190. if ( present(stride ) ) then
  13191. if ( size(stride ) /= varp%ndim ) then
  13192. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13193. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  13194. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13195. TRACEBACK; status=1; return
  13196. end if
  13197. end if
  13198. if ( present(map ) ) then
  13199. if ( size(map ) /= varp%ndim ) then
  13200. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13201. write (gol,'(" size map : ",i6)') size(map ); call goErr
  13202. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13203. TRACEBACK; status=1; return
  13204. end if
  13205. end if
  13206. ! loop over file types:
  13207. do iftype = 1, filep%nftype
  13208. ! current type:
  13209. ftype = filep%ftypes(iftype)
  13210. ! select appropriate routine for each type:
  13211. select case ( ftype )
  13212. #ifdef with_hdf4
  13213. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13214. case ( MDF_HDF4 )
  13215. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13216. ! check ...
  13217. if ( present(map ) ) then
  13218. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  13219. TRACEBACK; status=1; return
  13220. end if
  13221. ! fill offset (zero based!) and stride with default values:
  13222. hdf4_offset = 0
  13223. hdf4_stride = 1
  13224. ! count is by default the shape; padd with singleton dimensions:
  13225. hdf4_count = 1; hdf4_count(1:4) = shape(values)
  13226. ! replace by optional arguments if necessary:
  13227. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  13228. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  13229. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  13230. ! test target type;
  13231. ! convert to required kind before entering sfWData,
  13232. ! otherwise segmentation faults on some machines ...
  13233. select case ( varp%xtype )
  13234. case ( MDF_BYTE )
  13235. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13236. values_int1 = int(values,kind=1)
  13237. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13238. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  13239. deallocate( values_int1 )
  13240. case ( MDF_SHORT )
  13241. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13242. values_int2 = int(values,kind=2)
  13243. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13244. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  13245. deallocate( values_int2 )
  13246. case ( MDF_INT )
  13247. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13248. values_int4 = int(values,kind=4)
  13249. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13250. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  13251. deallocate( values_int4 )
  13252. case ( MDF_FLOAT )
  13253. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13254. values_real4 = real(values,kind=4)
  13255. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13256. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  13257. deallocate( values_real4 )
  13258. case ( MDF_DOUBLE )
  13259. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13260. values_real8 = real(values,kind=8)
  13261. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13262. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  13263. deallocate( values_real8 )
  13264. case default
  13265. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  13266. TRACEBACK; status=1; return
  13267. end select
  13268. if ( status == FAIL ) then
  13269. write (gol,'("writing hdf4 data set:")'); call goErr
  13270. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  13271. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  13272. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  13273. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  13274. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  13275. write (gol,'(" size : ",i12)') size(values); call goErr
  13276. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  13277. TRACEBACK; status=1; return
  13278. end if
  13279. #endif
  13280. #ifdef with_hdf5_beta
  13281. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13282. case ( MDF_HDF5 )
  13283. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13284. ! check ...
  13285. if ( present(map ) ) then
  13286. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  13287. TRACEBACK; status=1; return
  13288. end if
  13289. ! fill offset (zero based!), stride, and count :
  13290. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  13291. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  13292. hdf5_count = 1 ! default singleton dimension
  13293. if ( present(count) ) then
  13294. hdf5_count(1:varp%ndim) = count
  13295. else
  13296. hdf5_count(1:4) = shape(values)
  13297. end if
  13298. ! new dimension:
  13299. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  13300. ! target data space in file:
  13301. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  13302. IF_NOT_OK_RETURN(status=1)
  13303. ! chunked dataset ?
  13304. if ( varp%hdf5_chunked ) then
  13305. ! reset extend:
  13306. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  13307. IF_NOT_OK_RETURN(status=1)
  13308. end if
  13309. ! select hyperslab:
  13310. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  13311. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  13312. stride=hdf5_stride(1:varp%ndim) )
  13313. ! write data:
  13314. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  13315. int(shape(values),kind=HSIZE_T), status, &
  13316. file_space_id=hdf5_file_space_id )
  13317. IF_NOT_OK_RETURN(status=1)
  13318. ! release data space:
  13319. call H5SClose_f( hdf5_file_space_id, status )
  13320. IF_NOT_OK_RETURN(status=1)
  13321. #endif
  13322. #ifdef with_netcdf
  13323. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13324. case ( MDF_NETCDF, MDF_NETCDF4 )
  13325. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13326. ! test target type:
  13327. ! convert to required kind before entering NF90_Put_Var,
  13328. ! otherwise segmentation faults on some machines ...
  13329. select case ( varp%xtype )
  13330. case ( MDF_BYTE )
  13331. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13332. values_int1 = int(values,kind=1)
  13333. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  13334. start, count, stride, map )
  13335. IF_NF90_NOT_OK_RETURN(status=1)
  13336. deallocate( values_int1 )
  13337. case ( MDF_SHORT )
  13338. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13339. values_int2 = int(values,kind=2)
  13340. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  13341. start, count, stride, map )
  13342. IF_NF90_NOT_OK_RETURN(status=1)
  13343. deallocate( values_int2 )
  13344. case ( MDF_INT )
  13345. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13346. values_int4 = int(values,kind=4)
  13347. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  13348. start, count, stride, map )
  13349. IF_NF90_NOT_OK_RETURN(status=1)
  13350. deallocate( values_int4 )
  13351. case ( MDF_FLOAT )
  13352. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13353. values_real4 = real(values,kind=4)
  13354. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  13355. start, count, stride, map )
  13356. IF_NF90_NOT_OK_RETURN(status=1)
  13357. deallocate( values_real4 )
  13358. case ( MDF_DOUBLE )
  13359. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13360. values_real8 = real(values,kind=8)
  13361. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  13362. start, count, stride, map )
  13363. IF_NF90_NOT_OK_RETURN(status=1)
  13364. deallocate( values_real8 )
  13365. case default
  13366. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  13367. TRACEBACK; status=1; return
  13368. end select
  13369. ! just put; let netcdf library convert the right kind:
  13370. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  13371. ! start, count, stride, map )
  13372. !IF_NF90_NOT_OK_RETURN(status=1)
  13373. #endif
  13374. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13375. case default
  13376. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13377. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  13378. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  13379. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  13380. TRACEBACK; status=1; return
  13381. end select
  13382. end do ! file types
  13383. ! ok
  13384. status = 0
  13385. end subroutine MDF_Put_Var_i4_4d
  13386. ! ***
  13387. subroutine MDF_Get_Var_i4_4d( hid, varid, values, status, &
  13388. start, count, stride, map )
  13389. #ifdef with_netcdf
  13390. use NetCDF, only : NF90_Get_Var
  13391. #endif
  13392. ! --- in/out -------------------------------------
  13393. integer, intent(in) :: hid
  13394. integer, intent(in) :: varid
  13395. integer(4), intent(out) :: values(:,:,:,:)
  13396. integer, intent(out) :: status
  13397. integer, intent(in), optional :: start (:)
  13398. integer, intent(in), optional :: count (:)
  13399. integer, intent(in), optional :: stride(:)
  13400. integer, intent(in), optional :: map (:)
  13401. ! --- const --------------------------------------
  13402. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_4d'
  13403. ! --- external -----------------------------------
  13404. #ifdef with_hdf4
  13405. integer(hdf4_wpi), external :: sfRData
  13406. #endif
  13407. ! --- local --------------------------------------
  13408. type(MDF_File), pointer :: filep
  13409. type(MDF_Var), pointer :: varp
  13410. integer :: iftype
  13411. integer :: ftype
  13412. #ifdef with_hdf4
  13413. integer :: hdf4_offset(MAX_RANK)
  13414. integer :: hdf4_stride(MAX_RANK)
  13415. integer :: hdf4_count(MAX_RANK)
  13416. integer(1), allocatable :: values_int1(:,:,:,:)
  13417. integer(2), allocatable :: values_int2(:,:,:,:)
  13418. integer(4), allocatable :: values_int4(:,:,:,:)
  13419. integer(8), allocatable :: values_int8(:,:,:,:)
  13420. real(4), allocatable :: values_real4(:,:,:,:)
  13421. real(8), allocatable :: values_real8(:,:,:,:)
  13422. #endif
  13423. ! --- begin --------------------------------------
  13424. ! pointer to file structure:
  13425. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  13426. IF_NOT_OK_RETURN(status=1)
  13427. ! pointer to variable structure:
  13428. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  13429. IF_NOT_OK_RETURN(status=1)
  13430. ! check ...
  13431. if ( size(shape(values)) > varp%ndim ) then
  13432. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  13433. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  13434. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  13435. TRACEBACK; status=1; return
  13436. end if
  13437. ! check ...
  13438. if ( present(start ) ) then
  13439. if ( size(start ) /= varp%ndim ) then
  13440. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13441. write (gol,'(" size start : ",i6)') size(start ); call goErr
  13442. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13443. TRACEBACK; status=1; return
  13444. end if
  13445. end if
  13446. if ( present(count ) ) then
  13447. if ( size(count ) /= varp%ndim ) then
  13448. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13449. write (gol,'(" size count : ",i6)') size(count ); call goErr
  13450. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13451. TRACEBACK; status=1; return
  13452. end if
  13453. end if
  13454. if ( present(stride ) ) then
  13455. if ( size(stride ) /= varp%ndim ) then
  13456. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13457. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  13458. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13459. TRACEBACK; status=1; return
  13460. end if
  13461. end if
  13462. if ( present(map ) ) then
  13463. if ( size(map ) /= varp%ndim ) then
  13464. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13465. write (gol,'(" size map : ",i6)') size(map ); call goErr
  13466. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13467. TRACEBACK; status=1; return
  13468. end if
  13469. end if
  13470. ! loop over file types:
  13471. do iftype = 1, filep%nftype
  13472. ! current type:
  13473. ftype = filep%ftypes(iftype)
  13474. ! select appropriate routine for each type:
  13475. select case ( ftype )
  13476. #ifdef with_hdf4
  13477. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13478. case ( MDF_HDF4 )
  13479. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13480. ! check ...
  13481. if ( present(map ) ) then
  13482. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  13483. TRACEBACK; status=1; return
  13484. end if
  13485. ! fill offset (zero based!), stride, and count :
  13486. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  13487. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  13488. hdf4_count = 1 ! default singleton dimension
  13489. hdf4_count(1:4) = shape(values)
  13490. ! test source type:
  13491. select case ( varp%hdf4_xtype )
  13492. case ( DFNT_INT8 )
  13493. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13494. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  13495. values = int(values_int1,kind=4)
  13496. deallocate( values_int1 )
  13497. case ( DFNT_INT16 )
  13498. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13499. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  13500. values = int(values_int2,kind=4)
  13501. deallocate( values_int2 )
  13502. case ( DFNT_INT32 )
  13503. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13504. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  13505. values = int(values_int4,kind=4)
  13506. deallocate( values_int4 )
  13507. case ( DFNT_INT64 )
  13508. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13509. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  13510. values = int(values_int8,kind=4)
  13511. deallocate( values_int8 )
  13512. case ( DFNT_FLOAT32 )
  13513. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13514. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  13515. values = int(values_real4,kind=4)
  13516. deallocate( values_real4 )
  13517. case ( DFNT_FLOAT64 )
  13518. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  13519. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  13520. values = int(values_real8,kind=4)
  13521. deallocate( values_real8 )
  13522. case default
  13523. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  13524. TRACEBACK; status=1; return
  13525. end select
  13526. if ( status == FAIL ) then
  13527. write (gol,'("reading hdf4 data set:")'); call goErr
  13528. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  13529. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  13530. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  13531. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  13532. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  13533. write (gol,'(" size : ",i6)') size(values); call goErr
  13534. TRACEBACK; status=1; return
  13535. end if
  13536. #endif
  13537. #ifdef with_netcdf
  13538. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13539. case ( MDF_NETCDF, MDF_NETCDF4 )
  13540. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13541. ! read values, converted automatically:
  13542. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  13543. start, count, stride, map )
  13544. IF_NF90_NOT_OK_RETURN(status=1)
  13545. #endif
  13546. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13547. case default
  13548. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13549. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  13550. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  13551. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  13552. TRACEBACK; status=1; return
  13553. end select
  13554. end do ! file types
  13555. ! ok
  13556. status = 0
  13557. end subroutine MDF_Get_Var_i4_4d
  13558. ! ***
  13559. subroutine MDF_Put_Var_i4_5d( hid, varid, values, status, &
  13560. start, count, stride, map )
  13561. #ifdef with_hdf5_beta
  13562. use HDF5, only : HID_T, HSIZE_T
  13563. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  13564. use HDF5, only : H5T_NATIVE_CHARACTER
  13565. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  13566. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  13567. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  13568. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  13569. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  13570. #endif
  13571. #ifdef with_netcdf
  13572. use NetCDF, only : NF90_Put_Var
  13573. #endif
  13574. ! --- in/out -------------------------------------
  13575. integer, intent(in) :: hid
  13576. integer, intent(in) :: varid
  13577. integer(4), intent(in) :: values(:,:,:,:,:)
  13578. integer, intent(out) :: status
  13579. integer, intent(in), optional :: start (:)
  13580. integer, intent(in), optional :: count (:)
  13581. integer, intent(in), optional :: stride(:)
  13582. integer, intent(in), optional :: map (:)
  13583. ! --- const --------------------------------------
  13584. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_5d'
  13585. ! --- external -----------------------------------
  13586. #ifdef with_hdf4
  13587. integer(hdf4_wpi), external :: sfWData
  13588. #endif
  13589. ! --- local --------------------------------------
  13590. type(MDF_File), pointer :: filep
  13591. type(MDF_Var), pointer :: varp
  13592. integer :: iftype
  13593. integer :: ftype
  13594. #ifdef with_hdf4
  13595. integer :: hdf4_offset(MAX_RANK)
  13596. integer :: hdf4_stride(MAX_RANK)
  13597. integer :: hdf4_count(MAX_RANK)
  13598. #endif
  13599. #ifdef with_hdf5_beta
  13600. !integer(HID_T) :: hdf5_type_id
  13601. integer(HID_T) :: hdf5_file_space_id
  13602. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  13603. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  13604. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  13605. #endif
  13606. integer(1), allocatable :: values_int1(:,:,:,:,:)
  13607. integer(2), allocatable :: values_int2(:,:,:,:,:)
  13608. integer(4), allocatable :: values_int4(:,:,:,:,:)
  13609. integer(8), allocatable :: values_int8(:,:,:,:,:)
  13610. real(4), allocatable :: values_real4(:,:,:,:,:)
  13611. real(8), allocatable :: values_real8(:,:,:,:,:)
  13612. ! --- begin --------------------------------------
  13613. ! pointer to file structure:
  13614. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  13615. IF_NOT_OK_RETURN(status=1)
  13616. ! pointer to variable structure:
  13617. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  13618. IF_NOT_OK_RETURN(status=1)
  13619. ! check ...
  13620. if ( size(shape(values)) > varp%ndim ) then
  13621. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  13622. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  13623. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  13624. TRACEBACK; status=1; return
  13625. end if
  13626. ! check ...
  13627. if ( present(start ) ) then
  13628. if ( size(start ) /= varp%ndim ) then
  13629. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13630. write (gol,'(" size start : ",i6)') size(start ); call goErr
  13631. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13632. TRACEBACK; status=1; return
  13633. end if
  13634. end if
  13635. if ( present(count ) ) then
  13636. if ( size(count ) /= varp%ndim ) then
  13637. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13638. write (gol,'(" size count : ",i6)') size(count ); call goErr
  13639. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13640. TRACEBACK; status=1; return
  13641. end if
  13642. end if
  13643. if ( present(stride ) ) then
  13644. if ( size(stride ) /= varp%ndim ) then
  13645. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13646. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  13647. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13648. TRACEBACK; status=1; return
  13649. end if
  13650. end if
  13651. if ( present(map ) ) then
  13652. if ( size(map ) /= varp%ndim ) then
  13653. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13654. write (gol,'(" size map : ",i6)') size(map ); call goErr
  13655. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13656. TRACEBACK; status=1; return
  13657. end if
  13658. end if
  13659. ! loop over file types:
  13660. do iftype = 1, filep%nftype
  13661. ! current type:
  13662. ftype = filep%ftypes(iftype)
  13663. ! select appropriate routine for each type:
  13664. select case ( ftype )
  13665. #ifdef with_hdf4
  13666. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13667. case ( MDF_HDF4 )
  13668. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13669. ! check ...
  13670. if ( present(map ) ) then
  13671. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  13672. TRACEBACK; status=1; return
  13673. end if
  13674. ! fill offset (zero based!) and stride with default values:
  13675. hdf4_offset = 0
  13676. hdf4_stride = 1
  13677. ! count is by default the shape; padd with singleton dimensions:
  13678. hdf4_count = 1; hdf4_count(1:5) = shape(values)
  13679. ! replace by optional arguments if necessary:
  13680. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  13681. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  13682. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  13683. ! test target type;
  13684. ! convert to required kind before entering sfWData,
  13685. ! otherwise segmentation faults on some machines ...
  13686. select case ( varp%xtype )
  13687. case ( MDF_BYTE )
  13688. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13689. values_int1 = int(values,kind=1)
  13690. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13691. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  13692. deallocate( values_int1 )
  13693. case ( MDF_SHORT )
  13694. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13695. values_int2 = int(values,kind=2)
  13696. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13697. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  13698. deallocate( values_int2 )
  13699. case ( MDF_INT )
  13700. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13701. values_int4 = int(values,kind=4)
  13702. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13703. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  13704. deallocate( values_int4 )
  13705. case ( MDF_FLOAT )
  13706. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13707. values_real4 = real(values,kind=4)
  13708. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13709. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  13710. deallocate( values_real4 )
  13711. case ( MDF_DOUBLE )
  13712. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13713. values_real8 = real(values,kind=8)
  13714. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  13715. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  13716. deallocate( values_real8 )
  13717. case default
  13718. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  13719. TRACEBACK; status=1; return
  13720. end select
  13721. if ( status == FAIL ) then
  13722. write (gol,'("writing hdf4 data set:")'); call goErr
  13723. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  13724. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  13725. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  13726. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  13727. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  13728. write (gol,'(" size : ",i12)') size(values); call goErr
  13729. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  13730. TRACEBACK; status=1; return
  13731. end if
  13732. #endif
  13733. #ifdef with_hdf5_beta
  13734. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13735. case ( MDF_HDF5 )
  13736. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13737. ! check ...
  13738. if ( present(map ) ) then
  13739. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  13740. TRACEBACK; status=1; return
  13741. end if
  13742. ! fill offset (zero based!), stride, and count :
  13743. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  13744. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  13745. hdf5_count = 1 ! default singleton dimension
  13746. if ( present(count) ) then
  13747. hdf5_count(1:varp%ndim) = count
  13748. else
  13749. hdf5_count(1:5) = shape(values)
  13750. end if
  13751. ! new dimension:
  13752. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  13753. ! target data space in file:
  13754. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  13755. IF_NOT_OK_RETURN(status=1)
  13756. ! chunked dataset ?
  13757. if ( varp%hdf5_chunked ) then
  13758. ! reset extend:
  13759. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  13760. IF_NOT_OK_RETURN(status=1)
  13761. end if
  13762. ! select hyperslab:
  13763. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  13764. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  13765. stride=hdf5_stride(1:varp%ndim) )
  13766. ! write data:
  13767. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  13768. int(shape(values),kind=HSIZE_T), status, &
  13769. file_space_id=hdf5_file_space_id )
  13770. IF_NOT_OK_RETURN(status=1)
  13771. ! release data space:
  13772. call H5SClose_f( hdf5_file_space_id, status )
  13773. IF_NOT_OK_RETURN(status=1)
  13774. #endif
  13775. #ifdef with_netcdf
  13776. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13777. case ( MDF_NETCDF, MDF_NETCDF4 )
  13778. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13779. ! test target type:
  13780. ! convert to required kind before entering NF90_Put_Var,
  13781. ! otherwise segmentation faults on some machines ...
  13782. select case ( varp%xtype )
  13783. case ( MDF_BYTE )
  13784. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13785. values_int1 = int(values,kind=1)
  13786. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  13787. start, count, stride, map )
  13788. IF_NF90_NOT_OK_RETURN(status=1)
  13789. deallocate( values_int1 )
  13790. case ( MDF_SHORT )
  13791. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13792. values_int2 = int(values,kind=2)
  13793. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  13794. start, count, stride, map )
  13795. IF_NF90_NOT_OK_RETURN(status=1)
  13796. deallocate( values_int2 )
  13797. case ( MDF_INT )
  13798. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13799. values_int4 = int(values,kind=4)
  13800. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  13801. start, count, stride, map )
  13802. IF_NF90_NOT_OK_RETURN(status=1)
  13803. deallocate( values_int4 )
  13804. case ( MDF_FLOAT )
  13805. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13806. values_real4 = real(values,kind=4)
  13807. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  13808. start, count, stride, map )
  13809. IF_NF90_NOT_OK_RETURN(status=1)
  13810. deallocate( values_real4 )
  13811. case ( MDF_DOUBLE )
  13812. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13813. values_real8 = real(values,kind=8)
  13814. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  13815. start, count, stride, map )
  13816. IF_NF90_NOT_OK_RETURN(status=1)
  13817. deallocate( values_real8 )
  13818. case default
  13819. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  13820. TRACEBACK; status=1; return
  13821. end select
  13822. ! just put; let netcdf library convert the right kind:
  13823. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  13824. ! start, count, stride, map )
  13825. !IF_NF90_NOT_OK_RETURN(status=1)
  13826. #endif
  13827. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13828. case default
  13829. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13830. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  13831. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  13832. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  13833. TRACEBACK; status=1; return
  13834. end select
  13835. end do ! file types
  13836. ! ok
  13837. status = 0
  13838. end subroutine MDF_Put_Var_i4_5d
  13839. ! ***
  13840. subroutine MDF_Get_Var_i4_5d( hid, varid, values, status, &
  13841. start, count, stride, map )
  13842. #ifdef with_netcdf
  13843. use NetCDF, only : NF90_Get_Var
  13844. #endif
  13845. ! --- in/out -------------------------------------
  13846. integer, intent(in) :: hid
  13847. integer, intent(in) :: varid
  13848. integer(4), intent(out) :: values(:,:,:,:,:)
  13849. integer, intent(out) :: status
  13850. integer, intent(in), optional :: start (:)
  13851. integer, intent(in), optional :: count (:)
  13852. integer, intent(in), optional :: stride(:)
  13853. integer, intent(in), optional :: map (:)
  13854. ! --- const --------------------------------------
  13855. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_5d'
  13856. ! --- external -----------------------------------
  13857. #ifdef with_hdf4
  13858. integer(hdf4_wpi), external :: sfRData
  13859. #endif
  13860. ! --- local --------------------------------------
  13861. type(MDF_File), pointer :: filep
  13862. type(MDF_Var), pointer :: varp
  13863. integer :: iftype
  13864. integer :: ftype
  13865. #ifdef with_hdf4
  13866. integer :: hdf4_offset(MAX_RANK)
  13867. integer :: hdf4_stride(MAX_RANK)
  13868. integer :: hdf4_count(MAX_RANK)
  13869. integer(1), allocatable :: values_int1(:,:,:,:,:)
  13870. integer(2), allocatable :: values_int2(:,:,:,:,:)
  13871. integer(4), allocatable :: values_int4(:,:,:,:,:)
  13872. integer(8), allocatable :: values_int8(:,:,:,:,:)
  13873. real(4), allocatable :: values_real4(:,:,:,:,:)
  13874. real(8), allocatable :: values_real8(:,:,:,:,:)
  13875. #endif
  13876. ! --- begin --------------------------------------
  13877. ! pointer to file structure:
  13878. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  13879. IF_NOT_OK_RETURN(status=1)
  13880. ! pointer to variable structure:
  13881. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  13882. IF_NOT_OK_RETURN(status=1)
  13883. ! check ...
  13884. if ( size(shape(values)) > varp%ndim ) then
  13885. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  13886. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  13887. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  13888. TRACEBACK; status=1; return
  13889. end if
  13890. ! check ...
  13891. if ( present(start ) ) then
  13892. if ( size(start ) /= varp%ndim ) then
  13893. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13894. write (gol,'(" size start : ",i6)') size(start ); call goErr
  13895. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13896. TRACEBACK; status=1; return
  13897. end if
  13898. end if
  13899. if ( present(count ) ) then
  13900. if ( size(count ) /= varp%ndim ) then
  13901. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13902. write (gol,'(" size count : ",i6)') size(count ); call goErr
  13903. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13904. TRACEBACK; status=1; return
  13905. end if
  13906. end if
  13907. if ( present(stride ) ) then
  13908. if ( size(stride ) /= varp%ndim ) then
  13909. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13910. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  13911. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13912. TRACEBACK; status=1; return
  13913. end if
  13914. end if
  13915. if ( present(map ) ) then
  13916. if ( size(map ) /= varp%ndim ) then
  13917. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  13918. write (gol,'(" size map : ",i6)') size(map ); call goErr
  13919. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  13920. TRACEBACK; status=1; return
  13921. end if
  13922. end if
  13923. ! loop over file types:
  13924. do iftype = 1, filep%nftype
  13925. ! current type:
  13926. ftype = filep%ftypes(iftype)
  13927. ! select appropriate routine for each type:
  13928. select case ( ftype )
  13929. #ifdef with_hdf4
  13930. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13931. case ( MDF_HDF4 )
  13932. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13933. ! check ...
  13934. if ( present(map ) ) then
  13935. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  13936. TRACEBACK; status=1; return
  13937. end if
  13938. ! fill offset (zero based!), stride, and count :
  13939. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  13940. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  13941. hdf4_count = 1 ! default singleton dimension
  13942. hdf4_count(1:5) = shape(values)
  13943. ! test source type:
  13944. select case ( varp%hdf4_xtype )
  13945. case ( DFNT_INT8 )
  13946. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13947. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  13948. values = int(values_int1,kind=4)
  13949. deallocate( values_int1 )
  13950. case ( DFNT_INT16 )
  13951. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13952. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  13953. values = int(values_int2,kind=4)
  13954. deallocate( values_int2 )
  13955. case ( DFNT_INT32 )
  13956. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13957. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  13958. values = int(values_int4,kind=4)
  13959. deallocate( values_int4 )
  13960. case ( DFNT_INT64 )
  13961. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13962. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  13963. values = int(values_int8,kind=4)
  13964. deallocate( values_int8 )
  13965. case ( DFNT_FLOAT32 )
  13966. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13967. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  13968. values = int(values_real4,kind=4)
  13969. deallocate( values_real4 )
  13970. case ( DFNT_FLOAT64 )
  13971. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  13972. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  13973. values = int(values_real8,kind=4)
  13974. deallocate( values_real8 )
  13975. case default
  13976. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  13977. TRACEBACK; status=1; return
  13978. end select
  13979. if ( status == FAIL ) then
  13980. write (gol,'("reading hdf4 data set:")'); call goErr
  13981. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  13982. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  13983. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  13984. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  13985. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  13986. write (gol,'(" size : ",i6)') size(values); call goErr
  13987. TRACEBACK; status=1; return
  13988. end if
  13989. #endif
  13990. #ifdef with_netcdf
  13991. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13992. case ( MDF_NETCDF, MDF_NETCDF4 )
  13993. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  13994. ! read values, converted automatically:
  13995. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  13996. start, count, stride, map )
  13997. IF_NF90_NOT_OK_RETURN(status=1)
  13998. #endif
  13999. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14000. case default
  14001. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14002. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  14003. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  14004. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  14005. TRACEBACK; status=1; return
  14006. end select
  14007. end do ! file types
  14008. ! ok
  14009. status = 0
  14010. end subroutine MDF_Get_Var_i4_5d
  14011. ! ***
  14012. subroutine MDF_Put_Var_i4_6d( hid, varid, values, status, &
  14013. start, count, stride, map )
  14014. #ifdef with_hdf5_beta
  14015. use HDF5, only : HID_T, HSIZE_T
  14016. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  14017. use HDF5, only : H5T_NATIVE_CHARACTER
  14018. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  14019. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  14020. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  14021. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  14022. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  14023. #endif
  14024. #ifdef with_netcdf
  14025. use NetCDF, only : NF90_Put_Var
  14026. #endif
  14027. ! --- in/out -------------------------------------
  14028. integer, intent(in) :: hid
  14029. integer, intent(in) :: varid
  14030. integer(4), intent(in) :: values(:,:,:,:,:,:)
  14031. integer, intent(out) :: status
  14032. integer, intent(in), optional :: start (:)
  14033. integer, intent(in), optional :: count (:)
  14034. integer, intent(in), optional :: stride(:)
  14035. integer, intent(in), optional :: map (:)
  14036. ! --- const --------------------------------------
  14037. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_6d'
  14038. ! --- external -----------------------------------
  14039. #ifdef with_hdf4
  14040. integer(hdf4_wpi), external :: sfWData
  14041. #endif
  14042. ! --- local --------------------------------------
  14043. type(MDF_File), pointer :: filep
  14044. type(MDF_Var), pointer :: varp
  14045. integer :: iftype
  14046. integer :: ftype
  14047. #ifdef with_hdf4
  14048. integer :: hdf4_offset(MAX_RANK)
  14049. integer :: hdf4_stride(MAX_RANK)
  14050. integer :: hdf4_count(MAX_RANK)
  14051. #endif
  14052. #ifdef with_hdf5_beta
  14053. !integer(HID_T) :: hdf5_type_id
  14054. integer(HID_T) :: hdf5_file_space_id
  14055. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  14056. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  14057. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  14058. #endif
  14059. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  14060. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  14061. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  14062. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  14063. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  14064. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  14065. ! --- begin --------------------------------------
  14066. ! pointer to file structure:
  14067. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  14068. IF_NOT_OK_RETURN(status=1)
  14069. ! pointer to variable structure:
  14070. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  14071. IF_NOT_OK_RETURN(status=1)
  14072. ! check ...
  14073. if ( size(shape(values)) > varp%ndim ) then
  14074. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  14075. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  14076. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  14077. TRACEBACK; status=1; return
  14078. end if
  14079. ! check ...
  14080. if ( present(start ) ) then
  14081. if ( size(start ) /= varp%ndim ) then
  14082. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14083. write (gol,'(" size start : ",i6)') size(start ); call goErr
  14084. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14085. TRACEBACK; status=1; return
  14086. end if
  14087. end if
  14088. if ( present(count ) ) then
  14089. if ( size(count ) /= varp%ndim ) then
  14090. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14091. write (gol,'(" size count : ",i6)') size(count ); call goErr
  14092. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14093. TRACEBACK; status=1; return
  14094. end if
  14095. end if
  14096. if ( present(stride ) ) then
  14097. if ( size(stride ) /= varp%ndim ) then
  14098. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14099. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  14100. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14101. TRACEBACK; status=1; return
  14102. end if
  14103. end if
  14104. if ( present(map ) ) then
  14105. if ( size(map ) /= varp%ndim ) then
  14106. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14107. write (gol,'(" size map : ",i6)') size(map ); call goErr
  14108. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14109. TRACEBACK; status=1; return
  14110. end if
  14111. end if
  14112. ! loop over file types:
  14113. do iftype = 1, filep%nftype
  14114. ! current type:
  14115. ftype = filep%ftypes(iftype)
  14116. ! select appropriate routine for each type:
  14117. select case ( ftype )
  14118. #ifdef with_hdf4
  14119. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14120. case ( MDF_HDF4 )
  14121. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14122. ! check ...
  14123. if ( present(map ) ) then
  14124. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  14125. TRACEBACK; status=1; return
  14126. end if
  14127. ! fill offset (zero based!) and stride with default values:
  14128. hdf4_offset = 0
  14129. hdf4_stride = 1
  14130. ! count is by default the shape; padd with singleton dimensions:
  14131. hdf4_count = 1; hdf4_count(1:6) = shape(values)
  14132. ! replace by optional arguments if necessary:
  14133. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  14134. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  14135. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  14136. ! test target type;
  14137. ! convert to required kind before entering sfWData,
  14138. ! otherwise segmentation faults on some machines ...
  14139. select case ( varp%xtype )
  14140. case ( MDF_BYTE )
  14141. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14142. values_int1 = int(values,kind=1)
  14143. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14144. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  14145. deallocate( values_int1 )
  14146. case ( MDF_SHORT )
  14147. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14148. values_int2 = int(values,kind=2)
  14149. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14150. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  14151. deallocate( values_int2 )
  14152. case ( MDF_INT )
  14153. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14154. values_int4 = int(values,kind=4)
  14155. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14156. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  14157. deallocate( values_int4 )
  14158. case ( MDF_FLOAT )
  14159. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14160. values_real4 = real(values,kind=4)
  14161. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14162. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  14163. deallocate( values_real4 )
  14164. case ( MDF_DOUBLE )
  14165. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14166. values_real8 = real(values,kind=8)
  14167. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14168. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  14169. deallocate( values_real8 )
  14170. case default
  14171. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  14172. TRACEBACK; status=1; return
  14173. end select
  14174. if ( status == FAIL ) then
  14175. write (gol,'("writing hdf4 data set:")'); call goErr
  14176. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  14177. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  14178. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  14179. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  14180. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  14181. write (gol,'(" size : ",i12)') size(values); call goErr
  14182. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  14183. TRACEBACK; status=1; return
  14184. end if
  14185. #endif
  14186. #ifdef with_hdf5_beta
  14187. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14188. case ( MDF_HDF5 )
  14189. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14190. ! check ...
  14191. if ( present(map ) ) then
  14192. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  14193. TRACEBACK; status=1; return
  14194. end if
  14195. ! fill offset (zero based!), stride, and count :
  14196. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  14197. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  14198. hdf5_count = 1 ! default singleton dimension
  14199. if ( present(count) ) then
  14200. hdf5_count(1:varp%ndim) = count
  14201. else
  14202. hdf5_count(1:6) = shape(values)
  14203. end if
  14204. ! new dimension:
  14205. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  14206. ! target data space in file:
  14207. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  14208. IF_NOT_OK_RETURN(status=1)
  14209. ! chunked dataset ?
  14210. if ( varp%hdf5_chunked ) then
  14211. ! reset extend:
  14212. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  14213. IF_NOT_OK_RETURN(status=1)
  14214. end if
  14215. ! select hyperslab:
  14216. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  14217. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  14218. stride=hdf5_stride(1:varp%ndim) )
  14219. ! write data:
  14220. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  14221. int(shape(values),kind=HSIZE_T), status, &
  14222. file_space_id=hdf5_file_space_id )
  14223. IF_NOT_OK_RETURN(status=1)
  14224. ! release data space:
  14225. call H5SClose_f( hdf5_file_space_id, status )
  14226. IF_NOT_OK_RETURN(status=1)
  14227. #endif
  14228. #ifdef with_netcdf
  14229. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14230. case ( MDF_NETCDF, MDF_NETCDF4 )
  14231. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14232. ! test target type:
  14233. ! convert to required kind before entering NF90_Put_Var,
  14234. ! otherwise segmentation faults on some machines ...
  14235. select case ( varp%xtype )
  14236. case ( MDF_BYTE )
  14237. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14238. values_int1 = int(values,kind=1)
  14239. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  14240. start, count, stride, map )
  14241. IF_NF90_NOT_OK_RETURN(status=1)
  14242. deallocate( values_int1 )
  14243. case ( MDF_SHORT )
  14244. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14245. values_int2 = int(values,kind=2)
  14246. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  14247. start, count, stride, map )
  14248. IF_NF90_NOT_OK_RETURN(status=1)
  14249. deallocate( values_int2 )
  14250. case ( MDF_INT )
  14251. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14252. values_int4 = int(values,kind=4)
  14253. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  14254. start, count, stride, map )
  14255. IF_NF90_NOT_OK_RETURN(status=1)
  14256. deallocate( values_int4 )
  14257. case ( MDF_FLOAT )
  14258. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14259. values_real4 = real(values,kind=4)
  14260. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  14261. start, count, stride, map )
  14262. IF_NF90_NOT_OK_RETURN(status=1)
  14263. deallocate( values_real4 )
  14264. case ( MDF_DOUBLE )
  14265. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14266. values_real8 = real(values,kind=8)
  14267. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  14268. start, count, stride, map )
  14269. IF_NF90_NOT_OK_RETURN(status=1)
  14270. deallocate( values_real8 )
  14271. case default
  14272. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  14273. TRACEBACK; status=1; return
  14274. end select
  14275. ! just put; let netcdf library convert the right kind:
  14276. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  14277. ! start, count, stride, map )
  14278. !IF_NF90_NOT_OK_RETURN(status=1)
  14279. #endif
  14280. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14281. case default
  14282. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14283. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  14284. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  14285. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  14286. TRACEBACK; status=1; return
  14287. end select
  14288. end do ! file types
  14289. ! ok
  14290. status = 0
  14291. end subroutine MDF_Put_Var_i4_6d
  14292. ! ***
  14293. subroutine MDF_Get_Var_i4_6d( hid, varid, values, status, &
  14294. start, count, stride, map )
  14295. #ifdef with_netcdf
  14296. use NetCDF, only : NF90_Get_Var
  14297. #endif
  14298. ! --- in/out -------------------------------------
  14299. integer, intent(in) :: hid
  14300. integer, intent(in) :: varid
  14301. integer(4), intent(out) :: values(:,:,:,:,:,:)
  14302. integer, intent(out) :: status
  14303. integer, intent(in), optional :: start (:)
  14304. integer, intent(in), optional :: count (:)
  14305. integer, intent(in), optional :: stride(:)
  14306. integer, intent(in), optional :: map (:)
  14307. ! --- const --------------------------------------
  14308. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_6d'
  14309. ! --- external -----------------------------------
  14310. #ifdef with_hdf4
  14311. integer(hdf4_wpi), external :: sfRData
  14312. #endif
  14313. ! --- local --------------------------------------
  14314. type(MDF_File), pointer :: filep
  14315. type(MDF_Var), pointer :: varp
  14316. integer :: iftype
  14317. integer :: ftype
  14318. #ifdef with_hdf4
  14319. integer :: hdf4_offset(MAX_RANK)
  14320. integer :: hdf4_stride(MAX_RANK)
  14321. integer :: hdf4_count(MAX_RANK)
  14322. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  14323. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  14324. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  14325. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  14326. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  14327. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  14328. #endif
  14329. ! --- begin --------------------------------------
  14330. ! pointer to file structure:
  14331. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  14332. IF_NOT_OK_RETURN(status=1)
  14333. ! pointer to variable structure:
  14334. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  14335. IF_NOT_OK_RETURN(status=1)
  14336. ! check ...
  14337. if ( size(shape(values)) > varp%ndim ) then
  14338. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  14339. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  14340. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  14341. TRACEBACK; status=1; return
  14342. end if
  14343. ! check ...
  14344. if ( present(start ) ) then
  14345. if ( size(start ) /= varp%ndim ) then
  14346. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14347. write (gol,'(" size start : ",i6)') size(start ); call goErr
  14348. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14349. TRACEBACK; status=1; return
  14350. end if
  14351. end if
  14352. if ( present(count ) ) then
  14353. if ( size(count ) /= varp%ndim ) then
  14354. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14355. write (gol,'(" size count : ",i6)') size(count ); call goErr
  14356. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14357. TRACEBACK; status=1; return
  14358. end if
  14359. end if
  14360. if ( present(stride ) ) then
  14361. if ( size(stride ) /= varp%ndim ) then
  14362. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14363. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  14364. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14365. TRACEBACK; status=1; return
  14366. end if
  14367. end if
  14368. if ( present(map ) ) then
  14369. if ( size(map ) /= varp%ndim ) then
  14370. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14371. write (gol,'(" size map : ",i6)') size(map ); call goErr
  14372. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14373. TRACEBACK; status=1; return
  14374. end if
  14375. end if
  14376. ! loop over file types:
  14377. do iftype = 1, filep%nftype
  14378. ! current type:
  14379. ftype = filep%ftypes(iftype)
  14380. ! select appropriate routine for each type:
  14381. select case ( ftype )
  14382. #ifdef with_hdf4
  14383. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14384. case ( MDF_HDF4 )
  14385. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14386. ! check ...
  14387. if ( present(map ) ) then
  14388. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  14389. TRACEBACK; status=1; return
  14390. end if
  14391. ! fill offset (zero based!), stride, and count :
  14392. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  14393. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  14394. hdf4_count = 1 ! default singleton dimension
  14395. hdf4_count(1:6) = shape(values)
  14396. ! test source type:
  14397. select case ( varp%hdf4_xtype )
  14398. case ( DFNT_INT8 )
  14399. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14400. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  14401. values = int(values_int1,kind=4)
  14402. deallocate( values_int1 )
  14403. case ( DFNT_INT16 )
  14404. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14405. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  14406. values = int(values_int2,kind=4)
  14407. deallocate( values_int2 )
  14408. case ( DFNT_INT32 )
  14409. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14410. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  14411. values = int(values_int4,kind=4)
  14412. deallocate( values_int4 )
  14413. case ( DFNT_INT64 )
  14414. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14415. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  14416. values = int(values_int8,kind=4)
  14417. deallocate( values_int8 )
  14418. case ( DFNT_FLOAT32 )
  14419. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14420. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  14421. values = int(values_real4,kind=4)
  14422. deallocate( values_real4 )
  14423. case ( DFNT_FLOAT64 )
  14424. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  14425. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  14426. values = int(values_real8,kind=4)
  14427. deallocate( values_real8 )
  14428. case default
  14429. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  14430. TRACEBACK; status=1; return
  14431. end select
  14432. if ( status == FAIL ) then
  14433. write (gol,'("reading hdf4 data set:")'); call goErr
  14434. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  14435. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  14436. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  14437. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  14438. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  14439. write (gol,'(" size : ",i6)') size(values); call goErr
  14440. TRACEBACK; status=1; return
  14441. end if
  14442. #endif
  14443. #ifdef with_netcdf
  14444. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14445. case ( MDF_NETCDF, MDF_NETCDF4 )
  14446. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14447. ! read values, converted automatically:
  14448. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  14449. start, count, stride, map )
  14450. IF_NF90_NOT_OK_RETURN(status=1)
  14451. #endif
  14452. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14453. case default
  14454. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14455. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  14456. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  14457. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  14458. TRACEBACK; status=1; return
  14459. end select
  14460. end do ! file types
  14461. ! ok
  14462. status = 0
  14463. end subroutine MDF_Get_Var_i4_6d
  14464. ! ***
  14465. subroutine MDF_Put_Var_i4_7d( hid, varid, values, status, &
  14466. start, count, stride, map )
  14467. #ifdef with_hdf5_beta
  14468. use HDF5, only : HID_T, HSIZE_T
  14469. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  14470. use HDF5, only : H5T_NATIVE_CHARACTER
  14471. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  14472. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  14473. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  14474. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  14475. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  14476. #endif
  14477. #ifdef with_netcdf
  14478. use NetCDF, only : NF90_Put_Var
  14479. #endif
  14480. ! --- in/out -------------------------------------
  14481. integer, intent(in) :: hid
  14482. integer, intent(in) :: varid
  14483. integer(4), intent(in) :: values(:,:,:,:,:,:,:)
  14484. integer, intent(out) :: status
  14485. integer, intent(in), optional :: start (:)
  14486. integer, intent(in), optional :: count (:)
  14487. integer, intent(in), optional :: stride(:)
  14488. integer, intent(in), optional :: map (:)
  14489. ! --- const --------------------------------------
  14490. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_7d'
  14491. ! --- external -----------------------------------
  14492. #ifdef with_hdf4
  14493. integer(hdf4_wpi), external :: sfWData
  14494. #endif
  14495. ! --- local --------------------------------------
  14496. type(MDF_File), pointer :: filep
  14497. type(MDF_Var), pointer :: varp
  14498. integer :: iftype
  14499. integer :: ftype
  14500. #ifdef with_hdf4
  14501. integer :: hdf4_offset(MAX_RANK)
  14502. integer :: hdf4_stride(MAX_RANK)
  14503. integer :: hdf4_count(MAX_RANK)
  14504. #endif
  14505. #ifdef with_hdf5_beta
  14506. !integer(HID_T) :: hdf5_type_id
  14507. integer(HID_T) :: hdf5_file_space_id
  14508. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  14509. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  14510. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  14511. #endif
  14512. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  14513. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  14514. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  14515. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  14516. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  14517. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  14518. ! --- begin --------------------------------------
  14519. ! pointer to file structure:
  14520. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  14521. IF_NOT_OK_RETURN(status=1)
  14522. ! pointer to variable structure:
  14523. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  14524. IF_NOT_OK_RETURN(status=1)
  14525. ! check ...
  14526. if ( size(shape(values)) > varp%ndim ) then
  14527. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  14528. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  14529. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  14530. TRACEBACK; status=1; return
  14531. end if
  14532. ! check ...
  14533. if ( present(start ) ) then
  14534. if ( size(start ) /= varp%ndim ) then
  14535. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14536. write (gol,'(" size start : ",i6)') size(start ); call goErr
  14537. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14538. TRACEBACK; status=1; return
  14539. end if
  14540. end if
  14541. if ( present(count ) ) then
  14542. if ( size(count ) /= varp%ndim ) then
  14543. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14544. write (gol,'(" size count : ",i6)') size(count ); call goErr
  14545. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14546. TRACEBACK; status=1; return
  14547. end if
  14548. end if
  14549. if ( present(stride ) ) then
  14550. if ( size(stride ) /= varp%ndim ) then
  14551. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14552. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  14553. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14554. TRACEBACK; status=1; return
  14555. end if
  14556. end if
  14557. if ( present(map ) ) then
  14558. if ( size(map ) /= varp%ndim ) then
  14559. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14560. write (gol,'(" size map : ",i6)') size(map ); call goErr
  14561. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14562. TRACEBACK; status=1; return
  14563. end if
  14564. end if
  14565. ! loop over file types:
  14566. do iftype = 1, filep%nftype
  14567. ! current type:
  14568. ftype = filep%ftypes(iftype)
  14569. ! select appropriate routine for each type:
  14570. select case ( ftype )
  14571. #ifdef with_hdf4
  14572. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14573. case ( MDF_HDF4 )
  14574. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14575. ! check ...
  14576. if ( present(map ) ) then
  14577. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  14578. TRACEBACK; status=1; return
  14579. end if
  14580. ! fill offset (zero based!) and stride with default values:
  14581. hdf4_offset = 0
  14582. hdf4_stride = 1
  14583. ! count is by default the shape; padd with singleton dimensions:
  14584. hdf4_count = 1; hdf4_count(1:7) = shape(values)
  14585. ! replace by optional arguments if necessary:
  14586. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  14587. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  14588. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  14589. ! test target type;
  14590. ! convert to required kind before entering sfWData,
  14591. ! otherwise segmentation faults on some machines ...
  14592. select case ( varp%xtype )
  14593. case ( MDF_BYTE )
  14594. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14595. values_int1 = int(values,kind=1)
  14596. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14597. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  14598. deallocate( values_int1 )
  14599. case ( MDF_SHORT )
  14600. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14601. values_int2 = int(values,kind=2)
  14602. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14603. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  14604. deallocate( values_int2 )
  14605. case ( MDF_INT )
  14606. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14607. values_int4 = int(values,kind=4)
  14608. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14609. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  14610. deallocate( values_int4 )
  14611. case ( MDF_FLOAT )
  14612. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14613. values_real4 = real(values,kind=4)
  14614. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14615. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  14616. deallocate( values_real4 )
  14617. case ( MDF_DOUBLE )
  14618. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14619. values_real8 = real(values,kind=8)
  14620. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  14621. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  14622. deallocate( values_real8 )
  14623. case default
  14624. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  14625. TRACEBACK; status=1; return
  14626. end select
  14627. if ( status == FAIL ) then
  14628. write (gol,'("writing hdf4 data set:")'); call goErr
  14629. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  14630. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  14631. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  14632. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  14633. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  14634. write (gol,'(" size : ",i12)') size(values); call goErr
  14635. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  14636. TRACEBACK; status=1; return
  14637. end if
  14638. #endif
  14639. #ifdef with_hdf5_beta
  14640. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14641. case ( MDF_HDF5 )
  14642. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14643. ! check ...
  14644. if ( present(map ) ) then
  14645. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  14646. TRACEBACK; status=1; return
  14647. end if
  14648. ! fill offset (zero based!), stride, and count :
  14649. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  14650. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  14651. hdf5_count = 1 ! default singleton dimension
  14652. if ( present(count) ) then
  14653. hdf5_count(1:varp%ndim) = count
  14654. else
  14655. hdf5_count(1:7) = shape(values)
  14656. end if
  14657. ! new dimension:
  14658. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  14659. ! target data space in file:
  14660. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  14661. IF_NOT_OK_RETURN(status=1)
  14662. ! chunked dataset ?
  14663. if ( varp%hdf5_chunked ) then
  14664. ! reset extend:
  14665. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  14666. IF_NOT_OK_RETURN(status=1)
  14667. end if
  14668. ! select hyperslab:
  14669. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  14670. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  14671. stride=hdf5_stride(1:varp%ndim) )
  14672. ! write data:
  14673. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, &
  14674. int(shape(values),kind=HSIZE_T), status, &
  14675. file_space_id=hdf5_file_space_id )
  14676. IF_NOT_OK_RETURN(status=1)
  14677. ! release data space:
  14678. call H5SClose_f( hdf5_file_space_id, status )
  14679. IF_NOT_OK_RETURN(status=1)
  14680. #endif
  14681. #ifdef with_netcdf
  14682. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14683. case ( MDF_NETCDF, MDF_NETCDF4 )
  14684. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14685. ! test target type:
  14686. ! convert to required kind before entering NF90_Put_Var,
  14687. ! otherwise segmentation faults on some machines ...
  14688. select case ( varp%xtype )
  14689. case ( MDF_BYTE )
  14690. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14691. values_int1 = int(values,kind=1)
  14692. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  14693. start, count, stride, map )
  14694. IF_NF90_NOT_OK_RETURN(status=1)
  14695. deallocate( values_int1 )
  14696. case ( MDF_SHORT )
  14697. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14698. values_int2 = int(values,kind=2)
  14699. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  14700. start, count, stride, map )
  14701. IF_NF90_NOT_OK_RETURN(status=1)
  14702. deallocate( values_int2 )
  14703. case ( MDF_INT )
  14704. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14705. values_int4 = int(values,kind=4)
  14706. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  14707. start, count, stride, map )
  14708. IF_NF90_NOT_OK_RETURN(status=1)
  14709. deallocate( values_int4 )
  14710. case ( MDF_FLOAT )
  14711. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14712. values_real4 = real(values,kind=4)
  14713. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  14714. start, count, stride, map )
  14715. IF_NF90_NOT_OK_RETURN(status=1)
  14716. deallocate( values_real4 )
  14717. case ( MDF_DOUBLE )
  14718. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14719. values_real8 = real(values,kind=8)
  14720. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  14721. start, count, stride, map )
  14722. IF_NF90_NOT_OK_RETURN(status=1)
  14723. deallocate( values_real8 )
  14724. case default
  14725. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  14726. TRACEBACK; status=1; return
  14727. end select
  14728. ! just put; let netcdf library convert the right kind:
  14729. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  14730. ! start, count, stride, map )
  14731. !IF_NF90_NOT_OK_RETURN(status=1)
  14732. #endif
  14733. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14734. case default
  14735. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14736. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  14737. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  14738. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  14739. TRACEBACK; status=1; return
  14740. end select
  14741. end do ! file types
  14742. ! ok
  14743. status = 0
  14744. end subroutine MDF_Put_Var_i4_7d
  14745. ! ***
  14746. subroutine MDF_Get_Var_i4_7d( hid, varid, values, status, &
  14747. start, count, stride, map )
  14748. #ifdef with_netcdf
  14749. use NetCDF, only : NF90_Get_Var
  14750. #endif
  14751. ! --- in/out -------------------------------------
  14752. integer, intent(in) :: hid
  14753. integer, intent(in) :: varid
  14754. integer(4), intent(out) :: values(:,:,:,:,:,:,:)
  14755. integer, intent(out) :: status
  14756. integer, intent(in), optional :: start (:)
  14757. integer, intent(in), optional :: count (:)
  14758. integer, intent(in), optional :: stride(:)
  14759. integer, intent(in), optional :: map (:)
  14760. ! --- const --------------------------------------
  14761. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_7d'
  14762. ! --- external -----------------------------------
  14763. #ifdef with_hdf4
  14764. integer(hdf4_wpi), external :: sfRData
  14765. #endif
  14766. ! --- local --------------------------------------
  14767. type(MDF_File), pointer :: filep
  14768. type(MDF_Var), pointer :: varp
  14769. integer :: iftype
  14770. integer :: ftype
  14771. #ifdef with_hdf4
  14772. integer :: hdf4_offset(MAX_RANK)
  14773. integer :: hdf4_stride(MAX_RANK)
  14774. integer :: hdf4_count(MAX_RANK)
  14775. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  14776. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  14777. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  14778. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  14779. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  14780. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  14781. #endif
  14782. ! --- begin --------------------------------------
  14783. ! pointer to file structure:
  14784. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  14785. IF_NOT_OK_RETURN(status=1)
  14786. ! pointer to variable structure:
  14787. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  14788. IF_NOT_OK_RETURN(status=1)
  14789. ! check ...
  14790. if ( size(shape(values)) > varp%ndim ) then
  14791. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  14792. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  14793. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  14794. TRACEBACK; status=1; return
  14795. end if
  14796. ! check ...
  14797. if ( present(start ) ) then
  14798. if ( size(start ) /= varp%ndim ) then
  14799. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14800. write (gol,'(" size start : ",i6)') size(start ); call goErr
  14801. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14802. TRACEBACK; status=1; return
  14803. end if
  14804. end if
  14805. if ( present(count ) ) then
  14806. if ( size(count ) /= varp%ndim ) then
  14807. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14808. write (gol,'(" size count : ",i6)') size(count ); call goErr
  14809. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14810. TRACEBACK; status=1; return
  14811. end if
  14812. end if
  14813. if ( present(stride ) ) then
  14814. if ( size(stride ) /= varp%ndim ) then
  14815. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14816. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  14817. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14818. TRACEBACK; status=1; return
  14819. end if
  14820. end if
  14821. if ( present(map ) ) then
  14822. if ( size(map ) /= varp%ndim ) then
  14823. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14824. write (gol,'(" size map : ",i6)') size(map ); call goErr
  14825. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14826. TRACEBACK; status=1; return
  14827. end if
  14828. end if
  14829. ! loop over file types:
  14830. do iftype = 1, filep%nftype
  14831. ! current type:
  14832. ftype = filep%ftypes(iftype)
  14833. ! select appropriate routine for each type:
  14834. select case ( ftype )
  14835. #ifdef with_hdf4
  14836. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14837. case ( MDF_HDF4 )
  14838. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14839. ! check ...
  14840. if ( present(map ) ) then
  14841. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  14842. TRACEBACK; status=1; return
  14843. end if
  14844. ! fill offset (zero based!), stride, and count :
  14845. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  14846. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  14847. hdf4_count = 1 ! default singleton dimension
  14848. hdf4_count(1:7) = shape(values)
  14849. ! test source type:
  14850. select case ( varp%hdf4_xtype )
  14851. case ( DFNT_INT8 )
  14852. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14853. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  14854. values = int(values_int1,kind=4)
  14855. deallocate( values_int1 )
  14856. case ( DFNT_INT16 )
  14857. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14858. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  14859. values = int(values_int2,kind=4)
  14860. deallocate( values_int2 )
  14861. case ( DFNT_INT32 )
  14862. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14863. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  14864. values = int(values_int4,kind=4)
  14865. deallocate( values_int4 )
  14866. case ( DFNT_INT64 )
  14867. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14868. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  14869. values = int(values_int8,kind=4)
  14870. deallocate( values_int8 )
  14871. case ( DFNT_FLOAT32 )
  14872. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14873. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  14874. values = int(values_real4,kind=4)
  14875. deallocate( values_real4 )
  14876. case ( DFNT_FLOAT64 )
  14877. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  14878. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  14879. values = int(values_real8,kind=4)
  14880. deallocate( values_real8 )
  14881. case default
  14882. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  14883. TRACEBACK; status=1; return
  14884. end select
  14885. if ( status == FAIL ) then
  14886. write (gol,'("reading hdf4 data set:")'); call goErr
  14887. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  14888. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  14889. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  14890. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  14891. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  14892. write (gol,'(" size : ",i6)') size(values); call goErr
  14893. TRACEBACK; status=1; return
  14894. end if
  14895. #endif
  14896. #ifdef with_netcdf
  14897. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14898. case ( MDF_NETCDF, MDF_NETCDF4 )
  14899. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14900. ! read values, converted automatically:
  14901. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  14902. start, count, stride, map )
  14903. IF_NF90_NOT_OK_RETURN(status=1)
  14904. #endif
  14905. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14906. case default
  14907. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  14908. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  14909. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  14910. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  14911. TRACEBACK; status=1; return
  14912. end select
  14913. end do ! file types
  14914. ! ok
  14915. status = 0
  14916. end subroutine MDF_Get_Var_i4_7d
  14917. ! ***
  14918. subroutine MDF_Put_Var_r4_1d( hid, varid, values, status, &
  14919. start, count, stride, map )
  14920. #ifdef with_hdf5_beta
  14921. use HDF5, only : HID_T, HSIZE_T
  14922. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  14923. use HDF5, only : H5T_NATIVE_CHARACTER
  14924. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  14925. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  14926. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  14927. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  14928. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  14929. #endif
  14930. #ifdef with_netcdf
  14931. use NetCDF, only : NF90_Put_Var
  14932. #endif
  14933. ! --- in/out -------------------------------------
  14934. integer, intent(in) :: hid
  14935. integer, intent(in) :: varid
  14936. real(4), intent(in) :: values(:)
  14937. integer, intent(out) :: status
  14938. integer, intent(in), optional :: start (:)
  14939. integer, intent(in), optional :: count (:)
  14940. integer, intent(in), optional :: stride(:)
  14941. integer, intent(in), optional :: map (:)
  14942. ! --- const --------------------------------------
  14943. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_1d'
  14944. ! --- external -----------------------------------
  14945. #ifdef with_hdf4
  14946. integer(hdf4_wpi), external :: sfWData
  14947. #endif
  14948. ! --- local --------------------------------------
  14949. type(MDF_File), pointer :: filep
  14950. type(MDF_Var), pointer :: varp
  14951. integer :: iftype
  14952. integer :: ftype
  14953. #ifdef with_hdf4
  14954. integer :: hdf4_offset(MAX_RANK)
  14955. integer :: hdf4_stride(MAX_RANK)
  14956. integer :: hdf4_count(MAX_RANK)
  14957. #endif
  14958. #ifdef with_hdf5_beta
  14959. !integer(HID_T) :: hdf5_type_id
  14960. integer(HID_T) :: hdf5_file_space_id
  14961. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  14962. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  14963. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  14964. #endif
  14965. integer(1), allocatable :: values_int1(:)
  14966. integer(2), allocatable :: values_int2(:)
  14967. integer(4), allocatable :: values_int4(:)
  14968. integer(8), allocatable :: values_int8(:)
  14969. real(4), allocatable :: values_real4(:)
  14970. real(8), allocatable :: values_real8(:)
  14971. ! --- begin --------------------------------------
  14972. ! pointer to file structure:
  14973. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  14974. IF_NOT_OK_RETURN(status=1)
  14975. ! pointer to variable structure:
  14976. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  14977. IF_NOT_OK_RETURN(status=1)
  14978. ! check ...
  14979. if ( size(shape(values)) > varp%ndim ) then
  14980. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  14981. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  14982. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  14983. TRACEBACK; status=1; return
  14984. end if
  14985. ! check ...
  14986. if ( present(start ) ) then
  14987. if ( size(start ) /= varp%ndim ) then
  14988. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14989. write (gol,'(" size start : ",i6)') size(start ); call goErr
  14990. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14991. TRACEBACK; status=1; return
  14992. end if
  14993. end if
  14994. if ( present(count ) ) then
  14995. if ( size(count ) /= varp%ndim ) then
  14996. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  14997. write (gol,'(" size count : ",i6)') size(count ); call goErr
  14998. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  14999. TRACEBACK; status=1; return
  15000. end if
  15001. end if
  15002. if ( present(stride ) ) then
  15003. if ( size(stride ) /= varp%ndim ) then
  15004. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15005. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  15006. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15007. TRACEBACK; status=1; return
  15008. end if
  15009. end if
  15010. if ( present(map ) ) then
  15011. if ( size(map ) /= varp%ndim ) then
  15012. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15013. write (gol,'(" size map : ",i6)') size(map ); call goErr
  15014. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15015. TRACEBACK; status=1; return
  15016. end if
  15017. end if
  15018. ! loop over file types:
  15019. do iftype = 1, filep%nftype
  15020. ! current type:
  15021. ftype = filep%ftypes(iftype)
  15022. ! select appropriate routine for each type:
  15023. select case ( ftype )
  15024. #ifdef with_hdf4
  15025. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15026. case ( MDF_HDF4 )
  15027. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15028. ! check ...
  15029. if ( present(map ) ) then
  15030. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  15031. TRACEBACK; status=1; return
  15032. end if
  15033. ! fill offset (zero based!) and stride with default values:
  15034. hdf4_offset = 0
  15035. hdf4_stride = 1
  15036. ! count is by default the shape; padd with singleton dimensions:
  15037. hdf4_count = 1; hdf4_count(1:1) = shape(values)
  15038. ! replace by optional arguments if necessary:
  15039. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  15040. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  15041. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  15042. ! test target type;
  15043. ! convert to required kind before entering sfWData,
  15044. ! otherwise segmentation faults on some machines ...
  15045. select case ( varp%xtype )
  15046. case ( MDF_BYTE )
  15047. allocate( values_int1(size(values,1)) )
  15048. values_int1 = int(values,kind=1)
  15049. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15050. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  15051. deallocate( values_int1 )
  15052. case ( MDF_SHORT )
  15053. allocate( values_int2(size(values,1)) )
  15054. values_int2 = int(values,kind=2)
  15055. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15056. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  15057. deallocate( values_int2 )
  15058. case ( MDF_INT )
  15059. allocate( values_int4(size(values,1)) )
  15060. values_int4 = int(values,kind=4)
  15061. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15062. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  15063. deallocate( values_int4 )
  15064. case ( MDF_FLOAT )
  15065. allocate( values_real4(size(values,1)) )
  15066. values_real4 = real(values,kind=4)
  15067. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15068. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  15069. deallocate( values_real4 )
  15070. case ( MDF_DOUBLE )
  15071. allocate( values_real8(size(values,1)) )
  15072. values_real8 = real(values,kind=8)
  15073. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15074. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  15075. deallocate( values_real8 )
  15076. case default
  15077. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  15078. TRACEBACK; status=1; return
  15079. end select
  15080. if ( status == FAIL ) then
  15081. write (gol,'("writing hdf4 data set:")'); call goErr
  15082. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  15083. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  15084. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  15085. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  15086. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  15087. write (gol,'(" size : ",i12)') size(values); call goErr
  15088. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  15089. TRACEBACK; status=1; return
  15090. end if
  15091. #endif
  15092. #ifdef with_hdf5_beta
  15093. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15094. case ( MDF_HDF5 )
  15095. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15096. ! check ...
  15097. if ( present(map ) ) then
  15098. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  15099. TRACEBACK; status=1; return
  15100. end if
  15101. ! fill offset (zero based!), stride, and count :
  15102. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  15103. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  15104. hdf5_count = 1 ! default singleton dimension
  15105. if ( present(count) ) then
  15106. hdf5_count(1:varp%ndim) = count
  15107. else
  15108. hdf5_count(1:1) = shape(values)
  15109. end if
  15110. ! new dimension:
  15111. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  15112. ! target data space in file:
  15113. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  15114. IF_NOT_OK_RETURN(status=1)
  15115. ! chunked dataset ?
  15116. if ( varp%hdf5_chunked ) then
  15117. ! reset extend:
  15118. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  15119. IF_NOT_OK_RETURN(status=1)
  15120. end if
  15121. ! select hyperslab:
  15122. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  15123. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  15124. stride=hdf5_stride(1:varp%ndim) )
  15125. ! write data:
  15126. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  15127. int(shape(values),kind=HSIZE_T), status, &
  15128. file_space_id=hdf5_file_space_id )
  15129. IF_NOT_OK_RETURN(status=1)
  15130. ! release data space:
  15131. call H5SClose_f( hdf5_file_space_id, status )
  15132. IF_NOT_OK_RETURN(status=1)
  15133. #endif
  15134. #ifdef with_netcdf
  15135. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15136. case ( MDF_NETCDF, MDF_NETCDF4 )
  15137. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15138. ! test target type:
  15139. ! convert to required kind before entering NF90_Put_Var,
  15140. ! otherwise segmentation faults on some machines ...
  15141. select case ( varp%xtype )
  15142. case ( MDF_BYTE )
  15143. allocate( values_int1(size(values,1)) )
  15144. values_int1 = int(values,kind=1)
  15145. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  15146. start, count, stride, map )
  15147. IF_NF90_NOT_OK_RETURN(status=1)
  15148. deallocate( values_int1 )
  15149. case ( MDF_SHORT )
  15150. allocate( values_int2(size(values,1)) )
  15151. values_int2 = int(values,kind=2)
  15152. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  15153. start, count, stride, map )
  15154. IF_NF90_NOT_OK_RETURN(status=1)
  15155. deallocate( values_int2 )
  15156. case ( MDF_INT )
  15157. allocate( values_int4(size(values,1)) )
  15158. values_int4 = int(values,kind=4)
  15159. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  15160. start, count, stride, map )
  15161. IF_NF90_NOT_OK_RETURN(status=1)
  15162. deallocate( values_int4 )
  15163. case ( MDF_FLOAT )
  15164. allocate( values_real4(size(values,1)) )
  15165. values_real4 = real(values,kind=4)
  15166. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  15167. start, count, stride, map )
  15168. IF_NF90_NOT_OK_RETURN(status=1)
  15169. deallocate( values_real4 )
  15170. case ( MDF_DOUBLE )
  15171. allocate( values_real8(size(values,1)) )
  15172. values_real8 = real(values,kind=8)
  15173. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  15174. start, count, stride, map )
  15175. IF_NF90_NOT_OK_RETURN(status=1)
  15176. deallocate( values_real8 )
  15177. case default
  15178. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  15179. TRACEBACK; status=1; return
  15180. end select
  15181. ! just put; let netcdf library convert the right kind:
  15182. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  15183. ! start, count, stride, map )
  15184. !IF_NF90_NOT_OK_RETURN(status=1)
  15185. #endif
  15186. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15187. case default
  15188. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15189. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  15190. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  15191. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  15192. TRACEBACK; status=1; return
  15193. end select
  15194. end do ! file types
  15195. ! ok
  15196. status = 0
  15197. end subroutine MDF_Put_Var_r4_1d
  15198. ! ***
  15199. subroutine MDF_Get_Var_r4_1d( hid, varid, values, status, &
  15200. start, count, stride, map )
  15201. #ifdef with_netcdf
  15202. use NetCDF, only : NF90_Get_Var
  15203. #endif
  15204. ! --- in/out -------------------------------------
  15205. integer, intent(in) :: hid
  15206. integer, intent(in) :: varid
  15207. real(4), intent(out) :: values(:)
  15208. integer, intent(out) :: status
  15209. integer, intent(in), optional :: start (:)
  15210. integer, intent(in), optional :: count (:)
  15211. integer, intent(in), optional :: stride(:)
  15212. integer, intent(in), optional :: map (:)
  15213. ! --- const --------------------------------------
  15214. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_1d'
  15215. ! --- external -----------------------------------
  15216. #ifdef with_hdf4
  15217. integer(hdf4_wpi), external :: sfRData
  15218. #endif
  15219. ! --- local --------------------------------------
  15220. type(MDF_File), pointer :: filep
  15221. type(MDF_Var), pointer :: varp
  15222. integer :: iftype
  15223. integer :: ftype
  15224. #ifdef with_hdf4
  15225. integer :: hdf4_offset(MAX_RANK)
  15226. integer :: hdf4_stride(MAX_RANK)
  15227. integer :: hdf4_count(MAX_RANK)
  15228. integer(1), allocatable :: values_int1(:)
  15229. integer(2), allocatable :: values_int2(:)
  15230. integer(4), allocatable :: values_int4(:)
  15231. integer(8), allocatable :: values_int8(:)
  15232. real(4), allocatable :: values_real4(:)
  15233. real(8), allocatable :: values_real8(:)
  15234. #endif
  15235. ! --- begin --------------------------------------
  15236. ! pointer to file structure:
  15237. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  15238. IF_NOT_OK_RETURN(status=1)
  15239. ! pointer to variable structure:
  15240. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  15241. IF_NOT_OK_RETURN(status=1)
  15242. ! check ...
  15243. if ( size(shape(values)) > varp%ndim ) then
  15244. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  15245. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  15246. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  15247. TRACEBACK; status=1; return
  15248. end if
  15249. ! check ...
  15250. if ( present(start ) ) then
  15251. if ( size(start ) /= varp%ndim ) then
  15252. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15253. write (gol,'(" size start : ",i6)') size(start ); call goErr
  15254. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15255. TRACEBACK; status=1; return
  15256. end if
  15257. end if
  15258. if ( present(count ) ) then
  15259. if ( size(count ) /= varp%ndim ) then
  15260. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15261. write (gol,'(" size count : ",i6)') size(count ); call goErr
  15262. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15263. TRACEBACK; status=1; return
  15264. end if
  15265. end if
  15266. if ( present(stride ) ) then
  15267. if ( size(stride ) /= varp%ndim ) then
  15268. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15269. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  15270. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15271. TRACEBACK; status=1; return
  15272. end if
  15273. end if
  15274. if ( present(map ) ) then
  15275. if ( size(map ) /= varp%ndim ) then
  15276. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15277. write (gol,'(" size map : ",i6)') size(map ); call goErr
  15278. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15279. TRACEBACK; status=1; return
  15280. end if
  15281. end if
  15282. ! loop over file types:
  15283. do iftype = 1, filep%nftype
  15284. ! current type:
  15285. ftype = filep%ftypes(iftype)
  15286. ! select appropriate routine for each type:
  15287. select case ( ftype )
  15288. #ifdef with_hdf4
  15289. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15290. case ( MDF_HDF4 )
  15291. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15292. ! check ...
  15293. if ( present(map ) ) then
  15294. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  15295. TRACEBACK; status=1; return
  15296. end if
  15297. ! fill offset (zero based!), stride, and count :
  15298. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  15299. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  15300. hdf4_count = 1 ! default singleton dimension
  15301. hdf4_count(1:1) = shape(values)
  15302. ! test source type:
  15303. select case ( varp%hdf4_xtype )
  15304. case ( DFNT_INT8 )
  15305. allocate( values_int1(size(values,1)) )
  15306. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  15307. values = real(values_int1,kind=4)
  15308. deallocate( values_int1 )
  15309. case ( DFNT_INT16 )
  15310. allocate( values_int2(size(values,1)) )
  15311. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  15312. values = real(values_int2,kind=4)
  15313. deallocate( values_int2 )
  15314. case ( DFNT_INT32 )
  15315. allocate( values_int4(size(values,1)) )
  15316. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  15317. values = real(values_int4,kind=4)
  15318. deallocate( values_int4 )
  15319. case ( DFNT_INT64 )
  15320. allocate( values_int8(size(values,1)) )
  15321. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  15322. values = real(values_int8,kind=4)
  15323. deallocate( values_int8 )
  15324. case ( DFNT_FLOAT32 )
  15325. allocate( values_real4(size(values,1)) )
  15326. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  15327. values = real(values_real4,kind=4)
  15328. deallocate( values_real4 )
  15329. case ( DFNT_FLOAT64 )
  15330. allocate( values_real8(size(values,1)) )
  15331. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  15332. values = real(values_real8,kind=4)
  15333. deallocate( values_real8 )
  15334. case default
  15335. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  15336. TRACEBACK; status=1; return
  15337. end select
  15338. if ( status == FAIL ) then
  15339. write (gol,'("reading hdf4 data set:")'); call goErr
  15340. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  15341. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  15342. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  15343. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  15344. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  15345. write (gol,'(" size : ",i6)') size(values); call goErr
  15346. TRACEBACK; status=1; return
  15347. end if
  15348. #endif
  15349. #ifdef with_netcdf
  15350. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15351. case ( MDF_NETCDF, MDF_NETCDF4 )
  15352. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15353. ! read values, converted automatically:
  15354. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  15355. start, count, stride, map )
  15356. IF_NF90_NOT_OK_RETURN(status=1)
  15357. #endif
  15358. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15359. case default
  15360. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15361. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  15362. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  15363. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  15364. TRACEBACK; status=1; return
  15365. end select
  15366. end do ! file types
  15367. ! ok
  15368. status = 0
  15369. end subroutine MDF_Get_Var_r4_1d
  15370. ! ***
  15371. subroutine MDF_Put_Var_r4_2d( hid, varid, values, status, &
  15372. start, count, stride, map )
  15373. #ifdef with_hdf5_beta
  15374. use HDF5, only : HID_T, HSIZE_T
  15375. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  15376. use HDF5, only : H5T_NATIVE_CHARACTER
  15377. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  15378. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  15379. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  15380. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  15381. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  15382. #endif
  15383. #ifdef with_netcdf
  15384. use NetCDF, only : NF90_Put_Var
  15385. #endif
  15386. ! --- in/out -------------------------------------
  15387. integer, intent(in) :: hid
  15388. integer, intent(in) :: varid
  15389. real(4), intent(in) :: values(:,:)
  15390. integer, intent(out) :: status
  15391. integer, intent(in), optional :: start (:)
  15392. integer, intent(in), optional :: count (:)
  15393. integer, intent(in), optional :: stride(:)
  15394. integer, intent(in), optional :: map (:)
  15395. ! --- const --------------------------------------
  15396. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_2d'
  15397. ! --- external -----------------------------------
  15398. #ifdef with_hdf4
  15399. integer(hdf4_wpi), external :: sfWData
  15400. #endif
  15401. ! --- local --------------------------------------
  15402. type(MDF_File), pointer :: filep
  15403. type(MDF_Var), pointer :: varp
  15404. integer :: iftype
  15405. integer :: ftype
  15406. #ifdef with_hdf4
  15407. integer :: hdf4_offset(MAX_RANK)
  15408. integer :: hdf4_stride(MAX_RANK)
  15409. integer :: hdf4_count(MAX_RANK)
  15410. #endif
  15411. #ifdef with_hdf5_beta
  15412. !integer(HID_T) :: hdf5_type_id
  15413. integer(HID_T) :: hdf5_file_space_id
  15414. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  15415. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  15416. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  15417. #endif
  15418. integer(1), allocatable :: values_int1(:,:)
  15419. integer(2), allocatable :: values_int2(:,:)
  15420. integer(4), allocatable :: values_int4(:,:)
  15421. integer(8), allocatable :: values_int8(:,:)
  15422. real(4), allocatable :: values_real4(:,:)
  15423. real(8), allocatable :: values_real8(:,:)
  15424. ! --- begin --------------------------------------
  15425. ! pointer to file structure:
  15426. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  15427. IF_NOT_OK_RETURN(status=1)
  15428. ! pointer to variable structure:
  15429. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  15430. IF_NOT_OK_RETURN(status=1)
  15431. ! check ...
  15432. if ( size(shape(values)) > varp%ndim ) then
  15433. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  15434. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  15435. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  15436. TRACEBACK; status=1; return
  15437. end if
  15438. ! check ...
  15439. if ( present(start ) ) then
  15440. if ( size(start ) /= varp%ndim ) then
  15441. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15442. write (gol,'(" size start : ",i6)') size(start ); call goErr
  15443. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15444. TRACEBACK; status=1; return
  15445. end if
  15446. end if
  15447. if ( present(count ) ) then
  15448. if ( size(count ) /= varp%ndim ) then
  15449. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15450. write (gol,'(" size count : ",i6)') size(count ); call goErr
  15451. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15452. TRACEBACK; status=1; return
  15453. end if
  15454. end if
  15455. if ( present(stride ) ) then
  15456. if ( size(stride ) /= varp%ndim ) then
  15457. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15458. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  15459. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15460. TRACEBACK; status=1; return
  15461. end if
  15462. end if
  15463. if ( present(map ) ) then
  15464. if ( size(map ) /= varp%ndim ) then
  15465. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15466. write (gol,'(" size map : ",i6)') size(map ); call goErr
  15467. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15468. TRACEBACK; status=1; return
  15469. end if
  15470. end if
  15471. ! loop over file types:
  15472. do iftype = 1, filep%nftype
  15473. ! current type:
  15474. ftype = filep%ftypes(iftype)
  15475. ! select appropriate routine for each type:
  15476. select case ( ftype )
  15477. #ifdef with_hdf4
  15478. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15479. case ( MDF_HDF4 )
  15480. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15481. ! check ...
  15482. if ( present(map ) ) then
  15483. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  15484. TRACEBACK; status=1; return
  15485. end if
  15486. ! fill offset (zero based!) and stride with default values:
  15487. hdf4_offset = 0
  15488. hdf4_stride = 1
  15489. ! count is by default the shape; padd with singleton dimensions:
  15490. hdf4_count = 1; hdf4_count(1:2) = shape(values)
  15491. ! replace by optional arguments if necessary:
  15492. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  15493. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  15494. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  15495. ! test target type;
  15496. ! convert to required kind before entering sfWData,
  15497. ! otherwise segmentation faults on some machines ...
  15498. select case ( varp%xtype )
  15499. case ( MDF_BYTE )
  15500. allocate( values_int1(size(values,1),size(values,2)) )
  15501. values_int1 = int(values,kind=1)
  15502. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15503. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  15504. deallocate( values_int1 )
  15505. case ( MDF_SHORT )
  15506. allocate( values_int2(size(values,1),size(values,2)) )
  15507. values_int2 = int(values,kind=2)
  15508. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15509. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  15510. deallocate( values_int2 )
  15511. case ( MDF_INT )
  15512. allocate( values_int4(size(values,1),size(values,2)) )
  15513. values_int4 = int(values,kind=4)
  15514. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15515. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  15516. deallocate( values_int4 )
  15517. case ( MDF_FLOAT )
  15518. allocate( values_real4(size(values,1),size(values,2)) )
  15519. values_real4 = real(values,kind=4)
  15520. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15521. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  15522. deallocate( values_real4 )
  15523. case ( MDF_DOUBLE )
  15524. allocate( values_real8(size(values,1),size(values,2)) )
  15525. values_real8 = real(values,kind=8)
  15526. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15527. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  15528. deallocate( values_real8 )
  15529. case default
  15530. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  15531. TRACEBACK; status=1; return
  15532. end select
  15533. if ( status == FAIL ) then
  15534. write (gol,'("writing hdf4 data set:")'); call goErr
  15535. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  15536. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  15537. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  15538. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  15539. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  15540. write (gol,'(" size : ",i12)') size(values); call goErr
  15541. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  15542. TRACEBACK; status=1; return
  15543. end if
  15544. #endif
  15545. #ifdef with_hdf5_beta
  15546. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15547. case ( MDF_HDF5 )
  15548. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15549. ! check ...
  15550. if ( present(map ) ) then
  15551. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  15552. TRACEBACK; status=1; return
  15553. end if
  15554. ! fill offset (zero based!), stride, and count :
  15555. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  15556. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  15557. hdf5_count = 1 ! default singleton dimension
  15558. if ( present(count) ) then
  15559. hdf5_count(1:varp%ndim) = count
  15560. else
  15561. hdf5_count(1:2) = shape(values)
  15562. end if
  15563. ! new dimension:
  15564. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  15565. ! target data space in file:
  15566. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  15567. IF_NOT_OK_RETURN(status=1)
  15568. ! chunked dataset ?
  15569. if ( varp%hdf5_chunked ) then
  15570. ! reset extend:
  15571. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  15572. IF_NOT_OK_RETURN(status=1)
  15573. end if
  15574. ! select hyperslab:
  15575. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  15576. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  15577. stride=hdf5_stride(1:varp%ndim) )
  15578. ! write data:
  15579. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  15580. int(shape(values),kind=HSIZE_T), status, &
  15581. file_space_id=hdf5_file_space_id )
  15582. IF_NOT_OK_RETURN(status=1)
  15583. ! release data space:
  15584. call H5SClose_f( hdf5_file_space_id, status )
  15585. IF_NOT_OK_RETURN(status=1)
  15586. #endif
  15587. #ifdef with_netcdf
  15588. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15589. case ( MDF_NETCDF, MDF_NETCDF4 )
  15590. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15591. ! test target type:
  15592. ! convert to required kind before entering NF90_Put_Var,
  15593. ! otherwise segmentation faults on some machines ...
  15594. select case ( varp%xtype )
  15595. case ( MDF_BYTE )
  15596. allocate( values_int1(size(values,1),size(values,2)) )
  15597. values_int1 = int(values,kind=1)
  15598. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  15599. start, count, stride, map )
  15600. IF_NF90_NOT_OK_RETURN(status=1)
  15601. deallocate( values_int1 )
  15602. case ( MDF_SHORT )
  15603. allocate( values_int2(size(values,1),size(values,2)) )
  15604. values_int2 = int(values,kind=2)
  15605. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  15606. start, count, stride, map )
  15607. IF_NF90_NOT_OK_RETURN(status=1)
  15608. deallocate( values_int2 )
  15609. case ( MDF_INT )
  15610. allocate( values_int4(size(values,1),size(values,2)) )
  15611. values_int4 = int(values,kind=4)
  15612. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  15613. start, count, stride, map )
  15614. IF_NF90_NOT_OK_RETURN(status=1)
  15615. deallocate( values_int4 )
  15616. case ( MDF_FLOAT )
  15617. allocate( values_real4(size(values,1),size(values,2)) )
  15618. values_real4 = real(values,kind=4)
  15619. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  15620. start, count, stride, map )
  15621. IF_NF90_NOT_OK_RETURN(status=1)
  15622. deallocate( values_real4 )
  15623. case ( MDF_DOUBLE )
  15624. allocate( values_real8(size(values,1),size(values,2)) )
  15625. values_real8 = real(values,kind=8)
  15626. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  15627. start, count, stride, map )
  15628. IF_NF90_NOT_OK_RETURN(status=1)
  15629. deallocate( values_real8 )
  15630. case default
  15631. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  15632. TRACEBACK; status=1; return
  15633. end select
  15634. ! just put; let netcdf library convert the right kind:
  15635. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  15636. ! start, count, stride, map )
  15637. !IF_NF90_NOT_OK_RETURN(status=1)
  15638. #endif
  15639. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15640. case default
  15641. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15642. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  15643. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  15644. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  15645. TRACEBACK; status=1; return
  15646. end select
  15647. end do ! file types
  15648. ! ok
  15649. status = 0
  15650. end subroutine MDF_Put_Var_r4_2d
  15651. ! ***
  15652. subroutine MDF_Get_Var_r4_2d( hid, varid, values, status, &
  15653. start, count, stride, map )
  15654. #ifdef with_netcdf
  15655. use NetCDF, only : NF90_Get_Var
  15656. #endif
  15657. ! --- in/out -------------------------------------
  15658. integer, intent(in) :: hid
  15659. integer, intent(in) :: varid
  15660. real(4), intent(out) :: values(:,:)
  15661. integer, intent(out) :: status
  15662. integer, intent(in), optional :: start (:)
  15663. integer, intent(in), optional :: count (:)
  15664. integer, intent(in), optional :: stride(:)
  15665. integer, intent(in), optional :: map (:)
  15666. ! --- const --------------------------------------
  15667. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_2d'
  15668. ! --- external -----------------------------------
  15669. #ifdef with_hdf4
  15670. integer(hdf4_wpi), external :: sfRData
  15671. #endif
  15672. ! --- local --------------------------------------
  15673. type(MDF_File), pointer :: filep
  15674. type(MDF_Var), pointer :: varp
  15675. integer :: iftype
  15676. integer :: ftype
  15677. #ifdef with_hdf4
  15678. integer :: hdf4_offset(MAX_RANK)
  15679. integer :: hdf4_stride(MAX_RANK)
  15680. integer :: hdf4_count(MAX_RANK)
  15681. integer(1), allocatable :: values_int1(:,:)
  15682. integer(2), allocatable :: values_int2(:,:)
  15683. integer(4), allocatable :: values_int4(:,:)
  15684. integer(8), allocatable :: values_int8(:,:)
  15685. real(4), allocatable :: values_real4(:,:)
  15686. real(8), allocatable :: values_real8(:,:)
  15687. #endif
  15688. ! --- begin --------------------------------------
  15689. ! pointer to file structure:
  15690. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  15691. IF_NOT_OK_RETURN(status=1)
  15692. ! pointer to variable structure:
  15693. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  15694. IF_NOT_OK_RETURN(status=1)
  15695. ! check ...
  15696. if ( size(shape(values)) > varp%ndim ) then
  15697. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  15698. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  15699. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  15700. TRACEBACK; status=1; return
  15701. end if
  15702. ! check ...
  15703. if ( present(start ) ) then
  15704. if ( size(start ) /= varp%ndim ) then
  15705. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15706. write (gol,'(" size start : ",i6)') size(start ); call goErr
  15707. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15708. TRACEBACK; status=1; return
  15709. end if
  15710. end if
  15711. if ( present(count ) ) then
  15712. if ( size(count ) /= varp%ndim ) then
  15713. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15714. write (gol,'(" size count : ",i6)') size(count ); call goErr
  15715. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15716. TRACEBACK; status=1; return
  15717. end if
  15718. end if
  15719. if ( present(stride ) ) then
  15720. if ( size(stride ) /= varp%ndim ) then
  15721. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15722. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  15723. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15724. TRACEBACK; status=1; return
  15725. end if
  15726. end if
  15727. if ( present(map ) ) then
  15728. if ( size(map ) /= varp%ndim ) then
  15729. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15730. write (gol,'(" size map : ",i6)') size(map ); call goErr
  15731. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15732. TRACEBACK; status=1; return
  15733. end if
  15734. end if
  15735. ! loop over file types:
  15736. do iftype = 1, filep%nftype
  15737. ! current type:
  15738. ftype = filep%ftypes(iftype)
  15739. ! select appropriate routine for each type:
  15740. select case ( ftype )
  15741. #ifdef with_hdf4
  15742. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15743. case ( MDF_HDF4 )
  15744. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15745. ! check ...
  15746. if ( present(map ) ) then
  15747. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  15748. TRACEBACK; status=1; return
  15749. end if
  15750. ! fill offset (zero based!), stride, and count :
  15751. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  15752. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  15753. hdf4_count = 1 ! default singleton dimension
  15754. hdf4_count(1:2) = shape(values)
  15755. ! test source type:
  15756. select case ( varp%hdf4_xtype )
  15757. case ( DFNT_INT8 )
  15758. allocate( values_int1(size(values,1),size(values,2)) )
  15759. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  15760. values = real(values_int1,kind=4)
  15761. deallocate( values_int1 )
  15762. case ( DFNT_INT16 )
  15763. allocate( values_int2(size(values,1),size(values,2)) )
  15764. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  15765. values = real(values_int2,kind=4)
  15766. deallocate( values_int2 )
  15767. case ( DFNT_INT32 )
  15768. allocate( values_int4(size(values,1),size(values,2)) )
  15769. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  15770. values = real(values_int4,kind=4)
  15771. deallocate( values_int4 )
  15772. case ( DFNT_INT64 )
  15773. allocate( values_int8(size(values,1),size(values,2)) )
  15774. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  15775. values = real(values_int8,kind=4)
  15776. deallocate( values_int8 )
  15777. case ( DFNT_FLOAT32 )
  15778. allocate( values_real4(size(values,1),size(values,2)) )
  15779. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  15780. values = real(values_real4,kind=4)
  15781. deallocate( values_real4 )
  15782. case ( DFNT_FLOAT64 )
  15783. allocate( values_real8(size(values,1),size(values,2)) )
  15784. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  15785. values = real(values_real8,kind=4)
  15786. deallocate( values_real8 )
  15787. case default
  15788. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  15789. TRACEBACK; status=1; return
  15790. end select
  15791. if ( status == FAIL ) then
  15792. write (gol,'("reading hdf4 data set:")'); call goErr
  15793. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  15794. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  15795. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  15796. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  15797. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  15798. write (gol,'(" size : ",i6)') size(values); call goErr
  15799. TRACEBACK; status=1; return
  15800. end if
  15801. #endif
  15802. #ifdef with_netcdf
  15803. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15804. case ( MDF_NETCDF, MDF_NETCDF4 )
  15805. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15806. ! read values, converted automatically:
  15807. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  15808. start, count, stride, map )
  15809. IF_NF90_NOT_OK_RETURN(status=1)
  15810. #endif
  15811. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15812. case default
  15813. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15814. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  15815. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  15816. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  15817. TRACEBACK; status=1; return
  15818. end select
  15819. end do ! file types
  15820. ! ok
  15821. status = 0
  15822. end subroutine MDF_Get_Var_r4_2d
  15823. ! ***
  15824. subroutine MDF_Put_Var_r4_3d( hid, varid, values, status, &
  15825. start, count, stride, map )
  15826. #ifdef with_hdf5_beta
  15827. use HDF5, only : HID_T, HSIZE_T
  15828. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  15829. use HDF5, only : H5T_NATIVE_CHARACTER
  15830. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  15831. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  15832. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  15833. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  15834. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  15835. #endif
  15836. #ifdef with_netcdf
  15837. use NetCDF, only : NF90_Put_Var
  15838. #endif
  15839. ! --- in/out -------------------------------------
  15840. integer, intent(in) :: hid
  15841. integer, intent(in) :: varid
  15842. real(4), intent(in) :: values(:,:,:)
  15843. integer, intent(out) :: status
  15844. integer, intent(in), optional :: start (:)
  15845. integer, intent(in), optional :: count (:)
  15846. integer, intent(in), optional :: stride(:)
  15847. integer, intent(in), optional :: map (:)
  15848. ! --- const --------------------------------------
  15849. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_3d'
  15850. ! --- external -----------------------------------
  15851. #ifdef with_hdf4
  15852. integer(hdf4_wpi), external :: sfWData
  15853. #endif
  15854. ! --- local --------------------------------------
  15855. type(MDF_File), pointer :: filep
  15856. type(MDF_Var), pointer :: varp
  15857. integer :: iftype
  15858. integer :: ftype
  15859. #ifdef with_hdf4
  15860. integer :: hdf4_offset(MAX_RANK)
  15861. integer :: hdf4_stride(MAX_RANK)
  15862. integer :: hdf4_count(MAX_RANK)
  15863. #endif
  15864. #ifdef with_hdf5_beta
  15865. !integer(HID_T) :: hdf5_type_id
  15866. integer(HID_T) :: hdf5_file_space_id
  15867. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  15868. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  15869. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  15870. #endif
  15871. integer(1), allocatable :: values_int1(:,:,:)
  15872. integer(2), allocatable :: values_int2(:,:,:)
  15873. integer(4), allocatable :: values_int4(:,:,:)
  15874. integer(8), allocatable :: values_int8(:,:,:)
  15875. real(4), allocatable :: values_real4(:,:,:)
  15876. real(8), allocatable :: values_real8(:,:,:)
  15877. ! --- begin --------------------------------------
  15878. ! pointer to file structure:
  15879. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  15880. IF_NOT_OK_RETURN(status=1)
  15881. ! pointer to variable structure:
  15882. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  15883. IF_NOT_OK_RETURN(status=1)
  15884. ! check ...
  15885. if ( size(shape(values)) > varp%ndim ) then
  15886. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  15887. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  15888. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  15889. TRACEBACK; status=1; return
  15890. end if
  15891. ! check ...
  15892. if ( present(start ) ) then
  15893. if ( size(start ) /= varp%ndim ) then
  15894. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15895. write (gol,'(" size start : ",i6)') size(start ); call goErr
  15896. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15897. TRACEBACK; status=1; return
  15898. end if
  15899. end if
  15900. if ( present(count ) ) then
  15901. if ( size(count ) /= varp%ndim ) then
  15902. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15903. write (gol,'(" size count : ",i6)') size(count ); call goErr
  15904. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15905. TRACEBACK; status=1; return
  15906. end if
  15907. end if
  15908. if ( present(stride ) ) then
  15909. if ( size(stride ) /= varp%ndim ) then
  15910. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15911. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  15912. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15913. TRACEBACK; status=1; return
  15914. end if
  15915. end if
  15916. if ( present(map ) ) then
  15917. if ( size(map ) /= varp%ndim ) then
  15918. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  15919. write (gol,'(" size map : ",i6)') size(map ); call goErr
  15920. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  15921. TRACEBACK; status=1; return
  15922. end if
  15923. end if
  15924. ! loop over file types:
  15925. do iftype = 1, filep%nftype
  15926. ! current type:
  15927. ftype = filep%ftypes(iftype)
  15928. ! select appropriate routine for each type:
  15929. select case ( ftype )
  15930. #ifdef with_hdf4
  15931. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15932. case ( MDF_HDF4 )
  15933. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  15934. ! check ...
  15935. if ( present(map ) ) then
  15936. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  15937. TRACEBACK; status=1; return
  15938. end if
  15939. ! fill offset (zero based!) and stride with default values:
  15940. hdf4_offset = 0
  15941. hdf4_stride = 1
  15942. ! count is by default the shape; padd with singleton dimensions:
  15943. hdf4_count = 1; hdf4_count(1:3) = shape(values)
  15944. ! replace by optional arguments if necessary:
  15945. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  15946. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  15947. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  15948. ! test target type;
  15949. ! convert to required kind before entering sfWData,
  15950. ! otherwise segmentation faults on some machines ...
  15951. select case ( varp%xtype )
  15952. case ( MDF_BYTE )
  15953. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  15954. values_int1 = int(values,kind=1)
  15955. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15956. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  15957. deallocate( values_int1 )
  15958. case ( MDF_SHORT )
  15959. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  15960. values_int2 = int(values,kind=2)
  15961. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15962. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  15963. deallocate( values_int2 )
  15964. case ( MDF_INT )
  15965. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  15966. values_int4 = int(values,kind=4)
  15967. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15968. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  15969. deallocate( values_int4 )
  15970. case ( MDF_FLOAT )
  15971. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  15972. values_real4 = real(values,kind=4)
  15973. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15974. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  15975. deallocate( values_real4 )
  15976. case ( MDF_DOUBLE )
  15977. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  15978. values_real8 = real(values,kind=8)
  15979. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  15980. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  15981. deallocate( values_real8 )
  15982. case default
  15983. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  15984. TRACEBACK; status=1; return
  15985. end select
  15986. if ( status == FAIL ) then
  15987. write (gol,'("writing hdf4 data set:")'); call goErr
  15988. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  15989. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  15990. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  15991. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  15992. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  15993. write (gol,'(" size : ",i12)') size(values); call goErr
  15994. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  15995. TRACEBACK; status=1; return
  15996. end if
  15997. #endif
  15998. #ifdef with_hdf5_beta
  15999. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16000. case ( MDF_HDF5 )
  16001. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16002. ! check ...
  16003. if ( present(map ) ) then
  16004. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  16005. TRACEBACK; status=1; return
  16006. end if
  16007. ! fill offset (zero based!), stride, and count :
  16008. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  16009. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  16010. hdf5_count = 1 ! default singleton dimension
  16011. if ( present(count) ) then
  16012. hdf5_count(1:varp%ndim) = count
  16013. else
  16014. hdf5_count(1:3) = shape(values)
  16015. end if
  16016. ! new dimension:
  16017. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  16018. ! target data space in file:
  16019. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  16020. IF_NOT_OK_RETURN(status=1)
  16021. ! chunked dataset ?
  16022. if ( varp%hdf5_chunked ) then
  16023. ! reset extend:
  16024. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  16025. IF_NOT_OK_RETURN(status=1)
  16026. end if
  16027. ! select hyperslab:
  16028. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  16029. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  16030. stride=hdf5_stride(1:varp%ndim) )
  16031. ! write data:
  16032. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  16033. int(shape(values),kind=HSIZE_T), status, &
  16034. file_space_id=hdf5_file_space_id )
  16035. IF_NOT_OK_RETURN(status=1)
  16036. ! release data space:
  16037. call H5SClose_f( hdf5_file_space_id, status )
  16038. IF_NOT_OK_RETURN(status=1)
  16039. #endif
  16040. #ifdef with_netcdf
  16041. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16042. case ( MDF_NETCDF, MDF_NETCDF4 )
  16043. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16044. ! test target type:
  16045. ! convert to required kind before entering NF90_Put_Var,
  16046. ! otherwise segmentation faults on some machines ...
  16047. select case ( varp%xtype )
  16048. case ( MDF_BYTE )
  16049. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  16050. values_int1 = int(values,kind=1)
  16051. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  16052. start, count, stride, map )
  16053. IF_NF90_NOT_OK_RETURN(status=1)
  16054. deallocate( values_int1 )
  16055. case ( MDF_SHORT )
  16056. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  16057. values_int2 = int(values,kind=2)
  16058. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  16059. start, count, stride, map )
  16060. IF_NF90_NOT_OK_RETURN(status=1)
  16061. deallocate( values_int2 )
  16062. case ( MDF_INT )
  16063. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  16064. values_int4 = int(values,kind=4)
  16065. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  16066. start, count, stride, map )
  16067. IF_NF90_NOT_OK_RETURN(status=1)
  16068. deallocate( values_int4 )
  16069. case ( MDF_FLOAT )
  16070. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  16071. values_real4 = real(values,kind=4)
  16072. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  16073. start, count, stride, map )
  16074. IF_NF90_NOT_OK_RETURN(status=1)
  16075. deallocate( values_real4 )
  16076. case ( MDF_DOUBLE )
  16077. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  16078. values_real8 = real(values,kind=8)
  16079. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  16080. start, count, stride, map )
  16081. IF_NF90_NOT_OK_RETURN(status=1)
  16082. deallocate( values_real8 )
  16083. case default
  16084. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  16085. TRACEBACK; status=1; return
  16086. end select
  16087. ! just put; let netcdf library convert the right kind:
  16088. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  16089. ! start, count, stride, map )
  16090. !IF_NF90_NOT_OK_RETURN(status=1)
  16091. #endif
  16092. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16093. case default
  16094. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16095. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  16096. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  16097. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  16098. TRACEBACK; status=1; return
  16099. end select
  16100. end do ! file types
  16101. ! ok
  16102. status = 0
  16103. end subroutine MDF_Put_Var_r4_3d
  16104. ! ***
  16105. subroutine MDF_Get_Var_r4_3d( hid, varid, values, status, &
  16106. start, count, stride, map )
  16107. #ifdef with_netcdf
  16108. use NetCDF, only : NF90_Get_Var
  16109. #endif
  16110. ! --- in/out -------------------------------------
  16111. integer, intent(in) :: hid
  16112. integer, intent(in) :: varid
  16113. real(4), intent(out) :: values(:,:,:)
  16114. integer, intent(out) :: status
  16115. integer, intent(in), optional :: start (:)
  16116. integer, intent(in), optional :: count (:)
  16117. integer, intent(in), optional :: stride(:)
  16118. integer, intent(in), optional :: map (:)
  16119. ! --- const --------------------------------------
  16120. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_3d'
  16121. ! --- external -----------------------------------
  16122. #ifdef with_hdf4
  16123. integer(hdf4_wpi), external :: sfRData
  16124. #endif
  16125. ! --- local --------------------------------------
  16126. type(MDF_File), pointer :: filep
  16127. type(MDF_Var), pointer :: varp
  16128. integer :: iftype
  16129. integer :: ftype
  16130. #ifdef with_hdf4
  16131. integer :: hdf4_offset(MAX_RANK)
  16132. integer :: hdf4_stride(MAX_RANK)
  16133. integer :: hdf4_count(MAX_RANK)
  16134. integer(1), allocatable :: values_int1(:,:,:)
  16135. integer(2), allocatable :: values_int2(:,:,:)
  16136. integer(4), allocatable :: values_int4(:,:,:)
  16137. integer(8), allocatable :: values_int8(:,:,:)
  16138. real(4), allocatable :: values_real4(:,:,:)
  16139. real(8), allocatable :: values_real8(:,:,:)
  16140. #endif
  16141. ! --- begin --------------------------------------
  16142. ! pointer to file structure:
  16143. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  16144. IF_NOT_OK_RETURN(status=1)
  16145. ! pointer to variable structure:
  16146. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  16147. IF_NOT_OK_RETURN(status=1)
  16148. ! check ...
  16149. if ( size(shape(values)) > varp%ndim ) then
  16150. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  16151. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  16152. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  16153. TRACEBACK; status=1; return
  16154. end if
  16155. ! check ...
  16156. if ( present(start ) ) then
  16157. if ( size(start ) /= varp%ndim ) then
  16158. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16159. write (gol,'(" size start : ",i6)') size(start ); call goErr
  16160. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16161. TRACEBACK; status=1; return
  16162. end if
  16163. end if
  16164. if ( present(count ) ) then
  16165. if ( size(count ) /= varp%ndim ) then
  16166. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16167. write (gol,'(" size count : ",i6)') size(count ); call goErr
  16168. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16169. TRACEBACK; status=1; return
  16170. end if
  16171. end if
  16172. if ( present(stride ) ) then
  16173. if ( size(stride ) /= varp%ndim ) then
  16174. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16175. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  16176. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16177. TRACEBACK; status=1; return
  16178. end if
  16179. end if
  16180. if ( present(map ) ) then
  16181. if ( size(map ) /= varp%ndim ) then
  16182. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16183. write (gol,'(" size map : ",i6)') size(map ); call goErr
  16184. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16185. TRACEBACK; status=1; return
  16186. end if
  16187. end if
  16188. ! loop over file types:
  16189. do iftype = 1, filep%nftype
  16190. ! current type:
  16191. ftype = filep%ftypes(iftype)
  16192. ! select appropriate routine for each type:
  16193. select case ( ftype )
  16194. #ifdef with_hdf4
  16195. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16196. case ( MDF_HDF4 )
  16197. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16198. ! check ...
  16199. if ( present(map ) ) then
  16200. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  16201. TRACEBACK; status=1; return
  16202. end if
  16203. ! fill offset (zero based!), stride, and count :
  16204. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  16205. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  16206. hdf4_count = 1 ! default singleton dimension
  16207. hdf4_count(1:3) = shape(values)
  16208. ! test source type:
  16209. select case ( varp%hdf4_xtype )
  16210. case ( DFNT_INT8 )
  16211. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  16212. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  16213. values = real(values_int1,kind=4)
  16214. deallocate( values_int1 )
  16215. case ( DFNT_INT16 )
  16216. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  16217. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  16218. values = real(values_int2,kind=4)
  16219. deallocate( values_int2 )
  16220. case ( DFNT_INT32 )
  16221. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  16222. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  16223. values = real(values_int4,kind=4)
  16224. deallocate( values_int4 )
  16225. case ( DFNT_INT64 )
  16226. allocate( values_int8(size(values,1),size(values,2),size(values,3)) )
  16227. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  16228. values = real(values_int8,kind=4)
  16229. deallocate( values_int8 )
  16230. case ( DFNT_FLOAT32 )
  16231. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  16232. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  16233. values = real(values_real4,kind=4)
  16234. deallocate( values_real4 )
  16235. case ( DFNT_FLOAT64 )
  16236. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  16237. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  16238. values = real(values_real8,kind=4)
  16239. deallocate( values_real8 )
  16240. case default
  16241. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  16242. TRACEBACK; status=1; return
  16243. end select
  16244. if ( status == FAIL ) then
  16245. write (gol,'("reading hdf4 data set:")'); call goErr
  16246. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  16247. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  16248. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  16249. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  16250. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  16251. write (gol,'(" size : ",i6)') size(values); call goErr
  16252. TRACEBACK; status=1; return
  16253. end if
  16254. #endif
  16255. #ifdef with_netcdf
  16256. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16257. case ( MDF_NETCDF, MDF_NETCDF4 )
  16258. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16259. ! read values, converted automatically:
  16260. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  16261. start, count, stride, map )
  16262. IF_NF90_NOT_OK_RETURN(status=1)
  16263. #endif
  16264. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16265. case default
  16266. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16267. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  16268. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  16269. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  16270. TRACEBACK; status=1; return
  16271. end select
  16272. end do ! file types
  16273. ! ok
  16274. status = 0
  16275. end subroutine MDF_Get_Var_r4_3d
  16276. ! ***
  16277. subroutine MDF_Put_Var_r4_4d( hid, varid, values, status, &
  16278. start, count, stride, map )
  16279. #ifdef with_hdf5_beta
  16280. use HDF5, only : HID_T, HSIZE_T
  16281. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  16282. use HDF5, only : H5T_NATIVE_CHARACTER
  16283. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  16284. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  16285. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  16286. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  16287. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  16288. #endif
  16289. #ifdef with_netcdf
  16290. use NetCDF, only : NF90_Put_Var
  16291. #endif
  16292. ! --- in/out -------------------------------------
  16293. integer, intent(in) :: hid
  16294. integer, intent(in) :: varid
  16295. real(4), intent(in) :: values(:,:,:,:)
  16296. integer, intent(out) :: status
  16297. integer, intent(in), optional :: start (:)
  16298. integer, intent(in), optional :: count (:)
  16299. integer, intent(in), optional :: stride(:)
  16300. integer, intent(in), optional :: map (:)
  16301. ! --- const --------------------------------------
  16302. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_4d'
  16303. ! --- external -----------------------------------
  16304. #ifdef with_hdf4
  16305. integer(hdf4_wpi), external :: sfWData
  16306. #endif
  16307. ! --- local --------------------------------------
  16308. type(MDF_File), pointer :: filep
  16309. type(MDF_Var), pointer :: varp
  16310. integer :: iftype
  16311. integer :: ftype
  16312. #ifdef with_hdf4
  16313. integer :: hdf4_offset(MAX_RANK)
  16314. integer :: hdf4_stride(MAX_RANK)
  16315. integer :: hdf4_count(MAX_RANK)
  16316. #endif
  16317. #ifdef with_hdf5_beta
  16318. !integer(HID_T) :: hdf5_type_id
  16319. integer(HID_T) :: hdf5_file_space_id
  16320. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  16321. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  16322. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  16323. #endif
  16324. integer(1), allocatable :: values_int1(:,:,:,:)
  16325. integer(2), allocatable :: values_int2(:,:,:,:)
  16326. integer(4), allocatable :: values_int4(:,:,:,:)
  16327. integer(8), allocatable :: values_int8(:,:,:,:)
  16328. real(4), allocatable :: values_real4(:,:,:,:)
  16329. real(8), allocatable :: values_real8(:,:,:,:)
  16330. ! --- begin --------------------------------------
  16331. ! pointer to file structure:
  16332. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  16333. IF_NOT_OK_RETURN(status=1)
  16334. ! pointer to variable structure:
  16335. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  16336. IF_NOT_OK_RETURN(status=1)
  16337. ! check ...
  16338. if ( size(shape(values)) > varp%ndim ) then
  16339. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  16340. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  16341. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  16342. TRACEBACK; status=1; return
  16343. end if
  16344. ! check ...
  16345. if ( present(start ) ) then
  16346. if ( size(start ) /= varp%ndim ) then
  16347. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16348. write (gol,'(" size start : ",i6)') size(start ); call goErr
  16349. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16350. TRACEBACK; status=1; return
  16351. end if
  16352. end if
  16353. if ( present(count ) ) then
  16354. if ( size(count ) /= varp%ndim ) then
  16355. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16356. write (gol,'(" size count : ",i6)') size(count ); call goErr
  16357. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16358. TRACEBACK; status=1; return
  16359. end if
  16360. end if
  16361. if ( present(stride ) ) then
  16362. if ( size(stride ) /= varp%ndim ) then
  16363. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16364. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  16365. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16366. TRACEBACK; status=1; return
  16367. end if
  16368. end if
  16369. if ( present(map ) ) then
  16370. if ( size(map ) /= varp%ndim ) then
  16371. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16372. write (gol,'(" size map : ",i6)') size(map ); call goErr
  16373. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16374. TRACEBACK; status=1; return
  16375. end if
  16376. end if
  16377. ! loop over file types:
  16378. do iftype = 1, filep%nftype
  16379. ! current type:
  16380. ftype = filep%ftypes(iftype)
  16381. ! select appropriate routine for each type:
  16382. select case ( ftype )
  16383. #ifdef with_hdf4
  16384. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16385. case ( MDF_HDF4 )
  16386. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16387. ! check ...
  16388. if ( present(map ) ) then
  16389. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  16390. TRACEBACK; status=1; return
  16391. end if
  16392. ! fill offset (zero based!) and stride with default values:
  16393. hdf4_offset = 0
  16394. hdf4_stride = 1
  16395. ! count is by default the shape; padd with singleton dimensions:
  16396. hdf4_count = 1; hdf4_count(1:4) = shape(values)
  16397. ! replace by optional arguments if necessary:
  16398. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  16399. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  16400. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  16401. ! test target type;
  16402. ! convert to required kind before entering sfWData,
  16403. ! otherwise segmentation faults on some machines ...
  16404. select case ( varp%xtype )
  16405. case ( MDF_BYTE )
  16406. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16407. values_int1 = int(values,kind=1)
  16408. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16409. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  16410. deallocate( values_int1 )
  16411. case ( MDF_SHORT )
  16412. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16413. values_int2 = int(values,kind=2)
  16414. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16415. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  16416. deallocate( values_int2 )
  16417. case ( MDF_INT )
  16418. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16419. values_int4 = int(values,kind=4)
  16420. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16421. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  16422. deallocate( values_int4 )
  16423. case ( MDF_FLOAT )
  16424. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16425. values_real4 = real(values,kind=4)
  16426. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16427. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  16428. deallocate( values_real4 )
  16429. case ( MDF_DOUBLE )
  16430. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16431. values_real8 = real(values,kind=8)
  16432. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16433. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  16434. deallocate( values_real8 )
  16435. case default
  16436. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  16437. TRACEBACK; status=1; return
  16438. end select
  16439. if ( status == FAIL ) then
  16440. write (gol,'("writing hdf4 data set:")'); call goErr
  16441. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  16442. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  16443. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  16444. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  16445. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  16446. write (gol,'(" size : ",i12)') size(values); call goErr
  16447. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  16448. TRACEBACK; status=1; return
  16449. end if
  16450. #endif
  16451. #ifdef with_hdf5_beta
  16452. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16453. case ( MDF_HDF5 )
  16454. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16455. ! check ...
  16456. if ( present(map ) ) then
  16457. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  16458. TRACEBACK; status=1; return
  16459. end if
  16460. ! fill offset (zero based!), stride, and count :
  16461. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  16462. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  16463. hdf5_count = 1 ! default singleton dimension
  16464. if ( present(count) ) then
  16465. hdf5_count(1:varp%ndim) = count
  16466. else
  16467. hdf5_count(1:4) = shape(values)
  16468. end if
  16469. ! new dimension:
  16470. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  16471. ! target data space in file:
  16472. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  16473. IF_NOT_OK_RETURN(status=1)
  16474. ! chunked dataset ?
  16475. if ( varp%hdf5_chunked ) then
  16476. ! reset extend:
  16477. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  16478. IF_NOT_OK_RETURN(status=1)
  16479. end if
  16480. ! select hyperslab:
  16481. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  16482. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  16483. stride=hdf5_stride(1:varp%ndim) )
  16484. ! write data:
  16485. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  16486. int(shape(values),kind=HSIZE_T), status, &
  16487. file_space_id=hdf5_file_space_id )
  16488. IF_NOT_OK_RETURN(status=1)
  16489. ! release data space:
  16490. call H5SClose_f( hdf5_file_space_id, status )
  16491. IF_NOT_OK_RETURN(status=1)
  16492. #endif
  16493. #ifdef with_netcdf
  16494. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16495. case ( MDF_NETCDF, MDF_NETCDF4 )
  16496. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16497. ! test target type:
  16498. ! convert to required kind before entering NF90_Put_Var,
  16499. ! otherwise segmentation faults on some machines ...
  16500. select case ( varp%xtype )
  16501. case ( MDF_BYTE )
  16502. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16503. values_int1 = int(values,kind=1)
  16504. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  16505. start, count, stride, map )
  16506. IF_NF90_NOT_OK_RETURN(status=1)
  16507. deallocate( values_int1 )
  16508. case ( MDF_SHORT )
  16509. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16510. values_int2 = int(values,kind=2)
  16511. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  16512. start, count, stride, map )
  16513. IF_NF90_NOT_OK_RETURN(status=1)
  16514. deallocate( values_int2 )
  16515. case ( MDF_INT )
  16516. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16517. values_int4 = int(values,kind=4)
  16518. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  16519. start, count, stride, map )
  16520. IF_NF90_NOT_OK_RETURN(status=1)
  16521. deallocate( values_int4 )
  16522. case ( MDF_FLOAT )
  16523. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16524. values_real4 = real(values,kind=4)
  16525. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  16526. start, count, stride, map )
  16527. IF_NF90_NOT_OK_RETURN(status=1)
  16528. deallocate( values_real4 )
  16529. case ( MDF_DOUBLE )
  16530. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16531. values_real8 = real(values,kind=8)
  16532. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  16533. start, count, stride, map )
  16534. IF_NF90_NOT_OK_RETURN(status=1)
  16535. deallocate( values_real8 )
  16536. case default
  16537. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  16538. TRACEBACK; status=1; return
  16539. end select
  16540. ! just put; let netcdf library convert the right kind:
  16541. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  16542. ! start, count, stride, map )
  16543. !IF_NF90_NOT_OK_RETURN(status=1)
  16544. #endif
  16545. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16546. case default
  16547. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16548. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  16549. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  16550. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  16551. TRACEBACK; status=1; return
  16552. end select
  16553. end do ! file types
  16554. ! ok
  16555. status = 0
  16556. end subroutine MDF_Put_Var_r4_4d
  16557. ! ***
  16558. subroutine MDF_Get_Var_r4_4d( hid, varid, values, status, &
  16559. start, count, stride, map )
  16560. #ifdef with_netcdf
  16561. use NetCDF, only : NF90_Get_Var
  16562. #endif
  16563. ! --- in/out -------------------------------------
  16564. integer, intent(in) :: hid
  16565. integer, intent(in) :: varid
  16566. real(4), intent(out) :: values(:,:,:,:)
  16567. integer, intent(out) :: status
  16568. integer, intent(in), optional :: start (:)
  16569. integer, intent(in), optional :: count (:)
  16570. integer, intent(in), optional :: stride(:)
  16571. integer, intent(in), optional :: map (:)
  16572. ! --- const --------------------------------------
  16573. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_4d'
  16574. ! --- external -----------------------------------
  16575. #ifdef with_hdf4
  16576. integer(hdf4_wpi), external :: sfRData
  16577. #endif
  16578. ! --- local --------------------------------------
  16579. type(MDF_File), pointer :: filep
  16580. type(MDF_Var), pointer :: varp
  16581. integer :: iftype
  16582. integer :: ftype
  16583. #ifdef with_hdf4
  16584. integer :: hdf4_offset(MAX_RANK)
  16585. integer :: hdf4_stride(MAX_RANK)
  16586. integer :: hdf4_count(MAX_RANK)
  16587. integer(1), allocatable :: values_int1(:,:,:,:)
  16588. integer(2), allocatable :: values_int2(:,:,:,:)
  16589. integer(4), allocatable :: values_int4(:,:,:,:)
  16590. integer(8), allocatable :: values_int8(:,:,:,:)
  16591. real(4), allocatable :: values_real4(:,:,:,:)
  16592. real(8), allocatable :: values_real8(:,:,:,:)
  16593. #endif
  16594. ! --- begin --------------------------------------
  16595. ! pointer to file structure:
  16596. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  16597. IF_NOT_OK_RETURN(status=1)
  16598. ! pointer to variable structure:
  16599. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  16600. IF_NOT_OK_RETURN(status=1)
  16601. ! check ...
  16602. if ( size(shape(values)) > varp%ndim ) then
  16603. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  16604. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  16605. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  16606. TRACEBACK; status=1; return
  16607. end if
  16608. ! check ...
  16609. if ( present(start ) ) then
  16610. if ( size(start ) /= varp%ndim ) then
  16611. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16612. write (gol,'(" size start : ",i6)') size(start ); call goErr
  16613. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16614. TRACEBACK; status=1; return
  16615. end if
  16616. end if
  16617. if ( present(count ) ) then
  16618. if ( size(count ) /= varp%ndim ) then
  16619. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16620. write (gol,'(" size count : ",i6)') size(count ); call goErr
  16621. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16622. TRACEBACK; status=1; return
  16623. end if
  16624. end if
  16625. if ( present(stride ) ) then
  16626. if ( size(stride ) /= varp%ndim ) then
  16627. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16628. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  16629. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16630. TRACEBACK; status=1; return
  16631. end if
  16632. end if
  16633. if ( present(map ) ) then
  16634. if ( size(map ) /= varp%ndim ) then
  16635. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16636. write (gol,'(" size map : ",i6)') size(map ); call goErr
  16637. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16638. TRACEBACK; status=1; return
  16639. end if
  16640. end if
  16641. ! loop over file types:
  16642. do iftype = 1, filep%nftype
  16643. ! current type:
  16644. ftype = filep%ftypes(iftype)
  16645. ! select appropriate routine for each type:
  16646. select case ( ftype )
  16647. #ifdef with_hdf4
  16648. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16649. case ( MDF_HDF4 )
  16650. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16651. ! check ...
  16652. if ( present(map ) ) then
  16653. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  16654. TRACEBACK; status=1; return
  16655. end if
  16656. ! fill offset (zero based!), stride, and count :
  16657. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  16658. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  16659. hdf4_count = 1 ! default singleton dimension
  16660. hdf4_count(1:4) = shape(values)
  16661. ! test source type:
  16662. select case ( varp%hdf4_xtype )
  16663. case ( DFNT_INT8 )
  16664. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16665. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  16666. values = real(values_int1,kind=4)
  16667. deallocate( values_int1 )
  16668. case ( DFNT_INT16 )
  16669. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16670. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  16671. values = real(values_int2,kind=4)
  16672. deallocate( values_int2 )
  16673. case ( DFNT_INT32 )
  16674. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16675. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  16676. values = real(values_int4,kind=4)
  16677. deallocate( values_int4 )
  16678. case ( DFNT_INT64 )
  16679. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16680. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  16681. values = real(values_int8,kind=4)
  16682. deallocate( values_int8 )
  16683. case ( DFNT_FLOAT32 )
  16684. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16685. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  16686. values = real(values_real4,kind=4)
  16687. deallocate( values_real4 )
  16688. case ( DFNT_FLOAT64 )
  16689. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  16690. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  16691. values = real(values_real8,kind=4)
  16692. deallocate( values_real8 )
  16693. case default
  16694. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  16695. TRACEBACK; status=1; return
  16696. end select
  16697. if ( status == FAIL ) then
  16698. write (gol,'("reading hdf4 data set:")'); call goErr
  16699. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  16700. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  16701. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  16702. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  16703. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  16704. write (gol,'(" size : ",i6)') size(values); call goErr
  16705. TRACEBACK; status=1; return
  16706. end if
  16707. #endif
  16708. #ifdef with_netcdf
  16709. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16710. case ( MDF_NETCDF, MDF_NETCDF4 )
  16711. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16712. ! read values, converted automatically:
  16713. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  16714. start, count, stride, map )
  16715. IF_NF90_NOT_OK_RETURN(status=1)
  16716. #endif
  16717. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16718. case default
  16719. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16720. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  16721. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  16722. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  16723. TRACEBACK; status=1; return
  16724. end select
  16725. end do ! file types
  16726. ! ok
  16727. status = 0
  16728. end subroutine MDF_Get_Var_r4_4d
  16729. ! ***
  16730. subroutine MDF_Put_Var_r4_5d( hid, varid, values, status, &
  16731. start, count, stride, map )
  16732. #ifdef with_hdf5_beta
  16733. use HDF5, only : HID_T, HSIZE_T
  16734. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  16735. use HDF5, only : H5T_NATIVE_CHARACTER
  16736. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  16737. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  16738. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  16739. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  16740. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  16741. #endif
  16742. #ifdef with_netcdf
  16743. use NetCDF, only : NF90_Put_Var
  16744. #endif
  16745. ! --- in/out -------------------------------------
  16746. integer, intent(in) :: hid
  16747. integer, intent(in) :: varid
  16748. real(4), intent(in) :: values(:,:,:,:,:)
  16749. integer, intent(out) :: status
  16750. integer, intent(in), optional :: start (:)
  16751. integer, intent(in), optional :: count (:)
  16752. integer, intent(in), optional :: stride(:)
  16753. integer, intent(in), optional :: map (:)
  16754. ! --- const --------------------------------------
  16755. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_5d'
  16756. ! --- external -----------------------------------
  16757. #ifdef with_hdf4
  16758. integer(hdf4_wpi), external :: sfWData
  16759. #endif
  16760. ! --- local --------------------------------------
  16761. type(MDF_File), pointer :: filep
  16762. type(MDF_Var), pointer :: varp
  16763. integer :: iftype
  16764. integer :: ftype
  16765. #ifdef with_hdf4
  16766. integer :: hdf4_offset(MAX_RANK)
  16767. integer :: hdf4_stride(MAX_RANK)
  16768. integer :: hdf4_count(MAX_RANK)
  16769. #endif
  16770. #ifdef with_hdf5_beta
  16771. !integer(HID_T) :: hdf5_type_id
  16772. integer(HID_T) :: hdf5_file_space_id
  16773. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  16774. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  16775. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  16776. #endif
  16777. integer(1), allocatable :: values_int1(:,:,:,:,:)
  16778. integer(2), allocatable :: values_int2(:,:,:,:,:)
  16779. integer(4), allocatable :: values_int4(:,:,:,:,:)
  16780. integer(8), allocatable :: values_int8(:,:,:,:,:)
  16781. real(4), allocatable :: values_real4(:,:,:,:,:)
  16782. real(8), allocatable :: values_real8(:,:,:,:,:)
  16783. ! --- begin --------------------------------------
  16784. ! pointer to file structure:
  16785. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  16786. IF_NOT_OK_RETURN(status=1)
  16787. ! pointer to variable structure:
  16788. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  16789. IF_NOT_OK_RETURN(status=1)
  16790. ! check ...
  16791. if ( size(shape(values)) > varp%ndim ) then
  16792. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  16793. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  16794. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  16795. TRACEBACK; status=1; return
  16796. end if
  16797. ! check ...
  16798. if ( present(start ) ) then
  16799. if ( size(start ) /= varp%ndim ) then
  16800. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16801. write (gol,'(" size start : ",i6)') size(start ); call goErr
  16802. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16803. TRACEBACK; status=1; return
  16804. end if
  16805. end if
  16806. if ( present(count ) ) then
  16807. if ( size(count ) /= varp%ndim ) then
  16808. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16809. write (gol,'(" size count : ",i6)') size(count ); call goErr
  16810. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16811. TRACEBACK; status=1; return
  16812. end if
  16813. end if
  16814. if ( present(stride ) ) then
  16815. if ( size(stride ) /= varp%ndim ) then
  16816. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16817. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  16818. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16819. TRACEBACK; status=1; return
  16820. end if
  16821. end if
  16822. if ( present(map ) ) then
  16823. if ( size(map ) /= varp%ndim ) then
  16824. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  16825. write (gol,'(" size map : ",i6)') size(map ); call goErr
  16826. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  16827. TRACEBACK; status=1; return
  16828. end if
  16829. end if
  16830. ! loop over file types:
  16831. do iftype = 1, filep%nftype
  16832. ! current type:
  16833. ftype = filep%ftypes(iftype)
  16834. ! select appropriate routine for each type:
  16835. select case ( ftype )
  16836. #ifdef with_hdf4
  16837. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16838. case ( MDF_HDF4 )
  16839. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16840. ! check ...
  16841. if ( present(map ) ) then
  16842. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  16843. TRACEBACK; status=1; return
  16844. end if
  16845. ! fill offset (zero based!) and stride with default values:
  16846. hdf4_offset = 0
  16847. hdf4_stride = 1
  16848. ! count is by default the shape; padd with singleton dimensions:
  16849. hdf4_count = 1; hdf4_count(1:5) = shape(values)
  16850. ! replace by optional arguments if necessary:
  16851. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  16852. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  16853. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  16854. ! test target type;
  16855. ! convert to required kind before entering sfWData,
  16856. ! otherwise segmentation faults on some machines ...
  16857. select case ( varp%xtype )
  16858. case ( MDF_BYTE )
  16859. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16860. values_int1 = int(values,kind=1)
  16861. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16862. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  16863. deallocate( values_int1 )
  16864. case ( MDF_SHORT )
  16865. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16866. values_int2 = int(values,kind=2)
  16867. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16868. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  16869. deallocate( values_int2 )
  16870. case ( MDF_INT )
  16871. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16872. values_int4 = int(values,kind=4)
  16873. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16874. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  16875. deallocate( values_int4 )
  16876. case ( MDF_FLOAT )
  16877. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16878. values_real4 = real(values,kind=4)
  16879. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16880. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  16881. deallocate( values_real4 )
  16882. case ( MDF_DOUBLE )
  16883. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16884. values_real8 = real(values,kind=8)
  16885. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  16886. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  16887. deallocate( values_real8 )
  16888. case default
  16889. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  16890. TRACEBACK; status=1; return
  16891. end select
  16892. if ( status == FAIL ) then
  16893. write (gol,'("writing hdf4 data set:")'); call goErr
  16894. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  16895. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  16896. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  16897. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  16898. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  16899. write (gol,'(" size : ",i12)') size(values); call goErr
  16900. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  16901. TRACEBACK; status=1; return
  16902. end if
  16903. #endif
  16904. #ifdef with_hdf5_beta
  16905. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16906. case ( MDF_HDF5 )
  16907. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16908. ! check ...
  16909. if ( present(map ) ) then
  16910. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  16911. TRACEBACK; status=1; return
  16912. end if
  16913. ! fill offset (zero based!), stride, and count :
  16914. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  16915. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  16916. hdf5_count = 1 ! default singleton dimension
  16917. if ( present(count) ) then
  16918. hdf5_count(1:varp%ndim) = count
  16919. else
  16920. hdf5_count(1:5) = shape(values)
  16921. end if
  16922. ! new dimension:
  16923. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  16924. ! target data space in file:
  16925. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  16926. IF_NOT_OK_RETURN(status=1)
  16927. ! chunked dataset ?
  16928. if ( varp%hdf5_chunked ) then
  16929. ! reset extend:
  16930. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  16931. IF_NOT_OK_RETURN(status=1)
  16932. end if
  16933. ! select hyperslab:
  16934. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  16935. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  16936. stride=hdf5_stride(1:varp%ndim) )
  16937. ! write data:
  16938. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  16939. int(shape(values),kind=HSIZE_T), status, &
  16940. file_space_id=hdf5_file_space_id )
  16941. IF_NOT_OK_RETURN(status=1)
  16942. ! release data space:
  16943. call H5SClose_f( hdf5_file_space_id, status )
  16944. IF_NOT_OK_RETURN(status=1)
  16945. #endif
  16946. #ifdef with_netcdf
  16947. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16948. case ( MDF_NETCDF, MDF_NETCDF4 )
  16949. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16950. ! test target type:
  16951. ! convert to required kind before entering NF90_Put_Var,
  16952. ! otherwise segmentation faults on some machines ...
  16953. select case ( varp%xtype )
  16954. case ( MDF_BYTE )
  16955. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16956. values_int1 = int(values,kind=1)
  16957. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  16958. start, count, stride, map )
  16959. IF_NF90_NOT_OK_RETURN(status=1)
  16960. deallocate( values_int1 )
  16961. case ( MDF_SHORT )
  16962. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16963. values_int2 = int(values,kind=2)
  16964. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  16965. start, count, stride, map )
  16966. IF_NF90_NOT_OK_RETURN(status=1)
  16967. deallocate( values_int2 )
  16968. case ( MDF_INT )
  16969. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16970. values_int4 = int(values,kind=4)
  16971. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  16972. start, count, stride, map )
  16973. IF_NF90_NOT_OK_RETURN(status=1)
  16974. deallocate( values_int4 )
  16975. case ( MDF_FLOAT )
  16976. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16977. values_real4 = real(values,kind=4)
  16978. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  16979. start, count, stride, map )
  16980. IF_NF90_NOT_OK_RETURN(status=1)
  16981. deallocate( values_real4 )
  16982. case ( MDF_DOUBLE )
  16983. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  16984. values_real8 = real(values,kind=8)
  16985. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  16986. start, count, stride, map )
  16987. IF_NF90_NOT_OK_RETURN(status=1)
  16988. deallocate( values_real8 )
  16989. case default
  16990. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  16991. TRACEBACK; status=1; return
  16992. end select
  16993. ! just put; let netcdf library convert the right kind:
  16994. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  16995. ! start, count, stride, map )
  16996. !IF_NF90_NOT_OK_RETURN(status=1)
  16997. #endif
  16998. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  16999. case default
  17000. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17001. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  17002. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  17003. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  17004. TRACEBACK; status=1; return
  17005. end select
  17006. end do ! file types
  17007. ! ok
  17008. status = 0
  17009. end subroutine MDF_Put_Var_r4_5d
  17010. ! ***
  17011. subroutine MDF_Get_Var_r4_5d( hid, varid, values, status, &
  17012. start, count, stride, map )
  17013. #ifdef with_netcdf
  17014. use NetCDF, only : NF90_Get_Var
  17015. #endif
  17016. ! --- in/out -------------------------------------
  17017. integer, intent(in) :: hid
  17018. integer, intent(in) :: varid
  17019. real(4), intent(out) :: values(:,:,:,:,:)
  17020. integer, intent(out) :: status
  17021. integer, intent(in), optional :: start (:)
  17022. integer, intent(in), optional :: count (:)
  17023. integer, intent(in), optional :: stride(:)
  17024. integer, intent(in), optional :: map (:)
  17025. ! --- const --------------------------------------
  17026. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_5d'
  17027. ! --- external -----------------------------------
  17028. #ifdef with_hdf4
  17029. integer(hdf4_wpi), external :: sfRData
  17030. #endif
  17031. ! --- local --------------------------------------
  17032. type(MDF_File), pointer :: filep
  17033. type(MDF_Var), pointer :: varp
  17034. integer :: iftype
  17035. integer :: ftype
  17036. #ifdef with_hdf4
  17037. integer :: hdf4_offset(MAX_RANK)
  17038. integer :: hdf4_stride(MAX_RANK)
  17039. integer :: hdf4_count(MAX_RANK)
  17040. integer(1), allocatable :: values_int1(:,:,:,:,:)
  17041. integer(2), allocatable :: values_int2(:,:,:,:,:)
  17042. integer(4), allocatable :: values_int4(:,:,:,:,:)
  17043. integer(8), allocatable :: values_int8(:,:,:,:,:)
  17044. real(4), allocatable :: values_real4(:,:,:,:,:)
  17045. real(8), allocatable :: values_real8(:,:,:,:,:)
  17046. #endif
  17047. ! --- begin --------------------------------------
  17048. ! pointer to file structure:
  17049. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  17050. IF_NOT_OK_RETURN(status=1)
  17051. ! pointer to variable structure:
  17052. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  17053. IF_NOT_OK_RETURN(status=1)
  17054. ! check ...
  17055. if ( size(shape(values)) > varp%ndim ) then
  17056. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  17057. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  17058. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  17059. TRACEBACK; status=1; return
  17060. end if
  17061. ! check ...
  17062. if ( present(start ) ) then
  17063. if ( size(start ) /= varp%ndim ) then
  17064. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17065. write (gol,'(" size start : ",i6)') size(start ); call goErr
  17066. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17067. TRACEBACK; status=1; return
  17068. end if
  17069. end if
  17070. if ( present(count ) ) then
  17071. if ( size(count ) /= varp%ndim ) then
  17072. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17073. write (gol,'(" size count : ",i6)') size(count ); call goErr
  17074. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17075. TRACEBACK; status=1; return
  17076. end if
  17077. end if
  17078. if ( present(stride ) ) then
  17079. if ( size(stride ) /= varp%ndim ) then
  17080. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17081. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  17082. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17083. TRACEBACK; status=1; return
  17084. end if
  17085. end if
  17086. if ( present(map ) ) then
  17087. if ( size(map ) /= varp%ndim ) then
  17088. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17089. write (gol,'(" size map : ",i6)') size(map ); call goErr
  17090. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17091. TRACEBACK; status=1; return
  17092. end if
  17093. end if
  17094. ! loop over file types:
  17095. do iftype = 1, filep%nftype
  17096. ! current type:
  17097. ftype = filep%ftypes(iftype)
  17098. ! select appropriate routine for each type:
  17099. select case ( ftype )
  17100. #ifdef with_hdf4
  17101. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17102. case ( MDF_HDF4 )
  17103. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17104. ! check ...
  17105. if ( present(map ) ) then
  17106. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  17107. TRACEBACK; status=1; return
  17108. end if
  17109. ! fill offset (zero based!), stride, and count :
  17110. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  17111. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  17112. hdf4_count = 1 ! default singleton dimension
  17113. hdf4_count(1:5) = shape(values)
  17114. ! test source type:
  17115. select case ( varp%hdf4_xtype )
  17116. case ( DFNT_INT8 )
  17117. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17118. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  17119. values = real(values_int1,kind=4)
  17120. deallocate( values_int1 )
  17121. case ( DFNT_INT16 )
  17122. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17123. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  17124. values = real(values_int2,kind=4)
  17125. deallocate( values_int2 )
  17126. case ( DFNT_INT32 )
  17127. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17128. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  17129. values = real(values_int4,kind=4)
  17130. deallocate( values_int4 )
  17131. case ( DFNT_INT64 )
  17132. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17133. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  17134. values = real(values_int8,kind=4)
  17135. deallocate( values_int8 )
  17136. case ( DFNT_FLOAT32 )
  17137. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17138. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  17139. values = real(values_real4,kind=4)
  17140. deallocate( values_real4 )
  17141. case ( DFNT_FLOAT64 )
  17142. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  17143. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  17144. values = real(values_real8,kind=4)
  17145. deallocate( values_real8 )
  17146. case default
  17147. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  17148. TRACEBACK; status=1; return
  17149. end select
  17150. if ( status == FAIL ) then
  17151. write (gol,'("reading hdf4 data set:")'); call goErr
  17152. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  17153. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  17154. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  17155. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  17156. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  17157. write (gol,'(" size : ",i6)') size(values); call goErr
  17158. TRACEBACK; status=1; return
  17159. end if
  17160. #endif
  17161. #ifdef with_netcdf
  17162. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17163. case ( MDF_NETCDF, MDF_NETCDF4 )
  17164. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17165. ! read values, converted automatically:
  17166. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  17167. start, count, stride, map )
  17168. IF_NF90_NOT_OK_RETURN(status=1)
  17169. #endif
  17170. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17171. case default
  17172. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17173. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  17174. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  17175. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  17176. TRACEBACK; status=1; return
  17177. end select
  17178. end do ! file types
  17179. ! ok
  17180. status = 0
  17181. end subroutine MDF_Get_Var_r4_5d
  17182. ! ***
  17183. subroutine MDF_Put_Var_r4_6d( hid, varid, values, status, &
  17184. start, count, stride, map )
  17185. #ifdef with_hdf5_beta
  17186. use HDF5, only : HID_T, HSIZE_T
  17187. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  17188. use HDF5, only : H5T_NATIVE_CHARACTER
  17189. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  17190. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  17191. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  17192. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  17193. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  17194. #endif
  17195. #ifdef with_netcdf
  17196. use NetCDF, only : NF90_Put_Var
  17197. #endif
  17198. ! --- in/out -------------------------------------
  17199. integer, intent(in) :: hid
  17200. integer, intent(in) :: varid
  17201. real(4), intent(in) :: values(:,:,:,:,:,:)
  17202. integer, intent(out) :: status
  17203. integer, intent(in), optional :: start (:)
  17204. integer, intent(in), optional :: count (:)
  17205. integer, intent(in), optional :: stride(:)
  17206. integer, intent(in), optional :: map (:)
  17207. ! --- const --------------------------------------
  17208. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_6d'
  17209. ! --- external -----------------------------------
  17210. #ifdef with_hdf4
  17211. integer(hdf4_wpi), external :: sfWData
  17212. #endif
  17213. ! --- local --------------------------------------
  17214. type(MDF_File), pointer :: filep
  17215. type(MDF_Var), pointer :: varp
  17216. integer :: iftype
  17217. integer :: ftype
  17218. #ifdef with_hdf4
  17219. integer :: hdf4_offset(MAX_RANK)
  17220. integer :: hdf4_stride(MAX_RANK)
  17221. integer :: hdf4_count(MAX_RANK)
  17222. #endif
  17223. #ifdef with_hdf5_beta
  17224. !integer(HID_T) :: hdf5_type_id
  17225. integer(HID_T) :: hdf5_file_space_id
  17226. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  17227. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  17228. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  17229. #endif
  17230. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  17231. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  17232. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  17233. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  17234. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  17235. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  17236. ! --- begin --------------------------------------
  17237. ! pointer to file structure:
  17238. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  17239. IF_NOT_OK_RETURN(status=1)
  17240. ! pointer to variable structure:
  17241. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  17242. IF_NOT_OK_RETURN(status=1)
  17243. ! check ...
  17244. if ( size(shape(values)) > varp%ndim ) then
  17245. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  17246. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  17247. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  17248. TRACEBACK; status=1; return
  17249. end if
  17250. ! check ...
  17251. if ( present(start ) ) then
  17252. if ( size(start ) /= varp%ndim ) then
  17253. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17254. write (gol,'(" size start : ",i6)') size(start ); call goErr
  17255. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17256. TRACEBACK; status=1; return
  17257. end if
  17258. end if
  17259. if ( present(count ) ) then
  17260. if ( size(count ) /= varp%ndim ) then
  17261. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17262. write (gol,'(" size count : ",i6)') size(count ); call goErr
  17263. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17264. TRACEBACK; status=1; return
  17265. end if
  17266. end if
  17267. if ( present(stride ) ) then
  17268. if ( size(stride ) /= varp%ndim ) then
  17269. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17270. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  17271. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17272. TRACEBACK; status=1; return
  17273. end if
  17274. end if
  17275. if ( present(map ) ) then
  17276. if ( size(map ) /= varp%ndim ) then
  17277. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17278. write (gol,'(" size map : ",i6)') size(map ); call goErr
  17279. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17280. TRACEBACK; status=1; return
  17281. end if
  17282. end if
  17283. ! loop over file types:
  17284. do iftype = 1, filep%nftype
  17285. ! current type:
  17286. ftype = filep%ftypes(iftype)
  17287. ! select appropriate routine for each type:
  17288. select case ( ftype )
  17289. #ifdef with_hdf4
  17290. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17291. case ( MDF_HDF4 )
  17292. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17293. ! check ...
  17294. if ( present(map ) ) then
  17295. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  17296. TRACEBACK; status=1; return
  17297. end if
  17298. ! fill offset (zero based!) and stride with default values:
  17299. hdf4_offset = 0
  17300. hdf4_stride = 1
  17301. ! count is by default the shape; padd with singleton dimensions:
  17302. hdf4_count = 1; hdf4_count(1:6) = shape(values)
  17303. ! replace by optional arguments if necessary:
  17304. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  17305. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  17306. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  17307. ! test target type;
  17308. ! convert to required kind before entering sfWData,
  17309. ! otherwise segmentation faults on some machines ...
  17310. select case ( varp%xtype )
  17311. case ( MDF_BYTE )
  17312. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17313. values_int1 = int(values,kind=1)
  17314. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17315. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  17316. deallocate( values_int1 )
  17317. case ( MDF_SHORT )
  17318. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17319. values_int2 = int(values,kind=2)
  17320. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17321. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  17322. deallocate( values_int2 )
  17323. case ( MDF_INT )
  17324. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17325. values_int4 = int(values,kind=4)
  17326. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17327. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  17328. deallocate( values_int4 )
  17329. case ( MDF_FLOAT )
  17330. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17331. values_real4 = real(values,kind=4)
  17332. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17333. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  17334. deallocate( values_real4 )
  17335. case ( MDF_DOUBLE )
  17336. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17337. values_real8 = real(values,kind=8)
  17338. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17339. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  17340. deallocate( values_real8 )
  17341. case default
  17342. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  17343. TRACEBACK; status=1; return
  17344. end select
  17345. if ( status == FAIL ) then
  17346. write (gol,'("writing hdf4 data set:")'); call goErr
  17347. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  17348. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  17349. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  17350. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  17351. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  17352. write (gol,'(" size : ",i12)') size(values); call goErr
  17353. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  17354. TRACEBACK; status=1; return
  17355. end if
  17356. #endif
  17357. #ifdef with_hdf5_beta
  17358. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17359. case ( MDF_HDF5 )
  17360. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17361. ! check ...
  17362. if ( present(map ) ) then
  17363. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  17364. TRACEBACK; status=1; return
  17365. end if
  17366. ! fill offset (zero based!), stride, and count :
  17367. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  17368. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  17369. hdf5_count = 1 ! default singleton dimension
  17370. if ( present(count) ) then
  17371. hdf5_count(1:varp%ndim) = count
  17372. else
  17373. hdf5_count(1:6) = shape(values)
  17374. end if
  17375. ! new dimension:
  17376. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  17377. ! target data space in file:
  17378. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  17379. IF_NOT_OK_RETURN(status=1)
  17380. ! chunked dataset ?
  17381. if ( varp%hdf5_chunked ) then
  17382. ! reset extend:
  17383. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  17384. IF_NOT_OK_RETURN(status=1)
  17385. end if
  17386. ! select hyperslab:
  17387. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  17388. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  17389. stride=hdf5_stride(1:varp%ndim) )
  17390. ! write data:
  17391. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  17392. int(shape(values),kind=HSIZE_T), status, &
  17393. file_space_id=hdf5_file_space_id )
  17394. IF_NOT_OK_RETURN(status=1)
  17395. ! release data space:
  17396. call H5SClose_f( hdf5_file_space_id, status )
  17397. IF_NOT_OK_RETURN(status=1)
  17398. #endif
  17399. #ifdef with_netcdf
  17400. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17401. case ( MDF_NETCDF, MDF_NETCDF4 )
  17402. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17403. ! test target type:
  17404. ! convert to required kind before entering NF90_Put_Var,
  17405. ! otherwise segmentation faults on some machines ...
  17406. select case ( varp%xtype )
  17407. case ( MDF_BYTE )
  17408. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17409. values_int1 = int(values,kind=1)
  17410. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  17411. start, count, stride, map )
  17412. IF_NF90_NOT_OK_RETURN(status=1)
  17413. deallocate( values_int1 )
  17414. case ( MDF_SHORT )
  17415. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17416. values_int2 = int(values,kind=2)
  17417. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  17418. start, count, stride, map )
  17419. IF_NF90_NOT_OK_RETURN(status=1)
  17420. deallocate( values_int2 )
  17421. case ( MDF_INT )
  17422. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17423. values_int4 = int(values,kind=4)
  17424. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  17425. start, count, stride, map )
  17426. IF_NF90_NOT_OK_RETURN(status=1)
  17427. deallocate( values_int4 )
  17428. case ( MDF_FLOAT )
  17429. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17430. values_real4 = real(values,kind=4)
  17431. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  17432. start, count, stride, map )
  17433. IF_NF90_NOT_OK_RETURN(status=1)
  17434. deallocate( values_real4 )
  17435. case ( MDF_DOUBLE )
  17436. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17437. values_real8 = real(values,kind=8)
  17438. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  17439. start, count, stride, map )
  17440. IF_NF90_NOT_OK_RETURN(status=1)
  17441. deallocate( values_real8 )
  17442. case default
  17443. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  17444. TRACEBACK; status=1; return
  17445. end select
  17446. ! just put; let netcdf library convert the right kind:
  17447. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  17448. ! start, count, stride, map )
  17449. !IF_NF90_NOT_OK_RETURN(status=1)
  17450. #endif
  17451. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17452. case default
  17453. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17454. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  17455. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  17456. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  17457. TRACEBACK; status=1; return
  17458. end select
  17459. end do ! file types
  17460. ! ok
  17461. status = 0
  17462. end subroutine MDF_Put_Var_r4_6d
  17463. ! ***
  17464. subroutine MDF_Get_Var_r4_6d( hid, varid, values, status, &
  17465. start, count, stride, map )
  17466. #ifdef with_netcdf
  17467. use NetCDF, only : NF90_Get_Var
  17468. #endif
  17469. ! --- in/out -------------------------------------
  17470. integer, intent(in) :: hid
  17471. integer, intent(in) :: varid
  17472. real(4), intent(out) :: values(:,:,:,:,:,:)
  17473. integer, intent(out) :: status
  17474. integer, intent(in), optional :: start (:)
  17475. integer, intent(in), optional :: count (:)
  17476. integer, intent(in), optional :: stride(:)
  17477. integer, intent(in), optional :: map (:)
  17478. ! --- const --------------------------------------
  17479. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_6d'
  17480. ! --- external -----------------------------------
  17481. #ifdef with_hdf4
  17482. integer(hdf4_wpi), external :: sfRData
  17483. #endif
  17484. ! --- local --------------------------------------
  17485. type(MDF_File), pointer :: filep
  17486. type(MDF_Var), pointer :: varp
  17487. integer :: iftype
  17488. integer :: ftype
  17489. #ifdef with_hdf4
  17490. integer :: hdf4_offset(MAX_RANK)
  17491. integer :: hdf4_stride(MAX_RANK)
  17492. integer :: hdf4_count(MAX_RANK)
  17493. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  17494. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  17495. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  17496. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  17497. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  17498. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  17499. #endif
  17500. ! --- begin --------------------------------------
  17501. ! pointer to file structure:
  17502. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  17503. IF_NOT_OK_RETURN(status=1)
  17504. ! pointer to variable structure:
  17505. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  17506. IF_NOT_OK_RETURN(status=1)
  17507. ! check ...
  17508. if ( size(shape(values)) > varp%ndim ) then
  17509. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  17510. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  17511. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  17512. TRACEBACK; status=1; return
  17513. end if
  17514. ! check ...
  17515. if ( present(start ) ) then
  17516. if ( size(start ) /= varp%ndim ) then
  17517. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17518. write (gol,'(" size start : ",i6)') size(start ); call goErr
  17519. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17520. TRACEBACK; status=1; return
  17521. end if
  17522. end if
  17523. if ( present(count ) ) then
  17524. if ( size(count ) /= varp%ndim ) then
  17525. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17526. write (gol,'(" size count : ",i6)') size(count ); call goErr
  17527. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17528. TRACEBACK; status=1; return
  17529. end if
  17530. end if
  17531. if ( present(stride ) ) then
  17532. if ( size(stride ) /= varp%ndim ) then
  17533. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17534. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  17535. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17536. TRACEBACK; status=1; return
  17537. end if
  17538. end if
  17539. if ( present(map ) ) then
  17540. if ( size(map ) /= varp%ndim ) then
  17541. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17542. write (gol,'(" size map : ",i6)') size(map ); call goErr
  17543. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17544. TRACEBACK; status=1; return
  17545. end if
  17546. end if
  17547. ! loop over file types:
  17548. do iftype = 1, filep%nftype
  17549. ! current type:
  17550. ftype = filep%ftypes(iftype)
  17551. ! select appropriate routine for each type:
  17552. select case ( ftype )
  17553. #ifdef with_hdf4
  17554. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17555. case ( MDF_HDF4 )
  17556. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17557. ! check ...
  17558. if ( present(map ) ) then
  17559. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  17560. TRACEBACK; status=1; return
  17561. end if
  17562. ! fill offset (zero based!), stride, and count :
  17563. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  17564. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  17565. hdf4_count = 1 ! default singleton dimension
  17566. hdf4_count(1:6) = shape(values)
  17567. ! test source type:
  17568. select case ( varp%hdf4_xtype )
  17569. case ( DFNT_INT8 )
  17570. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17571. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  17572. values = real(values_int1,kind=4)
  17573. deallocate( values_int1 )
  17574. case ( DFNT_INT16 )
  17575. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17576. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  17577. values = real(values_int2,kind=4)
  17578. deallocate( values_int2 )
  17579. case ( DFNT_INT32 )
  17580. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17581. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  17582. values = real(values_int4,kind=4)
  17583. deallocate( values_int4 )
  17584. case ( DFNT_INT64 )
  17585. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17586. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  17587. values = real(values_int8,kind=4)
  17588. deallocate( values_int8 )
  17589. case ( DFNT_FLOAT32 )
  17590. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17591. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  17592. values = real(values_real4,kind=4)
  17593. deallocate( values_real4 )
  17594. case ( DFNT_FLOAT64 )
  17595. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  17596. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  17597. values = real(values_real8,kind=4)
  17598. deallocate( values_real8 )
  17599. case default
  17600. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  17601. TRACEBACK; status=1; return
  17602. end select
  17603. if ( status == FAIL ) then
  17604. write (gol,'("reading hdf4 data set:")'); call goErr
  17605. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  17606. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  17607. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  17608. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  17609. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  17610. write (gol,'(" size : ",i6)') size(values); call goErr
  17611. TRACEBACK; status=1; return
  17612. end if
  17613. #endif
  17614. #ifdef with_netcdf
  17615. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17616. case ( MDF_NETCDF, MDF_NETCDF4 )
  17617. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17618. ! read values, converted automatically:
  17619. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  17620. start, count, stride, map )
  17621. IF_NF90_NOT_OK_RETURN(status=1)
  17622. #endif
  17623. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17624. case default
  17625. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17626. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  17627. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  17628. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  17629. TRACEBACK; status=1; return
  17630. end select
  17631. end do ! file types
  17632. ! ok
  17633. status = 0
  17634. end subroutine MDF_Get_Var_r4_6d
  17635. ! ***
  17636. subroutine MDF_Put_Var_r4_7d( hid, varid, values, status, &
  17637. start, count, stride, map )
  17638. #ifdef with_hdf5_beta
  17639. use HDF5, only : HID_T, HSIZE_T
  17640. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  17641. use HDF5, only : H5T_NATIVE_CHARACTER
  17642. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  17643. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  17644. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  17645. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  17646. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  17647. #endif
  17648. #ifdef with_netcdf
  17649. use NetCDF, only : NF90_Put_Var
  17650. #endif
  17651. ! --- in/out -------------------------------------
  17652. integer, intent(in) :: hid
  17653. integer, intent(in) :: varid
  17654. real(4), intent(in) :: values(:,:,:,:,:,:,:)
  17655. integer, intent(out) :: status
  17656. integer, intent(in), optional :: start (:)
  17657. integer, intent(in), optional :: count (:)
  17658. integer, intent(in), optional :: stride(:)
  17659. integer, intent(in), optional :: map (:)
  17660. ! --- const --------------------------------------
  17661. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_7d'
  17662. ! --- external -----------------------------------
  17663. #ifdef with_hdf4
  17664. integer(hdf4_wpi), external :: sfWData
  17665. #endif
  17666. ! --- local --------------------------------------
  17667. type(MDF_File), pointer :: filep
  17668. type(MDF_Var), pointer :: varp
  17669. integer :: iftype
  17670. integer :: ftype
  17671. #ifdef with_hdf4
  17672. integer :: hdf4_offset(MAX_RANK)
  17673. integer :: hdf4_stride(MAX_RANK)
  17674. integer :: hdf4_count(MAX_RANK)
  17675. #endif
  17676. #ifdef with_hdf5_beta
  17677. !integer(HID_T) :: hdf5_type_id
  17678. integer(HID_T) :: hdf5_file_space_id
  17679. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  17680. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  17681. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  17682. #endif
  17683. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  17684. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  17685. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  17686. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  17687. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  17688. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  17689. ! --- begin --------------------------------------
  17690. ! pointer to file structure:
  17691. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  17692. IF_NOT_OK_RETURN(status=1)
  17693. ! pointer to variable structure:
  17694. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  17695. IF_NOT_OK_RETURN(status=1)
  17696. ! check ...
  17697. if ( size(shape(values)) > varp%ndim ) then
  17698. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  17699. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  17700. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  17701. TRACEBACK; status=1; return
  17702. end if
  17703. ! check ...
  17704. if ( present(start ) ) then
  17705. if ( size(start ) /= varp%ndim ) then
  17706. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17707. write (gol,'(" size start : ",i6)') size(start ); call goErr
  17708. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17709. TRACEBACK; status=1; return
  17710. end if
  17711. end if
  17712. if ( present(count ) ) then
  17713. if ( size(count ) /= varp%ndim ) then
  17714. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17715. write (gol,'(" size count : ",i6)') size(count ); call goErr
  17716. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17717. TRACEBACK; status=1; return
  17718. end if
  17719. end if
  17720. if ( present(stride ) ) then
  17721. if ( size(stride ) /= varp%ndim ) then
  17722. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17723. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  17724. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17725. TRACEBACK; status=1; return
  17726. end if
  17727. end if
  17728. if ( present(map ) ) then
  17729. if ( size(map ) /= varp%ndim ) then
  17730. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17731. write (gol,'(" size map : ",i6)') size(map ); call goErr
  17732. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17733. TRACEBACK; status=1; return
  17734. end if
  17735. end if
  17736. ! loop over file types:
  17737. do iftype = 1, filep%nftype
  17738. ! current type:
  17739. ftype = filep%ftypes(iftype)
  17740. ! select appropriate routine for each type:
  17741. select case ( ftype )
  17742. #ifdef with_hdf4
  17743. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17744. case ( MDF_HDF4 )
  17745. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17746. ! check ...
  17747. if ( present(map ) ) then
  17748. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  17749. TRACEBACK; status=1; return
  17750. end if
  17751. ! fill offset (zero based!) and stride with default values:
  17752. hdf4_offset = 0
  17753. hdf4_stride = 1
  17754. ! count is by default the shape; padd with singleton dimensions:
  17755. hdf4_count = 1; hdf4_count(1:7) = shape(values)
  17756. ! replace by optional arguments if necessary:
  17757. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  17758. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  17759. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  17760. ! test target type;
  17761. ! convert to required kind before entering sfWData,
  17762. ! otherwise segmentation faults on some machines ...
  17763. select case ( varp%xtype )
  17764. case ( MDF_BYTE )
  17765. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17766. values_int1 = int(values,kind=1)
  17767. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17768. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  17769. deallocate( values_int1 )
  17770. case ( MDF_SHORT )
  17771. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17772. values_int2 = int(values,kind=2)
  17773. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17774. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  17775. deallocate( values_int2 )
  17776. case ( MDF_INT )
  17777. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17778. values_int4 = int(values,kind=4)
  17779. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17780. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  17781. deallocate( values_int4 )
  17782. case ( MDF_FLOAT )
  17783. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17784. values_real4 = real(values,kind=4)
  17785. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17786. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  17787. deallocate( values_real4 )
  17788. case ( MDF_DOUBLE )
  17789. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17790. values_real8 = real(values,kind=8)
  17791. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  17792. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  17793. deallocate( values_real8 )
  17794. case default
  17795. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  17796. TRACEBACK; status=1; return
  17797. end select
  17798. if ( status == FAIL ) then
  17799. write (gol,'("writing hdf4 data set:")'); call goErr
  17800. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  17801. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  17802. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  17803. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  17804. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  17805. write (gol,'(" size : ",i12)') size(values); call goErr
  17806. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  17807. TRACEBACK; status=1; return
  17808. end if
  17809. #endif
  17810. #ifdef with_hdf5_beta
  17811. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17812. case ( MDF_HDF5 )
  17813. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17814. ! check ...
  17815. if ( present(map ) ) then
  17816. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  17817. TRACEBACK; status=1; return
  17818. end if
  17819. ! fill offset (zero based!), stride, and count :
  17820. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  17821. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  17822. hdf5_count = 1 ! default singleton dimension
  17823. if ( present(count) ) then
  17824. hdf5_count(1:varp%ndim) = count
  17825. else
  17826. hdf5_count(1:7) = shape(values)
  17827. end if
  17828. ! new dimension:
  17829. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  17830. ! target data space in file:
  17831. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  17832. IF_NOT_OK_RETURN(status=1)
  17833. ! chunked dataset ?
  17834. if ( varp%hdf5_chunked ) then
  17835. ! reset extend:
  17836. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  17837. IF_NOT_OK_RETURN(status=1)
  17838. end if
  17839. ! select hyperslab:
  17840. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  17841. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  17842. stride=hdf5_stride(1:varp%ndim) )
  17843. ! write data:
  17844. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, &
  17845. int(shape(values),kind=HSIZE_T), status, &
  17846. file_space_id=hdf5_file_space_id )
  17847. IF_NOT_OK_RETURN(status=1)
  17848. ! release data space:
  17849. call H5SClose_f( hdf5_file_space_id, status )
  17850. IF_NOT_OK_RETURN(status=1)
  17851. #endif
  17852. #ifdef with_netcdf
  17853. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17854. case ( MDF_NETCDF, MDF_NETCDF4 )
  17855. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17856. ! test target type:
  17857. ! convert to required kind before entering NF90_Put_Var,
  17858. ! otherwise segmentation faults on some machines ...
  17859. select case ( varp%xtype )
  17860. case ( MDF_BYTE )
  17861. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17862. values_int1 = int(values,kind=1)
  17863. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  17864. start, count, stride, map )
  17865. IF_NF90_NOT_OK_RETURN(status=1)
  17866. deallocate( values_int1 )
  17867. case ( MDF_SHORT )
  17868. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17869. values_int2 = int(values,kind=2)
  17870. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  17871. start, count, stride, map )
  17872. IF_NF90_NOT_OK_RETURN(status=1)
  17873. deallocate( values_int2 )
  17874. case ( MDF_INT )
  17875. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17876. values_int4 = int(values,kind=4)
  17877. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  17878. start, count, stride, map )
  17879. IF_NF90_NOT_OK_RETURN(status=1)
  17880. deallocate( values_int4 )
  17881. case ( MDF_FLOAT )
  17882. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17883. values_real4 = real(values,kind=4)
  17884. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  17885. start, count, stride, map )
  17886. IF_NF90_NOT_OK_RETURN(status=1)
  17887. deallocate( values_real4 )
  17888. case ( MDF_DOUBLE )
  17889. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  17890. values_real8 = real(values,kind=8)
  17891. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  17892. start, count, stride, map )
  17893. IF_NF90_NOT_OK_RETURN(status=1)
  17894. deallocate( values_real8 )
  17895. case default
  17896. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  17897. TRACEBACK; status=1; return
  17898. end select
  17899. ! just put; let netcdf library convert the right kind:
  17900. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  17901. ! start, count, stride, map )
  17902. !IF_NF90_NOT_OK_RETURN(status=1)
  17903. #endif
  17904. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17905. case default
  17906. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  17907. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  17908. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  17909. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  17910. TRACEBACK; status=1; return
  17911. end select
  17912. end do ! file types
  17913. ! ok
  17914. status = 0
  17915. end subroutine MDF_Put_Var_r4_7d
  17916. ! ***
  17917. subroutine MDF_Get_Var_r4_7d( hid, varid, values, status, &
  17918. start, count, stride, map )
  17919. #ifdef with_netcdf
  17920. use NetCDF, only : NF90_Get_Var
  17921. #endif
  17922. ! --- in/out -------------------------------------
  17923. integer, intent(in) :: hid
  17924. integer, intent(in) :: varid
  17925. real(4), intent(out) :: values(:,:,:,:,:,:,:)
  17926. integer, intent(out) :: status
  17927. integer, intent(in), optional :: start (:)
  17928. integer, intent(in), optional :: count (:)
  17929. integer, intent(in), optional :: stride(:)
  17930. integer, intent(in), optional :: map (:)
  17931. ! --- const --------------------------------------
  17932. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_7d'
  17933. ! --- external -----------------------------------
  17934. #ifdef with_hdf4
  17935. integer(hdf4_wpi), external :: sfRData
  17936. #endif
  17937. ! --- local --------------------------------------
  17938. type(MDF_File), pointer :: filep
  17939. type(MDF_Var), pointer :: varp
  17940. integer :: iftype
  17941. integer :: ftype
  17942. #ifdef with_hdf4
  17943. integer :: hdf4_offset(MAX_RANK)
  17944. integer :: hdf4_stride(MAX_RANK)
  17945. integer :: hdf4_count(MAX_RANK)
  17946. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  17947. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  17948. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  17949. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  17950. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  17951. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  17952. #endif
  17953. ! --- begin --------------------------------------
  17954. ! pointer to file structure:
  17955. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  17956. IF_NOT_OK_RETURN(status=1)
  17957. ! pointer to variable structure:
  17958. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  17959. IF_NOT_OK_RETURN(status=1)
  17960. ! check ...
  17961. if ( size(shape(values)) > varp%ndim ) then
  17962. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  17963. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  17964. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  17965. TRACEBACK; status=1; return
  17966. end if
  17967. ! check ...
  17968. if ( present(start ) ) then
  17969. if ( size(start ) /= varp%ndim ) then
  17970. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17971. write (gol,'(" size start : ",i6)') size(start ); call goErr
  17972. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17973. TRACEBACK; status=1; return
  17974. end if
  17975. end if
  17976. if ( present(count ) ) then
  17977. if ( size(count ) /= varp%ndim ) then
  17978. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17979. write (gol,'(" size count : ",i6)') size(count ); call goErr
  17980. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17981. TRACEBACK; status=1; return
  17982. end if
  17983. end if
  17984. if ( present(stride ) ) then
  17985. if ( size(stride ) /= varp%ndim ) then
  17986. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17987. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  17988. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17989. TRACEBACK; status=1; return
  17990. end if
  17991. end if
  17992. if ( present(map ) ) then
  17993. if ( size(map ) /= varp%ndim ) then
  17994. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  17995. write (gol,'(" size map : ",i6)') size(map ); call goErr
  17996. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  17997. TRACEBACK; status=1; return
  17998. end if
  17999. end if
  18000. ! loop over file types:
  18001. do iftype = 1, filep%nftype
  18002. ! current type:
  18003. ftype = filep%ftypes(iftype)
  18004. ! select appropriate routine for each type:
  18005. select case ( ftype )
  18006. #ifdef with_hdf4
  18007. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18008. case ( MDF_HDF4 )
  18009. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18010. ! check ...
  18011. if ( present(map ) ) then
  18012. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  18013. TRACEBACK; status=1; return
  18014. end if
  18015. ! fill offset (zero based!), stride, and count :
  18016. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  18017. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  18018. hdf4_count = 1 ! default singleton dimension
  18019. hdf4_count(1:7) = shape(values)
  18020. ! test source type:
  18021. select case ( varp%hdf4_xtype )
  18022. case ( DFNT_INT8 )
  18023. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18024. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  18025. values = real(values_int1,kind=4)
  18026. deallocate( values_int1 )
  18027. case ( DFNT_INT16 )
  18028. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18029. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  18030. values = real(values_int2,kind=4)
  18031. deallocate( values_int2 )
  18032. case ( DFNT_INT32 )
  18033. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18034. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  18035. values = real(values_int4,kind=4)
  18036. deallocate( values_int4 )
  18037. case ( DFNT_INT64 )
  18038. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18039. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  18040. values = real(values_int8,kind=4)
  18041. deallocate( values_int8 )
  18042. case ( DFNT_FLOAT32 )
  18043. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18044. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  18045. values = real(values_real4,kind=4)
  18046. deallocate( values_real4 )
  18047. case ( DFNT_FLOAT64 )
  18048. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  18049. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  18050. values = real(values_real8,kind=4)
  18051. deallocate( values_real8 )
  18052. case default
  18053. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  18054. TRACEBACK; status=1; return
  18055. end select
  18056. if ( status == FAIL ) then
  18057. write (gol,'("reading hdf4 data set:")'); call goErr
  18058. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  18059. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  18060. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  18061. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  18062. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  18063. write (gol,'(" size : ",i6)') size(values); call goErr
  18064. TRACEBACK; status=1; return
  18065. end if
  18066. #endif
  18067. #ifdef with_netcdf
  18068. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18069. case ( MDF_NETCDF, MDF_NETCDF4 )
  18070. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18071. ! read values, converted automatically:
  18072. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  18073. start, count, stride, map )
  18074. IF_NF90_NOT_OK_RETURN(status=1)
  18075. #endif
  18076. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18077. case default
  18078. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18079. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  18080. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  18081. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  18082. TRACEBACK; status=1; return
  18083. end select
  18084. end do ! file types
  18085. ! ok
  18086. status = 0
  18087. end subroutine MDF_Get_Var_r4_7d
  18088. ! ***
  18089. subroutine MDF_Put_Var_r8_1d( hid, varid, values, status, &
  18090. start, count, stride, map )
  18091. #ifdef with_hdf5_beta
  18092. use HDF5, only : HID_T, HSIZE_T
  18093. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  18094. use HDF5, only : H5T_NATIVE_CHARACTER
  18095. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  18096. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  18097. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  18098. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  18099. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  18100. #endif
  18101. #ifdef with_netcdf
  18102. use NetCDF, only : NF90_Put_Var
  18103. #endif
  18104. ! --- in/out -------------------------------------
  18105. integer, intent(in) :: hid
  18106. integer, intent(in) :: varid
  18107. real(8), intent(in) :: values(:)
  18108. integer, intent(out) :: status
  18109. integer, intent(in), optional :: start (:)
  18110. integer, intent(in), optional :: count (:)
  18111. integer, intent(in), optional :: stride(:)
  18112. integer, intent(in), optional :: map (:)
  18113. ! --- const --------------------------------------
  18114. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_1d'
  18115. ! --- external -----------------------------------
  18116. #ifdef with_hdf4
  18117. integer(hdf4_wpi), external :: sfWData
  18118. #endif
  18119. ! --- local --------------------------------------
  18120. type(MDF_File), pointer :: filep
  18121. type(MDF_Var), pointer :: varp
  18122. integer :: iftype
  18123. integer :: ftype
  18124. #ifdef with_hdf4
  18125. integer :: hdf4_offset(MAX_RANK)
  18126. integer :: hdf4_stride(MAX_RANK)
  18127. integer :: hdf4_count(MAX_RANK)
  18128. #endif
  18129. #ifdef with_hdf5_beta
  18130. !integer(HID_T) :: hdf5_type_id
  18131. integer(HID_T) :: hdf5_file_space_id
  18132. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  18133. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  18134. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  18135. #endif
  18136. integer(1), allocatable :: values_int1(:)
  18137. integer(2), allocatable :: values_int2(:)
  18138. integer(4), allocatable :: values_int4(:)
  18139. integer(8), allocatable :: values_int8(:)
  18140. real(4), allocatable :: values_real4(:)
  18141. real(8), allocatable :: values_real8(:)
  18142. ! --- begin --------------------------------------
  18143. ! pointer to file structure:
  18144. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  18145. IF_NOT_OK_RETURN(status=1)
  18146. ! pointer to variable structure:
  18147. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  18148. IF_NOT_OK_RETURN(status=1)
  18149. ! check ...
  18150. if ( size(shape(values)) > varp%ndim ) then
  18151. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  18152. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  18153. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  18154. TRACEBACK; status=1; return
  18155. end if
  18156. ! check ...
  18157. if ( present(start ) ) then
  18158. if ( size(start ) /= varp%ndim ) then
  18159. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18160. write (gol,'(" size start : ",i6)') size(start ); call goErr
  18161. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18162. TRACEBACK; status=1; return
  18163. end if
  18164. end if
  18165. if ( present(count ) ) then
  18166. if ( size(count ) /= varp%ndim ) then
  18167. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18168. write (gol,'(" size count : ",i6)') size(count ); call goErr
  18169. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18170. TRACEBACK; status=1; return
  18171. end if
  18172. end if
  18173. if ( present(stride ) ) then
  18174. if ( size(stride ) /= varp%ndim ) then
  18175. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18176. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  18177. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18178. TRACEBACK; status=1; return
  18179. end if
  18180. end if
  18181. if ( present(map ) ) then
  18182. if ( size(map ) /= varp%ndim ) then
  18183. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18184. write (gol,'(" size map : ",i6)') size(map ); call goErr
  18185. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18186. TRACEBACK; status=1; return
  18187. end if
  18188. end if
  18189. ! loop over file types:
  18190. do iftype = 1, filep%nftype
  18191. ! current type:
  18192. ftype = filep%ftypes(iftype)
  18193. ! select appropriate routine for each type:
  18194. select case ( ftype )
  18195. #ifdef with_hdf4
  18196. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18197. case ( MDF_HDF4 )
  18198. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18199. ! check ...
  18200. if ( present(map ) ) then
  18201. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  18202. TRACEBACK; status=1; return
  18203. end if
  18204. ! fill offset (zero based!) and stride with default values:
  18205. hdf4_offset = 0
  18206. hdf4_stride = 1
  18207. ! count is by default the shape; padd with singleton dimensions:
  18208. hdf4_count = 1; hdf4_count(1:1) = shape(values)
  18209. ! replace by optional arguments if necessary:
  18210. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  18211. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  18212. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  18213. ! test target type;
  18214. ! convert to required kind before entering sfWData,
  18215. ! otherwise segmentation faults on some machines ...
  18216. select case ( varp%xtype )
  18217. case ( MDF_BYTE )
  18218. allocate( values_int1(size(values,1)) )
  18219. values_int1 = int(values,kind=1)
  18220. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18221. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  18222. deallocate( values_int1 )
  18223. case ( MDF_SHORT )
  18224. allocate( values_int2(size(values,1)) )
  18225. values_int2 = int(values,kind=2)
  18226. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18227. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  18228. deallocate( values_int2 )
  18229. case ( MDF_INT )
  18230. allocate( values_int4(size(values,1)) )
  18231. values_int4 = int(values,kind=4)
  18232. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18233. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  18234. deallocate( values_int4 )
  18235. case ( MDF_FLOAT )
  18236. allocate( values_real4(size(values,1)) )
  18237. values_real4 = real(values,kind=4)
  18238. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18239. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  18240. deallocate( values_real4 )
  18241. case ( MDF_DOUBLE )
  18242. allocate( values_real8(size(values,1)) )
  18243. values_real8 = real(values,kind=8)
  18244. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18245. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  18246. deallocate( values_real8 )
  18247. case default
  18248. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  18249. TRACEBACK; status=1; return
  18250. end select
  18251. if ( status == FAIL ) then
  18252. write (gol,'("writing hdf4 data set:")'); call goErr
  18253. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  18254. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  18255. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  18256. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  18257. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  18258. write (gol,'(" size : ",i12)') size(values); call goErr
  18259. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  18260. TRACEBACK; status=1; return
  18261. end if
  18262. #endif
  18263. #ifdef with_hdf5_beta
  18264. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18265. case ( MDF_HDF5 )
  18266. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18267. ! check ...
  18268. if ( present(map ) ) then
  18269. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  18270. TRACEBACK; status=1; return
  18271. end if
  18272. ! fill offset (zero based!), stride, and count :
  18273. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  18274. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  18275. hdf5_count = 1 ! default singleton dimension
  18276. if ( present(count) ) then
  18277. hdf5_count(1:varp%ndim) = count
  18278. else
  18279. hdf5_count(1:1) = shape(values)
  18280. end if
  18281. ! new dimension:
  18282. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  18283. ! target data space in file:
  18284. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  18285. IF_NOT_OK_RETURN(status=1)
  18286. ! chunked dataset ?
  18287. if ( varp%hdf5_chunked ) then
  18288. ! reset extend:
  18289. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  18290. IF_NOT_OK_RETURN(status=1)
  18291. end if
  18292. ! select hyperslab:
  18293. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  18294. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  18295. stride=hdf5_stride(1:varp%ndim) )
  18296. ! write data:
  18297. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  18298. int(shape(values),kind=HSIZE_T), status, &
  18299. file_space_id=hdf5_file_space_id )
  18300. IF_NOT_OK_RETURN(status=1)
  18301. ! release data space:
  18302. call H5SClose_f( hdf5_file_space_id, status )
  18303. IF_NOT_OK_RETURN(status=1)
  18304. #endif
  18305. #ifdef with_netcdf
  18306. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18307. case ( MDF_NETCDF, MDF_NETCDF4 )
  18308. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18309. ! test target type:
  18310. ! convert to required kind before entering NF90_Put_Var,
  18311. ! otherwise segmentation faults on some machines ...
  18312. select case ( varp%xtype )
  18313. case ( MDF_BYTE )
  18314. allocate( values_int1(size(values,1)) )
  18315. values_int1 = int(values,kind=1)
  18316. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  18317. start, count, stride, map )
  18318. IF_NF90_NOT_OK_RETURN(status=1)
  18319. deallocate( values_int1 )
  18320. case ( MDF_SHORT )
  18321. allocate( values_int2(size(values,1)) )
  18322. values_int2 = int(values,kind=2)
  18323. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  18324. start, count, stride, map )
  18325. IF_NF90_NOT_OK_RETURN(status=1)
  18326. deallocate( values_int2 )
  18327. case ( MDF_INT )
  18328. allocate( values_int4(size(values,1)) )
  18329. values_int4 = int(values,kind=4)
  18330. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  18331. start, count, stride, map )
  18332. IF_NF90_NOT_OK_RETURN(status=1)
  18333. deallocate( values_int4 )
  18334. case ( MDF_FLOAT )
  18335. allocate( values_real4(size(values,1)) )
  18336. values_real4 = real(values,kind=4)
  18337. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  18338. start, count, stride, map )
  18339. IF_NF90_NOT_OK_RETURN(status=1)
  18340. deallocate( values_real4 )
  18341. case ( MDF_DOUBLE )
  18342. allocate( values_real8(size(values,1)) )
  18343. values_real8 = real(values,kind=8)
  18344. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  18345. start, count, stride, map )
  18346. IF_NF90_NOT_OK_RETURN(status=1)
  18347. deallocate( values_real8 )
  18348. case default
  18349. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  18350. TRACEBACK; status=1; return
  18351. end select
  18352. ! just put; let netcdf library convert the right kind:
  18353. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  18354. ! start, count, stride, map )
  18355. !IF_NF90_NOT_OK_RETURN(status=1)
  18356. #endif
  18357. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18358. case default
  18359. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18360. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  18361. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  18362. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  18363. TRACEBACK; status=1; return
  18364. end select
  18365. end do ! file types
  18366. ! ok
  18367. status = 0
  18368. end subroutine MDF_Put_Var_r8_1d
  18369. ! ***
  18370. subroutine MDF_Get_Var_r8_1d( hid, varid, values, status, &
  18371. start, count, stride, map )
  18372. #ifdef with_netcdf
  18373. use NetCDF, only : NF90_Get_Var
  18374. #endif
  18375. ! --- in/out -------------------------------------
  18376. integer, intent(in) :: hid
  18377. integer, intent(in) :: varid
  18378. real(8), intent(out) :: values(:)
  18379. integer, intent(out) :: status
  18380. integer, intent(in), optional :: start (:)
  18381. integer, intent(in), optional :: count (:)
  18382. integer, intent(in), optional :: stride(:)
  18383. integer, intent(in), optional :: map (:)
  18384. ! --- const --------------------------------------
  18385. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_1d'
  18386. ! --- external -----------------------------------
  18387. #ifdef with_hdf4
  18388. integer(hdf4_wpi), external :: sfRData
  18389. #endif
  18390. ! --- local --------------------------------------
  18391. type(MDF_File), pointer :: filep
  18392. type(MDF_Var), pointer :: varp
  18393. integer :: iftype
  18394. integer :: ftype
  18395. #ifdef with_hdf4
  18396. integer :: hdf4_offset(MAX_RANK)
  18397. integer :: hdf4_stride(MAX_RANK)
  18398. integer :: hdf4_count(MAX_RANK)
  18399. integer(1), allocatable :: values_int1(:)
  18400. integer(2), allocatable :: values_int2(:)
  18401. integer(4), allocatable :: values_int4(:)
  18402. integer(8), allocatable :: values_int8(:)
  18403. real(4), allocatable :: values_real4(:)
  18404. real(8), allocatable :: values_real8(:)
  18405. #endif
  18406. ! --- begin --------------------------------------
  18407. ! pointer to file structure:
  18408. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  18409. IF_NOT_OK_RETURN(status=1)
  18410. ! pointer to variable structure:
  18411. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  18412. IF_NOT_OK_RETURN(status=1)
  18413. ! check ...
  18414. if ( size(shape(values)) > varp%ndim ) then
  18415. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  18416. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  18417. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  18418. TRACEBACK; status=1; return
  18419. end if
  18420. ! check ...
  18421. if ( present(start ) ) then
  18422. if ( size(start ) /= varp%ndim ) then
  18423. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18424. write (gol,'(" size start : ",i6)') size(start ); call goErr
  18425. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18426. TRACEBACK; status=1; return
  18427. end if
  18428. end if
  18429. if ( present(count ) ) then
  18430. if ( size(count ) /= varp%ndim ) then
  18431. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18432. write (gol,'(" size count : ",i6)') size(count ); call goErr
  18433. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18434. TRACEBACK; status=1; return
  18435. end if
  18436. end if
  18437. if ( present(stride ) ) then
  18438. if ( size(stride ) /= varp%ndim ) then
  18439. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18440. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  18441. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18442. TRACEBACK; status=1; return
  18443. end if
  18444. end if
  18445. if ( present(map ) ) then
  18446. if ( size(map ) /= varp%ndim ) then
  18447. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18448. write (gol,'(" size map : ",i6)') size(map ); call goErr
  18449. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18450. TRACEBACK; status=1; return
  18451. end if
  18452. end if
  18453. ! loop over file types:
  18454. do iftype = 1, filep%nftype
  18455. ! current type:
  18456. ftype = filep%ftypes(iftype)
  18457. ! select appropriate routine for each type:
  18458. select case ( ftype )
  18459. #ifdef with_hdf4
  18460. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18461. case ( MDF_HDF4 )
  18462. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18463. ! check ...
  18464. if ( present(map ) ) then
  18465. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  18466. TRACEBACK; status=1; return
  18467. end if
  18468. ! fill offset (zero based!), stride, and count :
  18469. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  18470. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  18471. hdf4_count = 1 ! default singleton dimension
  18472. hdf4_count(1:1) = shape(values)
  18473. ! test source type:
  18474. select case ( varp%hdf4_xtype )
  18475. case ( DFNT_INT8 )
  18476. allocate( values_int1(size(values,1)) )
  18477. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  18478. values = real(values_int1,kind=8)
  18479. deallocate( values_int1 )
  18480. case ( DFNT_INT16 )
  18481. allocate( values_int2(size(values,1)) )
  18482. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  18483. values = real(values_int2,kind=8)
  18484. deallocate( values_int2 )
  18485. case ( DFNT_INT32 )
  18486. allocate( values_int4(size(values,1)) )
  18487. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  18488. values = real(values_int4,kind=8)
  18489. deallocate( values_int4 )
  18490. case ( DFNT_INT64 )
  18491. allocate( values_int8(size(values,1)) )
  18492. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  18493. values = real(values_int8,kind=8)
  18494. deallocate( values_int8 )
  18495. case ( DFNT_FLOAT32 )
  18496. allocate( values_real4(size(values,1)) )
  18497. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  18498. values = real(values_real4,kind=8)
  18499. deallocate( values_real4 )
  18500. case ( DFNT_FLOAT64 )
  18501. allocate( values_real8(size(values,1)) )
  18502. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  18503. values = real(values_real8,kind=8)
  18504. deallocate( values_real8 )
  18505. case default
  18506. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  18507. TRACEBACK; status=1; return
  18508. end select
  18509. if ( status == FAIL ) then
  18510. write (gol,'("reading hdf4 data set:")'); call goErr
  18511. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  18512. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  18513. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  18514. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  18515. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  18516. write (gol,'(" size : ",i6)') size(values); call goErr
  18517. TRACEBACK; status=1; return
  18518. end if
  18519. #endif
  18520. #ifdef with_netcdf
  18521. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18522. case ( MDF_NETCDF, MDF_NETCDF4 )
  18523. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18524. ! read values, converted automatically:
  18525. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  18526. start, count, stride, map )
  18527. IF_NF90_NOT_OK_RETURN(status=1)
  18528. #endif
  18529. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18530. case default
  18531. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18532. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  18533. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  18534. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  18535. TRACEBACK; status=1; return
  18536. end select
  18537. end do ! file types
  18538. ! ok
  18539. status = 0
  18540. end subroutine MDF_Get_Var_r8_1d
  18541. ! ***
  18542. subroutine MDF_Put_Var_r8_2d( hid, varid, values, status, &
  18543. start, count, stride, map )
  18544. #ifdef with_hdf5_beta
  18545. use HDF5, only : HID_T, HSIZE_T
  18546. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  18547. use HDF5, only : H5T_NATIVE_CHARACTER
  18548. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  18549. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  18550. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  18551. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  18552. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  18553. #endif
  18554. #ifdef with_netcdf
  18555. use NetCDF, only : NF90_Put_Var
  18556. #endif
  18557. ! --- in/out -------------------------------------
  18558. integer, intent(in) :: hid
  18559. integer, intent(in) :: varid
  18560. real(8), intent(in) :: values(:,:)
  18561. integer, intent(out) :: status
  18562. integer, intent(in), optional :: start (:)
  18563. integer, intent(in), optional :: count (:)
  18564. integer, intent(in), optional :: stride(:)
  18565. integer, intent(in), optional :: map (:)
  18566. ! --- const --------------------------------------
  18567. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_2d'
  18568. ! --- external -----------------------------------
  18569. #ifdef with_hdf4
  18570. integer(hdf4_wpi), external :: sfWData
  18571. #endif
  18572. ! --- local --------------------------------------
  18573. type(MDF_File), pointer :: filep
  18574. type(MDF_Var), pointer :: varp
  18575. integer :: iftype
  18576. integer :: ftype
  18577. #ifdef with_hdf4
  18578. integer :: hdf4_offset(MAX_RANK)
  18579. integer :: hdf4_stride(MAX_RANK)
  18580. integer :: hdf4_count(MAX_RANK)
  18581. #endif
  18582. #ifdef with_hdf5_beta
  18583. !integer(HID_T) :: hdf5_type_id
  18584. integer(HID_T) :: hdf5_file_space_id
  18585. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  18586. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  18587. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  18588. #endif
  18589. integer(1), allocatable :: values_int1(:,:)
  18590. integer(2), allocatable :: values_int2(:,:)
  18591. integer(4), allocatable :: values_int4(:,:)
  18592. integer(8), allocatable :: values_int8(:,:)
  18593. real(4), allocatable :: values_real4(:,:)
  18594. real(8), allocatable :: values_real8(:,:)
  18595. ! --- begin --------------------------------------
  18596. ! pointer to file structure:
  18597. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  18598. IF_NOT_OK_RETURN(status=1)
  18599. ! pointer to variable structure:
  18600. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  18601. IF_NOT_OK_RETURN(status=1)
  18602. ! check ...
  18603. if ( size(shape(values)) > varp%ndim ) then
  18604. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  18605. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  18606. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  18607. TRACEBACK; status=1; return
  18608. end if
  18609. ! check ...
  18610. if ( present(start ) ) then
  18611. if ( size(start ) /= varp%ndim ) then
  18612. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18613. write (gol,'(" size start : ",i6)') size(start ); call goErr
  18614. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18615. TRACEBACK; status=1; return
  18616. end if
  18617. end if
  18618. if ( present(count ) ) then
  18619. if ( size(count ) /= varp%ndim ) then
  18620. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18621. write (gol,'(" size count : ",i6)') size(count ); call goErr
  18622. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18623. TRACEBACK; status=1; return
  18624. end if
  18625. end if
  18626. if ( present(stride ) ) then
  18627. if ( size(stride ) /= varp%ndim ) then
  18628. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18629. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  18630. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18631. TRACEBACK; status=1; return
  18632. end if
  18633. end if
  18634. if ( present(map ) ) then
  18635. if ( size(map ) /= varp%ndim ) then
  18636. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18637. write (gol,'(" size map : ",i6)') size(map ); call goErr
  18638. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18639. TRACEBACK; status=1; return
  18640. end if
  18641. end if
  18642. ! loop over file types:
  18643. do iftype = 1, filep%nftype
  18644. ! current type:
  18645. ftype = filep%ftypes(iftype)
  18646. ! select appropriate routine for each type:
  18647. select case ( ftype )
  18648. #ifdef with_hdf4
  18649. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18650. case ( MDF_HDF4 )
  18651. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18652. ! check ...
  18653. if ( present(map ) ) then
  18654. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  18655. TRACEBACK; status=1; return
  18656. end if
  18657. ! fill offset (zero based!) and stride with default values:
  18658. hdf4_offset = 0
  18659. hdf4_stride = 1
  18660. ! count is by default the shape; padd with singleton dimensions:
  18661. hdf4_count = 1; hdf4_count(1:2) = shape(values)
  18662. ! replace by optional arguments if necessary:
  18663. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  18664. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  18665. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  18666. ! test target type;
  18667. ! convert to required kind before entering sfWData,
  18668. ! otherwise segmentation faults on some machines ...
  18669. select case ( varp%xtype )
  18670. case ( MDF_BYTE )
  18671. allocate( values_int1(size(values,1),size(values,2)) )
  18672. values_int1 = int(values,kind=1)
  18673. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18674. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  18675. deallocate( values_int1 )
  18676. case ( MDF_SHORT )
  18677. allocate( values_int2(size(values,1),size(values,2)) )
  18678. values_int2 = int(values,kind=2)
  18679. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18680. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  18681. deallocate( values_int2 )
  18682. case ( MDF_INT )
  18683. allocate( values_int4(size(values,1),size(values,2)) )
  18684. values_int4 = int(values,kind=4)
  18685. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18686. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  18687. deallocate( values_int4 )
  18688. case ( MDF_FLOAT )
  18689. allocate( values_real4(size(values,1),size(values,2)) )
  18690. values_real4 = real(values,kind=4)
  18691. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18692. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  18693. deallocate( values_real4 )
  18694. case ( MDF_DOUBLE )
  18695. allocate( values_real8(size(values,1),size(values,2)) )
  18696. values_real8 = real(values,kind=8)
  18697. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  18698. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  18699. deallocate( values_real8 )
  18700. case default
  18701. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  18702. TRACEBACK; status=1; return
  18703. end select
  18704. if ( status == FAIL ) then
  18705. write (gol,'("writing hdf4 data set:")'); call goErr
  18706. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  18707. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  18708. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  18709. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  18710. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  18711. write (gol,'(" size : ",i12)') size(values); call goErr
  18712. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  18713. TRACEBACK; status=1; return
  18714. end if
  18715. #endif
  18716. #ifdef with_hdf5_beta
  18717. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18718. case ( MDF_HDF5 )
  18719. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18720. ! check ...
  18721. if ( present(map ) ) then
  18722. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  18723. TRACEBACK; status=1; return
  18724. end if
  18725. ! fill offset (zero based!), stride, and count :
  18726. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  18727. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  18728. hdf5_count = 1 ! default singleton dimension
  18729. if ( present(count) ) then
  18730. hdf5_count(1:varp%ndim) = count
  18731. else
  18732. hdf5_count(1:2) = shape(values)
  18733. end if
  18734. ! new dimension:
  18735. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  18736. ! target data space in file:
  18737. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  18738. IF_NOT_OK_RETURN(status=1)
  18739. ! chunked dataset ?
  18740. if ( varp%hdf5_chunked ) then
  18741. ! reset extend:
  18742. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  18743. IF_NOT_OK_RETURN(status=1)
  18744. end if
  18745. ! select hyperslab:
  18746. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  18747. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  18748. stride=hdf5_stride(1:varp%ndim) )
  18749. ! write data:
  18750. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  18751. int(shape(values),kind=HSIZE_T), status, &
  18752. file_space_id=hdf5_file_space_id )
  18753. IF_NOT_OK_RETURN(status=1)
  18754. ! release data space:
  18755. call H5SClose_f( hdf5_file_space_id, status )
  18756. IF_NOT_OK_RETURN(status=1)
  18757. #endif
  18758. #ifdef with_netcdf
  18759. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18760. case ( MDF_NETCDF, MDF_NETCDF4 )
  18761. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18762. ! test target type:
  18763. ! convert to required kind before entering NF90_Put_Var,
  18764. ! otherwise segmentation faults on some machines ...
  18765. select case ( varp%xtype )
  18766. case ( MDF_BYTE )
  18767. allocate( values_int1(size(values,1),size(values,2)) )
  18768. values_int1 = int(values,kind=1)
  18769. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  18770. start, count, stride, map )
  18771. IF_NF90_NOT_OK_RETURN(status=1)
  18772. deallocate( values_int1 )
  18773. case ( MDF_SHORT )
  18774. allocate( values_int2(size(values,1),size(values,2)) )
  18775. values_int2 = int(values,kind=2)
  18776. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  18777. start, count, stride, map )
  18778. IF_NF90_NOT_OK_RETURN(status=1)
  18779. deallocate( values_int2 )
  18780. case ( MDF_INT )
  18781. allocate( values_int4(size(values,1),size(values,2)) )
  18782. values_int4 = int(values,kind=4)
  18783. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  18784. start, count, stride, map )
  18785. IF_NF90_NOT_OK_RETURN(status=1)
  18786. deallocate( values_int4 )
  18787. case ( MDF_FLOAT )
  18788. allocate( values_real4(size(values,1),size(values,2)) )
  18789. values_real4 = real(values,kind=4)
  18790. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  18791. start, count, stride, map )
  18792. IF_NF90_NOT_OK_RETURN(status=1)
  18793. deallocate( values_real4 )
  18794. case ( MDF_DOUBLE )
  18795. allocate( values_real8(size(values,1),size(values,2)) )
  18796. values_real8 = real(values,kind=8)
  18797. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  18798. start, count, stride, map )
  18799. IF_NF90_NOT_OK_RETURN(status=1)
  18800. deallocate( values_real8 )
  18801. case default
  18802. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  18803. TRACEBACK; status=1; return
  18804. end select
  18805. ! just put; let netcdf library convert the right kind:
  18806. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  18807. ! start, count, stride, map )
  18808. !IF_NF90_NOT_OK_RETURN(status=1)
  18809. #endif
  18810. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18811. case default
  18812. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18813. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  18814. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  18815. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  18816. TRACEBACK; status=1; return
  18817. end select
  18818. end do ! file types
  18819. ! ok
  18820. status = 0
  18821. end subroutine MDF_Put_Var_r8_2d
  18822. ! ***
  18823. subroutine MDF_Get_Var_r8_2d( hid, varid, values, status, &
  18824. start, count, stride, map )
  18825. #ifdef with_netcdf
  18826. use NetCDF, only : NF90_Get_Var
  18827. #endif
  18828. ! --- in/out -------------------------------------
  18829. integer, intent(in) :: hid
  18830. integer, intent(in) :: varid
  18831. real(8), intent(out) :: values(:,:)
  18832. integer, intent(out) :: status
  18833. integer, intent(in), optional :: start (:)
  18834. integer, intent(in), optional :: count (:)
  18835. integer, intent(in), optional :: stride(:)
  18836. integer, intent(in), optional :: map (:)
  18837. ! --- const --------------------------------------
  18838. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_2d'
  18839. ! --- external -----------------------------------
  18840. #ifdef with_hdf4
  18841. integer(hdf4_wpi), external :: sfRData
  18842. #endif
  18843. ! --- local --------------------------------------
  18844. type(MDF_File), pointer :: filep
  18845. type(MDF_Var), pointer :: varp
  18846. integer :: iftype
  18847. integer :: ftype
  18848. #ifdef with_hdf4
  18849. integer :: hdf4_offset(MAX_RANK)
  18850. integer :: hdf4_stride(MAX_RANK)
  18851. integer :: hdf4_count(MAX_RANK)
  18852. integer(1), allocatable :: values_int1(:,:)
  18853. integer(2), allocatable :: values_int2(:,:)
  18854. integer(4), allocatable :: values_int4(:,:)
  18855. integer(8), allocatable :: values_int8(:,:)
  18856. real(4), allocatable :: values_real4(:,:)
  18857. real(8), allocatable :: values_real8(:,:)
  18858. #endif
  18859. ! --- begin --------------------------------------
  18860. ! pointer to file structure:
  18861. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  18862. IF_NOT_OK_RETURN(status=1)
  18863. ! pointer to variable structure:
  18864. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  18865. IF_NOT_OK_RETURN(status=1)
  18866. ! check ...
  18867. if ( size(shape(values)) > varp%ndim ) then
  18868. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  18869. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  18870. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  18871. TRACEBACK; status=1; return
  18872. end if
  18873. ! check ...
  18874. if ( present(start ) ) then
  18875. if ( size(start ) /= varp%ndim ) then
  18876. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18877. write (gol,'(" size start : ",i6)') size(start ); call goErr
  18878. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18879. TRACEBACK; status=1; return
  18880. end if
  18881. end if
  18882. if ( present(count ) ) then
  18883. if ( size(count ) /= varp%ndim ) then
  18884. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18885. write (gol,'(" size count : ",i6)') size(count ); call goErr
  18886. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18887. TRACEBACK; status=1; return
  18888. end if
  18889. end if
  18890. if ( present(stride ) ) then
  18891. if ( size(stride ) /= varp%ndim ) then
  18892. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18893. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  18894. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18895. TRACEBACK; status=1; return
  18896. end if
  18897. end if
  18898. if ( present(map ) ) then
  18899. if ( size(map ) /= varp%ndim ) then
  18900. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  18901. write (gol,'(" size map : ",i6)') size(map ); call goErr
  18902. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  18903. TRACEBACK; status=1; return
  18904. end if
  18905. end if
  18906. ! loop over file types:
  18907. do iftype = 1, filep%nftype
  18908. ! current type:
  18909. ftype = filep%ftypes(iftype)
  18910. ! select appropriate routine for each type:
  18911. select case ( ftype )
  18912. #ifdef with_hdf4
  18913. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18914. case ( MDF_HDF4 )
  18915. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18916. ! check ...
  18917. if ( present(map ) ) then
  18918. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  18919. TRACEBACK; status=1; return
  18920. end if
  18921. ! fill offset (zero based!), stride, and count :
  18922. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  18923. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  18924. hdf4_count = 1 ! default singleton dimension
  18925. hdf4_count(1:2) = shape(values)
  18926. ! test source type:
  18927. select case ( varp%hdf4_xtype )
  18928. case ( DFNT_INT8 )
  18929. allocate( values_int1(size(values,1),size(values,2)) )
  18930. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  18931. values = real(values_int1,kind=8)
  18932. deallocate( values_int1 )
  18933. case ( DFNT_INT16 )
  18934. allocate( values_int2(size(values,1),size(values,2)) )
  18935. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  18936. values = real(values_int2,kind=8)
  18937. deallocate( values_int2 )
  18938. case ( DFNT_INT32 )
  18939. allocate( values_int4(size(values,1),size(values,2)) )
  18940. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  18941. values = real(values_int4,kind=8)
  18942. deallocate( values_int4 )
  18943. case ( DFNT_INT64 )
  18944. allocate( values_int8(size(values,1),size(values,2)) )
  18945. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  18946. values = real(values_int8,kind=8)
  18947. deallocate( values_int8 )
  18948. case ( DFNT_FLOAT32 )
  18949. allocate( values_real4(size(values,1),size(values,2)) )
  18950. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  18951. values = real(values_real4,kind=8)
  18952. deallocate( values_real4 )
  18953. case ( DFNT_FLOAT64 )
  18954. allocate( values_real8(size(values,1),size(values,2)) )
  18955. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  18956. values = real(values_real8,kind=8)
  18957. deallocate( values_real8 )
  18958. case default
  18959. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  18960. TRACEBACK; status=1; return
  18961. end select
  18962. if ( status == FAIL ) then
  18963. write (gol,'("reading hdf4 data set:")'); call goErr
  18964. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  18965. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  18966. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  18967. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  18968. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  18969. write (gol,'(" size : ",i6)') size(values); call goErr
  18970. TRACEBACK; status=1; return
  18971. end if
  18972. #endif
  18973. #ifdef with_netcdf
  18974. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18975. case ( MDF_NETCDF, MDF_NETCDF4 )
  18976. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18977. ! read values, converted automatically:
  18978. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  18979. start, count, stride, map )
  18980. IF_NF90_NOT_OK_RETURN(status=1)
  18981. #endif
  18982. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18983. case default
  18984. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  18985. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  18986. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  18987. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  18988. TRACEBACK; status=1; return
  18989. end select
  18990. end do ! file types
  18991. ! ok
  18992. status = 0
  18993. end subroutine MDF_Get_Var_r8_2d
  18994. ! ***
  18995. subroutine MDF_Put_Var_r8_3d( hid, varid, values, status, &
  18996. start, count, stride, map )
  18997. #ifdef with_hdf5_beta
  18998. use HDF5, only : HID_T, HSIZE_T
  18999. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  19000. use HDF5, only : H5T_NATIVE_CHARACTER
  19001. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  19002. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  19003. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  19004. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  19005. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  19006. #endif
  19007. #ifdef with_netcdf
  19008. use NetCDF, only : NF90_Put_Var
  19009. #endif
  19010. ! --- in/out -------------------------------------
  19011. integer, intent(in) :: hid
  19012. integer, intent(in) :: varid
  19013. real(8), intent(in) :: values(:,:,:)
  19014. integer, intent(out) :: status
  19015. integer, intent(in), optional :: start (:)
  19016. integer, intent(in), optional :: count (:)
  19017. integer, intent(in), optional :: stride(:)
  19018. integer, intent(in), optional :: map (:)
  19019. ! --- const --------------------------------------
  19020. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_3d'
  19021. ! --- external -----------------------------------
  19022. #ifdef with_hdf4
  19023. integer(hdf4_wpi), external :: sfWData
  19024. #endif
  19025. ! --- local --------------------------------------
  19026. type(MDF_File), pointer :: filep
  19027. type(MDF_Var), pointer :: varp
  19028. integer :: iftype
  19029. integer :: ftype
  19030. #ifdef with_hdf4
  19031. integer :: hdf4_offset(MAX_RANK)
  19032. integer :: hdf4_stride(MAX_RANK)
  19033. integer :: hdf4_count(MAX_RANK)
  19034. #endif
  19035. #ifdef with_hdf5_beta
  19036. !integer(HID_T) :: hdf5_type_id
  19037. integer(HID_T) :: hdf5_file_space_id
  19038. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  19039. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  19040. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  19041. #endif
  19042. integer(1), allocatable :: values_int1(:,:,:)
  19043. integer(2), allocatable :: values_int2(:,:,:)
  19044. integer(4), allocatable :: values_int4(:,:,:)
  19045. integer(8), allocatable :: values_int8(:,:,:)
  19046. real(4), allocatable :: values_real4(:,:,:)
  19047. real(8), allocatable :: values_real8(:,:,:)
  19048. ! --- begin --------------------------------------
  19049. ! pointer to file structure:
  19050. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  19051. IF_NOT_OK_RETURN(status=1)
  19052. ! pointer to variable structure:
  19053. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  19054. IF_NOT_OK_RETURN(status=1)
  19055. ! check ...
  19056. if ( size(shape(values)) > varp%ndim ) then
  19057. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  19058. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  19059. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  19060. TRACEBACK; status=1; return
  19061. end if
  19062. ! check ...
  19063. if ( present(start ) ) then
  19064. if ( size(start ) /= varp%ndim ) then
  19065. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19066. write (gol,'(" size start : ",i6)') size(start ); call goErr
  19067. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19068. TRACEBACK; status=1; return
  19069. end if
  19070. end if
  19071. if ( present(count ) ) then
  19072. if ( size(count ) /= varp%ndim ) then
  19073. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19074. write (gol,'(" size count : ",i6)') size(count ); call goErr
  19075. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19076. TRACEBACK; status=1; return
  19077. end if
  19078. end if
  19079. if ( present(stride ) ) then
  19080. if ( size(stride ) /= varp%ndim ) then
  19081. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19082. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  19083. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19084. TRACEBACK; status=1; return
  19085. end if
  19086. end if
  19087. if ( present(map ) ) then
  19088. if ( size(map ) /= varp%ndim ) then
  19089. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19090. write (gol,'(" size map : ",i6)') size(map ); call goErr
  19091. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19092. TRACEBACK; status=1; return
  19093. end if
  19094. end if
  19095. ! loop over file types:
  19096. do iftype = 1, filep%nftype
  19097. ! current type:
  19098. ftype = filep%ftypes(iftype)
  19099. ! select appropriate routine for each type:
  19100. select case ( ftype )
  19101. #ifdef with_hdf4
  19102. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19103. case ( MDF_HDF4 )
  19104. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19105. ! check ...
  19106. if ( present(map ) ) then
  19107. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  19108. TRACEBACK; status=1; return
  19109. end if
  19110. ! fill offset (zero based!) and stride with default values:
  19111. hdf4_offset = 0
  19112. hdf4_stride = 1
  19113. ! count is by default the shape; padd with singleton dimensions:
  19114. hdf4_count = 1; hdf4_count(1:3) = shape(values)
  19115. ! replace by optional arguments if necessary:
  19116. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  19117. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  19118. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  19119. ! test target type;
  19120. ! convert to required kind before entering sfWData,
  19121. ! otherwise segmentation faults on some machines ...
  19122. select case ( varp%xtype )
  19123. case ( MDF_BYTE )
  19124. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  19125. values_int1 = int(values,kind=1)
  19126. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19127. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  19128. deallocate( values_int1 )
  19129. case ( MDF_SHORT )
  19130. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  19131. values_int2 = int(values,kind=2)
  19132. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19133. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  19134. deallocate( values_int2 )
  19135. case ( MDF_INT )
  19136. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  19137. values_int4 = int(values,kind=4)
  19138. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19139. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  19140. deallocate( values_int4 )
  19141. case ( MDF_FLOAT )
  19142. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  19143. values_real4 = real(values,kind=4)
  19144. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19145. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  19146. deallocate( values_real4 )
  19147. case ( MDF_DOUBLE )
  19148. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  19149. values_real8 = real(values,kind=8)
  19150. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19151. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  19152. deallocate( values_real8 )
  19153. case default
  19154. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  19155. TRACEBACK; status=1; return
  19156. end select
  19157. if ( status == FAIL ) then
  19158. write (gol,'("writing hdf4 data set:")'); call goErr
  19159. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  19160. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  19161. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  19162. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  19163. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  19164. write (gol,'(" size : ",i12)') size(values); call goErr
  19165. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  19166. TRACEBACK; status=1; return
  19167. end if
  19168. #endif
  19169. #ifdef with_hdf5_beta
  19170. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19171. case ( MDF_HDF5 )
  19172. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19173. ! check ...
  19174. if ( present(map ) ) then
  19175. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  19176. TRACEBACK; status=1; return
  19177. end if
  19178. ! fill offset (zero based!), stride, and count :
  19179. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  19180. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  19181. hdf5_count = 1 ! default singleton dimension
  19182. if ( present(count) ) then
  19183. hdf5_count(1:varp%ndim) = count
  19184. else
  19185. hdf5_count(1:3) = shape(values)
  19186. end if
  19187. ! new dimension:
  19188. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  19189. ! target data space in file:
  19190. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  19191. IF_NOT_OK_RETURN(status=1)
  19192. ! chunked dataset ?
  19193. if ( varp%hdf5_chunked ) then
  19194. ! reset extend:
  19195. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  19196. IF_NOT_OK_RETURN(status=1)
  19197. end if
  19198. ! select hyperslab:
  19199. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  19200. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  19201. stride=hdf5_stride(1:varp%ndim) )
  19202. ! write data:
  19203. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  19204. int(shape(values),kind=HSIZE_T), status, &
  19205. file_space_id=hdf5_file_space_id )
  19206. IF_NOT_OK_RETURN(status=1)
  19207. ! release data space:
  19208. call H5SClose_f( hdf5_file_space_id, status )
  19209. IF_NOT_OK_RETURN(status=1)
  19210. #endif
  19211. #ifdef with_netcdf
  19212. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19213. case ( MDF_NETCDF, MDF_NETCDF4 )
  19214. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19215. ! test target type:
  19216. ! convert to required kind before entering NF90_Put_Var,
  19217. ! otherwise segmentation faults on some machines ...
  19218. select case ( varp%xtype )
  19219. case ( MDF_BYTE )
  19220. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  19221. values_int1 = int(values,kind=1)
  19222. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  19223. start, count, stride, map )
  19224. IF_NF90_NOT_OK_RETURN(status=1)
  19225. deallocate( values_int1 )
  19226. case ( MDF_SHORT )
  19227. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  19228. values_int2 = int(values,kind=2)
  19229. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  19230. start, count, stride, map )
  19231. IF_NF90_NOT_OK_RETURN(status=1)
  19232. deallocate( values_int2 )
  19233. case ( MDF_INT )
  19234. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  19235. values_int4 = int(values,kind=4)
  19236. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  19237. start, count, stride, map )
  19238. IF_NF90_NOT_OK_RETURN(status=1)
  19239. deallocate( values_int4 )
  19240. case ( MDF_FLOAT )
  19241. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  19242. values_real4 = real(values,kind=4)
  19243. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  19244. start, count, stride, map )
  19245. IF_NF90_NOT_OK_RETURN(status=1)
  19246. deallocate( values_real4 )
  19247. case ( MDF_DOUBLE )
  19248. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  19249. values_real8 = real(values,kind=8)
  19250. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  19251. start, count, stride, map )
  19252. IF_NF90_NOT_OK_RETURN(status=1)
  19253. deallocate( values_real8 )
  19254. case default
  19255. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  19256. TRACEBACK; status=1; return
  19257. end select
  19258. ! just put; let netcdf library convert the right kind:
  19259. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  19260. ! start, count, stride, map )
  19261. !IF_NF90_NOT_OK_RETURN(status=1)
  19262. #endif
  19263. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19264. case default
  19265. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19266. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  19267. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  19268. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  19269. TRACEBACK; status=1; return
  19270. end select
  19271. end do ! file types
  19272. ! ok
  19273. status = 0
  19274. end subroutine MDF_Put_Var_r8_3d
  19275. ! ***
  19276. subroutine MDF_Get_Var_r8_3d( hid, varid, values, status, &
  19277. start, count, stride, map )
  19278. #ifdef with_netcdf
  19279. use NetCDF, only : NF90_Get_Var
  19280. #endif
  19281. ! --- in/out -------------------------------------
  19282. integer, intent(in) :: hid
  19283. integer, intent(in) :: varid
  19284. real(8), intent(out) :: values(:,:,:)
  19285. integer, intent(out) :: status
  19286. integer, intent(in), optional :: start (:)
  19287. integer, intent(in), optional :: count (:)
  19288. integer, intent(in), optional :: stride(:)
  19289. integer, intent(in), optional :: map (:)
  19290. ! --- const --------------------------------------
  19291. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_3d'
  19292. ! --- external -----------------------------------
  19293. #ifdef with_hdf4
  19294. integer(hdf4_wpi), external :: sfRData
  19295. #endif
  19296. ! --- local --------------------------------------
  19297. type(MDF_File), pointer :: filep
  19298. type(MDF_Var), pointer :: varp
  19299. integer :: iftype
  19300. integer :: ftype
  19301. #ifdef with_hdf4
  19302. integer :: hdf4_offset(MAX_RANK)
  19303. integer :: hdf4_stride(MAX_RANK)
  19304. integer :: hdf4_count(MAX_RANK)
  19305. integer(1), allocatable :: values_int1(:,:,:)
  19306. integer(2), allocatable :: values_int2(:,:,:)
  19307. integer(4), allocatable :: values_int4(:,:,:)
  19308. integer(8), allocatable :: values_int8(:,:,:)
  19309. real(4), allocatable :: values_real4(:,:,:)
  19310. real(8), allocatable :: values_real8(:,:,:)
  19311. #endif
  19312. ! --- begin --------------------------------------
  19313. ! pointer to file structure:
  19314. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  19315. IF_NOT_OK_RETURN(status=1)
  19316. ! pointer to variable structure:
  19317. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  19318. IF_NOT_OK_RETURN(status=1)
  19319. ! check ...
  19320. if ( size(shape(values)) > varp%ndim ) then
  19321. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  19322. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  19323. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  19324. TRACEBACK; status=1; return
  19325. end if
  19326. ! check ...
  19327. if ( present(start ) ) then
  19328. if ( size(start ) /= varp%ndim ) then
  19329. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19330. write (gol,'(" size start : ",i6)') size(start ); call goErr
  19331. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19332. TRACEBACK; status=1; return
  19333. end if
  19334. end if
  19335. if ( present(count ) ) then
  19336. if ( size(count ) /= varp%ndim ) then
  19337. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19338. write (gol,'(" size count : ",i6)') size(count ); call goErr
  19339. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19340. TRACEBACK; status=1; return
  19341. end if
  19342. end if
  19343. if ( present(stride ) ) then
  19344. if ( size(stride ) /= varp%ndim ) then
  19345. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19346. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  19347. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19348. TRACEBACK; status=1; return
  19349. end if
  19350. end if
  19351. if ( present(map ) ) then
  19352. if ( size(map ) /= varp%ndim ) then
  19353. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19354. write (gol,'(" size map : ",i6)') size(map ); call goErr
  19355. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19356. TRACEBACK; status=1; return
  19357. end if
  19358. end if
  19359. ! loop over file types:
  19360. do iftype = 1, filep%nftype
  19361. ! current type:
  19362. ftype = filep%ftypes(iftype)
  19363. ! select appropriate routine for each type:
  19364. select case ( ftype )
  19365. #ifdef with_hdf4
  19366. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19367. case ( MDF_HDF4 )
  19368. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19369. ! check ...
  19370. if ( present(map ) ) then
  19371. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  19372. TRACEBACK; status=1; return
  19373. end if
  19374. ! fill offset (zero based!), stride, and count :
  19375. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  19376. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  19377. hdf4_count = 1 ! default singleton dimension
  19378. hdf4_count(1:3) = shape(values)
  19379. ! test source type:
  19380. select case ( varp%hdf4_xtype )
  19381. case ( DFNT_INT8 )
  19382. allocate( values_int1(size(values,1),size(values,2),size(values,3)) )
  19383. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  19384. values = real(values_int1,kind=8)
  19385. deallocate( values_int1 )
  19386. case ( DFNT_INT16 )
  19387. allocate( values_int2(size(values,1),size(values,2),size(values,3)) )
  19388. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  19389. values = real(values_int2,kind=8)
  19390. deallocate( values_int2 )
  19391. case ( DFNT_INT32 )
  19392. allocate( values_int4(size(values,1),size(values,2),size(values,3)) )
  19393. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  19394. values = real(values_int4,kind=8)
  19395. deallocate( values_int4 )
  19396. case ( DFNT_INT64 )
  19397. allocate( values_int8(size(values,1),size(values,2),size(values,3)) )
  19398. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  19399. values = real(values_int8,kind=8)
  19400. deallocate( values_int8 )
  19401. case ( DFNT_FLOAT32 )
  19402. allocate( values_real4(size(values,1),size(values,2),size(values,3)) )
  19403. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  19404. values = real(values_real4,kind=8)
  19405. deallocate( values_real4 )
  19406. case ( DFNT_FLOAT64 )
  19407. allocate( values_real8(size(values,1),size(values,2),size(values,3)) )
  19408. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  19409. values = real(values_real8,kind=8)
  19410. deallocate( values_real8 )
  19411. case default
  19412. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  19413. TRACEBACK; status=1; return
  19414. end select
  19415. if ( status == FAIL ) then
  19416. write (gol,'("reading hdf4 data set:")'); call goErr
  19417. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  19418. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  19419. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  19420. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  19421. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  19422. write (gol,'(" size : ",i6)') size(values); call goErr
  19423. TRACEBACK; status=1; return
  19424. end if
  19425. #endif
  19426. #ifdef with_netcdf
  19427. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19428. case ( MDF_NETCDF, MDF_NETCDF4 )
  19429. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19430. ! read values, converted automatically:
  19431. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  19432. start, count, stride, map )
  19433. IF_NF90_NOT_OK_RETURN(status=1)
  19434. #endif
  19435. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19436. case default
  19437. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19438. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  19439. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  19440. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  19441. TRACEBACK; status=1; return
  19442. end select
  19443. end do ! file types
  19444. ! ok
  19445. status = 0
  19446. end subroutine MDF_Get_Var_r8_3d
  19447. ! ***
  19448. subroutine MDF_Put_Var_r8_4d( hid, varid, values, status, &
  19449. start, count, stride, map )
  19450. #ifdef with_hdf5_beta
  19451. use HDF5, only : HID_T, HSIZE_T
  19452. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  19453. use HDF5, only : H5T_NATIVE_CHARACTER
  19454. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  19455. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  19456. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  19457. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  19458. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  19459. #endif
  19460. #ifdef with_netcdf
  19461. use NetCDF, only : NF90_Put_Var
  19462. #endif
  19463. ! --- in/out -------------------------------------
  19464. integer, intent(in) :: hid
  19465. integer, intent(in) :: varid
  19466. real(8), intent(in) :: values(:,:,:,:)
  19467. integer, intent(out) :: status
  19468. integer, intent(in), optional :: start (:)
  19469. integer, intent(in), optional :: count (:)
  19470. integer, intent(in), optional :: stride(:)
  19471. integer, intent(in), optional :: map (:)
  19472. ! --- const --------------------------------------
  19473. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_4d'
  19474. ! --- external -----------------------------------
  19475. #ifdef with_hdf4
  19476. integer(hdf4_wpi), external :: sfWData
  19477. #endif
  19478. ! --- local --------------------------------------
  19479. type(MDF_File), pointer :: filep
  19480. type(MDF_Var), pointer :: varp
  19481. integer :: iftype
  19482. integer :: ftype
  19483. #ifdef with_hdf4
  19484. integer :: hdf4_offset(MAX_RANK)
  19485. integer :: hdf4_stride(MAX_RANK)
  19486. integer :: hdf4_count(MAX_RANK)
  19487. #endif
  19488. #ifdef with_hdf5_beta
  19489. !integer(HID_T) :: hdf5_type_id
  19490. integer(HID_T) :: hdf5_file_space_id
  19491. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  19492. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  19493. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  19494. #endif
  19495. integer(1), allocatable :: values_int1(:,:,:,:)
  19496. integer(2), allocatable :: values_int2(:,:,:,:)
  19497. integer(4), allocatable :: values_int4(:,:,:,:)
  19498. integer(8), allocatable :: values_int8(:,:,:,:)
  19499. real(4), allocatable :: values_real4(:,:,:,:)
  19500. real(8), allocatable :: values_real8(:,:,:,:)
  19501. ! --- begin --------------------------------------
  19502. ! pointer to file structure:
  19503. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  19504. IF_NOT_OK_RETURN(status=1)
  19505. ! pointer to variable structure:
  19506. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  19507. IF_NOT_OK_RETURN(status=1)
  19508. ! check ...
  19509. if ( size(shape(values)) > varp%ndim ) then
  19510. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  19511. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  19512. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  19513. TRACEBACK; status=1; return
  19514. end if
  19515. ! check ...
  19516. if ( present(start ) ) then
  19517. if ( size(start ) /= varp%ndim ) then
  19518. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19519. write (gol,'(" size start : ",i6)') size(start ); call goErr
  19520. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19521. TRACEBACK; status=1; return
  19522. end if
  19523. end if
  19524. if ( present(count ) ) then
  19525. if ( size(count ) /= varp%ndim ) then
  19526. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19527. write (gol,'(" size count : ",i6)') size(count ); call goErr
  19528. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19529. TRACEBACK; status=1; return
  19530. end if
  19531. end if
  19532. if ( present(stride ) ) then
  19533. if ( size(stride ) /= varp%ndim ) then
  19534. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19535. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  19536. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19537. TRACEBACK; status=1; return
  19538. end if
  19539. end if
  19540. if ( present(map ) ) then
  19541. if ( size(map ) /= varp%ndim ) then
  19542. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19543. write (gol,'(" size map : ",i6)') size(map ); call goErr
  19544. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19545. TRACEBACK; status=1; return
  19546. end if
  19547. end if
  19548. ! loop over file types:
  19549. do iftype = 1, filep%nftype
  19550. ! current type:
  19551. ftype = filep%ftypes(iftype)
  19552. ! select appropriate routine for each type:
  19553. select case ( ftype )
  19554. #ifdef with_hdf4
  19555. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19556. case ( MDF_HDF4 )
  19557. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19558. ! check ...
  19559. if ( present(map ) ) then
  19560. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  19561. TRACEBACK; status=1; return
  19562. end if
  19563. ! fill offset (zero based!) and stride with default values:
  19564. hdf4_offset = 0
  19565. hdf4_stride = 1
  19566. ! count is by default the shape; padd with singleton dimensions:
  19567. hdf4_count = 1; hdf4_count(1:4) = shape(values)
  19568. ! replace by optional arguments if necessary:
  19569. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  19570. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  19571. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  19572. ! test target type;
  19573. ! convert to required kind before entering sfWData,
  19574. ! otherwise segmentation faults on some machines ...
  19575. select case ( varp%xtype )
  19576. case ( MDF_BYTE )
  19577. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19578. values_int1 = int(values,kind=1)
  19579. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19580. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  19581. deallocate( values_int1 )
  19582. case ( MDF_SHORT )
  19583. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19584. values_int2 = int(values,kind=2)
  19585. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19586. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  19587. deallocate( values_int2 )
  19588. case ( MDF_INT )
  19589. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19590. values_int4 = int(values,kind=4)
  19591. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19592. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  19593. deallocate( values_int4 )
  19594. case ( MDF_FLOAT )
  19595. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19596. values_real4 = real(values,kind=4)
  19597. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19598. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  19599. deallocate( values_real4 )
  19600. case ( MDF_DOUBLE )
  19601. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19602. values_real8 = real(values,kind=8)
  19603. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  19604. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  19605. deallocate( values_real8 )
  19606. case default
  19607. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  19608. TRACEBACK; status=1; return
  19609. end select
  19610. if ( status == FAIL ) then
  19611. write (gol,'("writing hdf4 data set:")'); call goErr
  19612. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  19613. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  19614. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  19615. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  19616. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  19617. write (gol,'(" size : ",i12)') size(values); call goErr
  19618. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  19619. TRACEBACK; status=1; return
  19620. end if
  19621. #endif
  19622. #ifdef with_hdf5_beta
  19623. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19624. case ( MDF_HDF5 )
  19625. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19626. ! check ...
  19627. if ( present(map ) ) then
  19628. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  19629. TRACEBACK; status=1; return
  19630. end if
  19631. ! fill offset (zero based!), stride, and count :
  19632. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  19633. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  19634. hdf5_count = 1 ! default singleton dimension
  19635. if ( present(count) ) then
  19636. hdf5_count(1:varp%ndim) = count
  19637. else
  19638. hdf5_count(1:4) = shape(values)
  19639. end if
  19640. ! new dimension:
  19641. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  19642. ! target data space in file:
  19643. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  19644. IF_NOT_OK_RETURN(status=1)
  19645. ! chunked dataset ?
  19646. if ( varp%hdf5_chunked ) then
  19647. ! reset extend:
  19648. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  19649. IF_NOT_OK_RETURN(status=1)
  19650. end if
  19651. ! select hyperslab:
  19652. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  19653. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  19654. stride=hdf5_stride(1:varp%ndim) )
  19655. ! write data:
  19656. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  19657. int(shape(values),kind=HSIZE_T), status, &
  19658. file_space_id=hdf5_file_space_id )
  19659. IF_NOT_OK_RETURN(status=1)
  19660. ! release data space:
  19661. call H5SClose_f( hdf5_file_space_id, status )
  19662. IF_NOT_OK_RETURN(status=1)
  19663. #endif
  19664. #ifdef with_netcdf
  19665. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19666. case ( MDF_NETCDF, MDF_NETCDF4 )
  19667. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19668. ! test target type:
  19669. ! convert to required kind before entering NF90_Put_Var,
  19670. ! otherwise segmentation faults on some machines ...
  19671. select case ( varp%xtype )
  19672. case ( MDF_BYTE )
  19673. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19674. values_int1 = int(values,kind=1)
  19675. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  19676. start, count, stride, map )
  19677. IF_NF90_NOT_OK_RETURN(status=1)
  19678. deallocate( values_int1 )
  19679. case ( MDF_SHORT )
  19680. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19681. values_int2 = int(values,kind=2)
  19682. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  19683. start, count, stride, map )
  19684. IF_NF90_NOT_OK_RETURN(status=1)
  19685. deallocate( values_int2 )
  19686. case ( MDF_INT )
  19687. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19688. values_int4 = int(values,kind=4)
  19689. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  19690. start, count, stride, map )
  19691. IF_NF90_NOT_OK_RETURN(status=1)
  19692. deallocate( values_int4 )
  19693. case ( MDF_FLOAT )
  19694. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19695. values_real4 = real(values,kind=4)
  19696. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  19697. start, count, stride, map )
  19698. IF_NF90_NOT_OK_RETURN(status=1)
  19699. deallocate( values_real4 )
  19700. case ( MDF_DOUBLE )
  19701. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19702. values_real8 = real(values,kind=8)
  19703. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  19704. start, count, stride, map )
  19705. IF_NF90_NOT_OK_RETURN(status=1)
  19706. deallocate( values_real8 )
  19707. case default
  19708. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  19709. TRACEBACK; status=1; return
  19710. end select
  19711. ! just put; let netcdf library convert the right kind:
  19712. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  19713. ! start, count, stride, map )
  19714. !IF_NF90_NOT_OK_RETURN(status=1)
  19715. #endif
  19716. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19717. case default
  19718. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19719. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  19720. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  19721. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  19722. TRACEBACK; status=1; return
  19723. end select
  19724. end do ! file types
  19725. ! ok
  19726. status = 0
  19727. end subroutine MDF_Put_Var_r8_4d
  19728. ! ***
  19729. subroutine MDF_Get_Var_r8_4d( hid, varid, values, status, &
  19730. start, count, stride, map )
  19731. #ifdef with_netcdf
  19732. use NetCDF, only : NF90_Get_Var
  19733. #endif
  19734. ! --- in/out -------------------------------------
  19735. integer, intent(in) :: hid
  19736. integer, intent(in) :: varid
  19737. real(8), intent(out) :: values(:,:,:,:)
  19738. integer, intent(out) :: status
  19739. integer, intent(in), optional :: start (:)
  19740. integer, intent(in), optional :: count (:)
  19741. integer, intent(in), optional :: stride(:)
  19742. integer, intent(in), optional :: map (:)
  19743. ! --- const --------------------------------------
  19744. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_4d'
  19745. ! --- external -----------------------------------
  19746. #ifdef with_hdf4
  19747. integer(hdf4_wpi), external :: sfRData
  19748. #endif
  19749. ! --- local --------------------------------------
  19750. type(MDF_File), pointer :: filep
  19751. type(MDF_Var), pointer :: varp
  19752. integer :: iftype
  19753. integer :: ftype
  19754. #ifdef with_hdf4
  19755. integer :: hdf4_offset(MAX_RANK)
  19756. integer :: hdf4_stride(MAX_RANK)
  19757. integer :: hdf4_count(MAX_RANK)
  19758. integer(1), allocatable :: values_int1(:,:,:,:)
  19759. integer(2), allocatable :: values_int2(:,:,:,:)
  19760. integer(4), allocatable :: values_int4(:,:,:,:)
  19761. integer(8), allocatable :: values_int8(:,:,:,:)
  19762. real(4), allocatable :: values_real4(:,:,:,:)
  19763. real(8), allocatable :: values_real8(:,:,:,:)
  19764. #endif
  19765. ! --- begin --------------------------------------
  19766. ! pointer to file structure:
  19767. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  19768. IF_NOT_OK_RETURN(status=1)
  19769. ! pointer to variable structure:
  19770. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  19771. IF_NOT_OK_RETURN(status=1)
  19772. ! check ...
  19773. if ( size(shape(values)) > varp%ndim ) then
  19774. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  19775. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  19776. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  19777. TRACEBACK; status=1; return
  19778. end if
  19779. ! check ...
  19780. if ( present(start ) ) then
  19781. if ( size(start ) /= varp%ndim ) then
  19782. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19783. write (gol,'(" size start : ",i6)') size(start ); call goErr
  19784. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19785. TRACEBACK; status=1; return
  19786. end if
  19787. end if
  19788. if ( present(count ) ) then
  19789. if ( size(count ) /= varp%ndim ) then
  19790. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19791. write (gol,'(" size count : ",i6)') size(count ); call goErr
  19792. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19793. TRACEBACK; status=1; return
  19794. end if
  19795. end if
  19796. if ( present(stride ) ) then
  19797. if ( size(stride ) /= varp%ndim ) then
  19798. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19799. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  19800. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19801. TRACEBACK; status=1; return
  19802. end if
  19803. end if
  19804. if ( present(map ) ) then
  19805. if ( size(map ) /= varp%ndim ) then
  19806. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19807. write (gol,'(" size map : ",i6)') size(map ); call goErr
  19808. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19809. TRACEBACK; status=1; return
  19810. end if
  19811. end if
  19812. ! loop over file types:
  19813. do iftype = 1, filep%nftype
  19814. ! current type:
  19815. ftype = filep%ftypes(iftype)
  19816. ! select appropriate routine for each type:
  19817. select case ( ftype )
  19818. #ifdef with_hdf4
  19819. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19820. case ( MDF_HDF4 )
  19821. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19822. ! check ...
  19823. if ( present(map ) ) then
  19824. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  19825. TRACEBACK; status=1; return
  19826. end if
  19827. ! fill offset (zero based!), stride, and count :
  19828. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  19829. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  19830. hdf4_count = 1 ! default singleton dimension
  19831. hdf4_count(1:4) = shape(values)
  19832. ! test source type:
  19833. select case ( varp%hdf4_xtype )
  19834. case ( DFNT_INT8 )
  19835. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19836. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  19837. values = real(values_int1,kind=8)
  19838. deallocate( values_int1 )
  19839. case ( DFNT_INT16 )
  19840. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19841. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  19842. values = real(values_int2,kind=8)
  19843. deallocate( values_int2 )
  19844. case ( DFNT_INT32 )
  19845. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19846. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  19847. values = real(values_int4,kind=8)
  19848. deallocate( values_int4 )
  19849. case ( DFNT_INT64 )
  19850. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19851. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  19852. values = real(values_int8,kind=8)
  19853. deallocate( values_int8 )
  19854. case ( DFNT_FLOAT32 )
  19855. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19856. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  19857. values = real(values_real4,kind=8)
  19858. deallocate( values_real4 )
  19859. case ( DFNT_FLOAT64 )
  19860. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) )
  19861. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  19862. values = real(values_real8,kind=8)
  19863. deallocate( values_real8 )
  19864. case default
  19865. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  19866. TRACEBACK; status=1; return
  19867. end select
  19868. if ( status == FAIL ) then
  19869. write (gol,'("reading hdf4 data set:")'); call goErr
  19870. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  19871. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  19872. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  19873. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  19874. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  19875. write (gol,'(" size : ",i6)') size(values); call goErr
  19876. TRACEBACK; status=1; return
  19877. end if
  19878. #endif
  19879. #ifdef with_netcdf
  19880. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19881. case ( MDF_NETCDF, MDF_NETCDF4 )
  19882. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19883. ! read values, converted automatically:
  19884. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  19885. start, count, stride, map )
  19886. IF_NF90_NOT_OK_RETURN(status=1)
  19887. #endif
  19888. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19889. case default
  19890. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  19891. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  19892. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  19893. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  19894. TRACEBACK; status=1; return
  19895. end select
  19896. end do ! file types
  19897. ! ok
  19898. status = 0
  19899. end subroutine MDF_Get_Var_r8_4d
  19900. ! ***
  19901. subroutine MDF_Put_Var_r8_5d( hid, varid, values, status, &
  19902. start, count, stride, map )
  19903. #ifdef with_hdf5_beta
  19904. use HDF5, only : HID_T, HSIZE_T
  19905. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  19906. use HDF5, only : H5T_NATIVE_CHARACTER
  19907. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  19908. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  19909. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  19910. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  19911. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  19912. #endif
  19913. #ifdef with_netcdf
  19914. use NetCDF, only : NF90_Put_Var
  19915. #endif
  19916. ! --- in/out -------------------------------------
  19917. integer, intent(in) :: hid
  19918. integer, intent(in) :: varid
  19919. real(8), intent(in) :: values(:,:,:,:,:)
  19920. integer, intent(out) :: status
  19921. integer, intent(in), optional :: start (:)
  19922. integer, intent(in), optional :: count (:)
  19923. integer, intent(in), optional :: stride(:)
  19924. integer, intent(in), optional :: map (:)
  19925. ! --- const --------------------------------------
  19926. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_5d'
  19927. ! --- external -----------------------------------
  19928. #ifdef with_hdf4
  19929. integer(hdf4_wpi), external :: sfWData
  19930. #endif
  19931. ! --- local --------------------------------------
  19932. type(MDF_File), pointer :: filep
  19933. type(MDF_Var), pointer :: varp
  19934. integer :: iftype
  19935. integer :: ftype
  19936. #ifdef with_hdf4
  19937. integer :: hdf4_offset(MAX_RANK)
  19938. integer :: hdf4_stride(MAX_RANK)
  19939. integer :: hdf4_count(MAX_RANK)
  19940. #endif
  19941. #ifdef with_hdf5_beta
  19942. !integer(HID_T) :: hdf5_type_id
  19943. integer(HID_T) :: hdf5_file_space_id
  19944. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  19945. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  19946. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  19947. #endif
  19948. integer(1), allocatable :: values_int1(:,:,:,:,:)
  19949. integer(2), allocatable :: values_int2(:,:,:,:,:)
  19950. integer(4), allocatable :: values_int4(:,:,:,:,:)
  19951. integer(8), allocatable :: values_int8(:,:,:,:,:)
  19952. real(4), allocatable :: values_real4(:,:,:,:,:)
  19953. real(8), allocatable :: values_real8(:,:,:,:,:)
  19954. ! --- begin --------------------------------------
  19955. ! pointer to file structure:
  19956. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  19957. IF_NOT_OK_RETURN(status=1)
  19958. ! pointer to variable structure:
  19959. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  19960. IF_NOT_OK_RETURN(status=1)
  19961. ! check ...
  19962. if ( size(shape(values)) > varp%ndim ) then
  19963. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  19964. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  19965. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  19966. TRACEBACK; status=1; return
  19967. end if
  19968. ! check ...
  19969. if ( present(start ) ) then
  19970. if ( size(start ) /= varp%ndim ) then
  19971. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19972. write (gol,'(" size start : ",i6)') size(start ); call goErr
  19973. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19974. TRACEBACK; status=1; return
  19975. end if
  19976. end if
  19977. if ( present(count ) ) then
  19978. if ( size(count ) /= varp%ndim ) then
  19979. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19980. write (gol,'(" size count : ",i6)') size(count ); call goErr
  19981. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19982. TRACEBACK; status=1; return
  19983. end if
  19984. end if
  19985. if ( present(stride ) ) then
  19986. if ( size(stride ) /= varp%ndim ) then
  19987. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19988. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  19989. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19990. TRACEBACK; status=1; return
  19991. end if
  19992. end if
  19993. if ( present(map ) ) then
  19994. if ( size(map ) /= varp%ndim ) then
  19995. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  19996. write (gol,'(" size map : ",i6)') size(map ); call goErr
  19997. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  19998. TRACEBACK; status=1; return
  19999. end if
  20000. end if
  20001. ! loop over file types:
  20002. do iftype = 1, filep%nftype
  20003. ! current type:
  20004. ftype = filep%ftypes(iftype)
  20005. ! select appropriate routine for each type:
  20006. select case ( ftype )
  20007. #ifdef with_hdf4
  20008. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20009. case ( MDF_HDF4 )
  20010. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20011. ! check ...
  20012. if ( present(map ) ) then
  20013. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  20014. TRACEBACK; status=1; return
  20015. end if
  20016. ! fill offset (zero based!) and stride with default values:
  20017. hdf4_offset = 0
  20018. hdf4_stride = 1
  20019. ! count is by default the shape; padd with singleton dimensions:
  20020. hdf4_count = 1; hdf4_count(1:5) = shape(values)
  20021. ! replace by optional arguments if necessary:
  20022. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  20023. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  20024. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  20025. ! test target type;
  20026. ! convert to required kind before entering sfWData,
  20027. ! otherwise segmentation faults on some machines ...
  20028. select case ( varp%xtype )
  20029. case ( MDF_BYTE )
  20030. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20031. values_int1 = int(values,kind=1)
  20032. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20033. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  20034. deallocate( values_int1 )
  20035. case ( MDF_SHORT )
  20036. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20037. values_int2 = int(values,kind=2)
  20038. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20039. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  20040. deallocate( values_int2 )
  20041. case ( MDF_INT )
  20042. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20043. values_int4 = int(values,kind=4)
  20044. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20045. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  20046. deallocate( values_int4 )
  20047. case ( MDF_FLOAT )
  20048. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20049. values_real4 = real(values,kind=4)
  20050. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20051. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  20052. deallocate( values_real4 )
  20053. case ( MDF_DOUBLE )
  20054. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20055. values_real8 = real(values,kind=8)
  20056. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20057. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  20058. deallocate( values_real8 )
  20059. case default
  20060. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  20061. TRACEBACK; status=1; return
  20062. end select
  20063. if ( status == FAIL ) then
  20064. write (gol,'("writing hdf4 data set:")'); call goErr
  20065. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  20066. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  20067. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  20068. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  20069. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  20070. write (gol,'(" size : ",i12)') size(values); call goErr
  20071. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  20072. TRACEBACK; status=1; return
  20073. end if
  20074. #endif
  20075. #ifdef with_hdf5_beta
  20076. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20077. case ( MDF_HDF5 )
  20078. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20079. ! check ...
  20080. if ( present(map ) ) then
  20081. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  20082. TRACEBACK; status=1; return
  20083. end if
  20084. ! fill offset (zero based!), stride, and count :
  20085. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  20086. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  20087. hdf5_count = 1 ! default singleton dimension
  20088. if ( present(count) ) then
  20089. hdf5_count(1:varp%ndim) = count
  20090. else
  20091. hdf5_count(1:5) = shape(values)
  20092. end if
  20093. ! new dimension:
  20094. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  20095. ! target data space in file:
  20096. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  20097. IF_NOT_OK_RETURN(status=1)
  20098. ! chunked dataset ?
  20099. if ( varp%hdf5_chunked ) then
  20100. ! reset extend:
  20101. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  20102. IF_NOT_OK_RETURN(status=1)
  20103. end if
  20104. ! select hyperslab:
  20105. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  20106. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  20107. stride=hdf5_stride(1:varp%ndim) )
  20108. ! write data:
  20109. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  20110. int(shape(values),kind=HSIZE_T), status, &
  20111. file_space_id=hdf5_file_space_id )
  20112. IF_NOT_OK_RETURN(status=1)
  20113. ! release data space:
  20114. call H5SClose_f( hdf5_file_space_id, status )
  20115. IF_NOT_OK_RETURN(status=1)
  20116. #endif
  20117. #ifdef with_netcdf
  20118. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20119. case ( MDF_NETCDF, MDF_NETCDF4 )
  20120. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20121. ! test target type:
  20122. ! convert to required kind before entering NF90_Put_Var,
  20123. ! otherwise segmentation faults on some machines ...
  20124. select case ( varp%xtype )
  20125. case ( MDF_BYTE )
  20126. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20127. values_int1 = int(values,kind=1)
  20128. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  20129. start, count, stride, map )
  20130. IF_NF90_NOT_OK_RETURN(status=1)
  20131. deallocate( values_int1 )
  20132. case ( MDF_SHORT )
  20133. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20134. values_int2 = int(values,kind=2)
  20135. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  20136. start, count, stride, map )
  20137. IF_NF90_NOT_OK_RETURN(status=1)
  20138. deallocate( values_int2 )
  20139. case ( MDF_INT )
  20140. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20141. values_int4 = int(values,kind=4)
  20142. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  20143. start, count, stride, map )
  20144. IF_NF90_NOT_OK_RETURN(status=1)
  20145. deallocate( values_int4 )
  20146. case ( MDF_FLOAT )
  20147. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20148. values_real4 = real(values,kind=4)
  20149. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  20150. start, count, stride, map )
  20151. IF_NF90_NOT_OK_RETURN(status=1)
  20152. deallocate( values_real4 )
  20153. case ( MDF_DOUBLE )
  20154. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20155. values_real8 = real(values,kind=8)
  20156. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  20157. start, count, stride, map )
  20158. IF_NF90_NOT_OK_RETURN(status=1)
  20159. deallocate( values_real8 )
  20160. case default
  20161. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  20162. TRACEBACK; status=1; return
  20163. end select
  20164. ! just put; let netcdf library convert the right kind:
  20165. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  20166. ! start, count, stride, map )
  20167. !IF_NF90_NOT_OK_RETURN(status=1)
  20168. #endif
  20169. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20170. case default
  20171. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20172. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  20173. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  20174. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  20175. TRACEBACK; status=1; return
  20176. end select
  20177. end do ! file types
  20178. ! ok
  20179. status = 0
  20180. end subroutine MDF_Put_Var_r8_5d
  20181. ! ***
  20182. subroutine MDF_Get_Var_r8_5d( hid, varid, values, status, &
  20183. start, count, stride, map )
  20184. #ifdef with_netcdf
  20185. use NetCDF, only : NF90_Get_Var
  20186. #endif
  20187. ! --- in/out -------------------------------------
  20188. integer, intent(in) :: hid
  20189. integer, intent(in) :: varid
  20190. real(8), intent(out) :: values(:,:,:,:,:)
  20191. integer, intent(out) :: status
  20192. integer, intent(in), optional :: start (:)
  20193. integer, intent(in), optional :: count (:)
  20194. integer, intent(in), optional :: stride(:)
  20195. integer, intent(in), optional :: map (:)
  20196. ! --- const --------------------------------------
  20197. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_5d'
  20198. ! --- external -----------------------------------
  20199. #ifdef with_hdf4
  20200. integer(hdf4_wpi), external :: sfRData
  20201. #endif
  20202. ! --- local --------------------------------------
  20203. type(MDF_File), pointer :: filep
  20204. type(MDF_Var), pointer :: varp
  20205. integer :: iftype
  20206. integer :: ftype
  20207. #ifdef with_hdf4
  20208. integer :: hdf4_offset(MAX_RANK)
  20209. integer :: hdf4_stride(MAX_RANK)
  20210. integer :: hdf4_count(MAX_RANK)
  20211. integer(1), allocatable :: values_int1(:,:,:,:,:)
  20212. integer(2), allocatable :: values_int2(:,:,:,:,:)
  20213. integer(4), allocatable :: values_int4(:,:,:,:,:)
  20214. integer(8), allocatable :: values_int8(:,:,:,:,:)
  20215. real(4), allocatable :: values_real4(:,:,:,:,:)
  20216. real(8), allocatable :: values_real8(:,:,:,:,:)
  20217. #endif
  20218. ! --- begin --------------------------------------
  20219. ! pointer to file structure:
  20220. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  20221. IF_NOT_OK_RETURN(status=1)
  20222. ! pointer to variable structure:
  20223. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  20224. IF_NOT_OK_RETURN(status=1)
  20225. ! check ...
  20226. if ( size(shape(values)) > varp%ndim ) then
  20227. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  20228. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  20229. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  20230. TRACEBACK; status=1; return
  20231. end if
  20232. ! check ...
  20233. if ( present(start ) ) then
  20234. if ( size(start ) /= varp%ndim ) then
  20235. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20236. write (gol,'(" size start : ",i6)') size(start ); call goErr
  20237. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20238. TRACEBACK; status=1; return
  20239. end if
  20240. end if
  20241. if ( present(count ) ) then
  20242. if ( size(count ) /= varp%ndim ) then
  20243. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20244. write (gol,'(" size count : ",i6)') size(count ); call goErr
  20245. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20246. TRACEBACK; status=1; return
  20247. end if
  20248. end if
  20249. if ( present(stride ) ) then
  20250. if ( size(stride ) /= varp%ndim ) then
  20251. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20252. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  20253. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20254. TRACEBACK; status=1; return
  20255. end if
  20256. end if
  20257. if ( present(map ) ) then
  20258. if ( size(map ) /= varp%ndim ) then
  20259. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20260. write (gol,'(" size map : ",i6)') size(map ); call goErr
  20261. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20262. TRACEBACK; status=1; return
  20263. end if
  20264. end if
  20265. ! loop over file types:
  20266. do iftype = 1, filep%nftype
  20267. ! current type:
  20268. ftype = filep%ftypes(iftype)
  20269. ! select appropriate routine for each type:
  20270. select case ( ftype )
  20271. #ifdef with_hdf4
  20272. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20273. case ( MDF_HDF4 )
  20274. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20275. ! check ...
  20276. if ( present(map ) ) then
  20277. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  20278. TRACEBACK; status=1; return
  20279. end if
  20280. ! fill offset (zero based!), stride, and count :
  20281. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  20282. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  20283. hdf4_count = 1 ! default singleton dimension
  20284. hdf4_count(1:5) = shape(values)
  20285. ! test source type:
  20286. select case ( varp%hdf4_xtype )
  20287. case ( DFNT_INT8 )
  20288. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20289. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  20290. values = real(values_int1,kind=8)
  20291. deallocate( values_int1 )
  20292. case ( DFNT_INT16 )
  20293. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20294. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  20295. values = real(values_int2,kind=8)
  20296. deallocate( values_int2 )
  20297. case ( DFNT_INT32 )
  20298. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20299. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  20300. values = real(values_int4,kind=8)
  20301. deallocate( values_int4 )
  20302. case ( DFNT_INT64 )
  20303. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20304. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  20305. values = real(values_int8,kind=8)
  20306. deallocate( values_int8 )
  20307. case ( DFNT_FLOAT32 )
  20308. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20309. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  20310. values = real(values_real4,kind=8)
  20311. deallocate( values_real4 )
  20312. case ( DFNT_FLOAT64 )
  20313. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) )
  20314. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  20315. values = real(values_real8,kind=8)
  20316. deallocate( values_real8 )
  20317. case default
  20318. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  20319. TRACEBACK; status=1; return
  20320. end select
  20321. if ( status == FAIL ) then
  20322. write (gol,'("reading hdf4 data set:")'); call goErr
  20323. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  20324. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  20325. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  20326. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  20327. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  20328. write (gol,'(" size : ",i6)') size(values); call goErr
  20329. TRACEBACK; status=1; return
  20330. end if
  20331. #endif
  20332. #ifdef with_netcdf
  20333. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20334. case ( MDF_NETCDF, MDF_NETCDF4 )
  20335. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20336. ! read values, converted automatically:
  20337. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  20338. start, count, stride, map )
  20339. IF_NF90_NOT_OK_RETURN(status=1)
  20340. #endif
  20341. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20342. case default
  20343. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20344. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  20345. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  20346. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  20347. TRACEBACK; status=1; return
  20348. end select
  20349. end do ! file types
  20350. ! ok
  20351. status = 0
  20352. end subroutine MDF_Get_Var_r8_5d
  20353. ! ***
  20354. subroutine MDF_Put_Var_r8_6d( hid, varid, values, status, &
  20355. start, count, stride, map )
  20356. #ifdef with_hdf5_beta
  20357. use HDF5, only : HID_T, HSIZE_T
  20358. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  20359. use HDF5, only : H5T_NATIVE_CHARACTER
  20360. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  20361. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  20362. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  20363. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  20364. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  20365. #endif
  20366. #ifdef with_netcdf
  20367. use NetCDF, only : NF90_Put_Var
  20368. #endif
  20369. ! --- in/out -------------------------------------
  20370. integer, intent(in) :: hid
  20371. integer, intent(in) :: varid
  20372. real(8), intent(in) :: values(:,:,:,:,:,:)
  20373. integer, intent(out) :: status
  20374. integer, intent(in), optional :: start (:)
  20375. integer, intent(in), optional :: count (:)
  20376. integer, intent(in), optional :: stride(:)
  20377. integer, intent(in), optional :: map (:)
  20378. ! --- const --------------------------------------
  20379. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_6d'
  20380. ! --- external -----------------------------------
  20381. #ifdef with_hdf4
  20382. integer(hdf4_wpi), external :: sfWData
  20383. #endif
  20384. ! --- local --------------------------------------
  20385. type(MDF_File), pointer :: filep
  20386. type(MDF_Var), pointer :: varp
  20387. integer :: iftype
  20388. integer :: ftype
  20389. #ifdef with_hdf4
  20390. integer :: hdf4_offset(MAX_RANK)
  20391. integer :: hdf4_stride(MAX_RANK)
  20392. integer :: hdf4_count(MAX_RANK)
  20393. #endif
  20394. #ifdef with_hdf5_beta
  20395. !integer(HID_T) :: hdf5_type_id
  20396. integer(HID_T) :: hdf5_file_space_id
  20397. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  20398. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  20399. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  20400. #endif
  20401. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  20402. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  20403. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  20404. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  20405. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  20406. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  20407. ! --- begin --------------------------------------
  20408. ! pointer to file structure:
  20409. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  20410. IF_NOT_OK_RETURN(status=1)
  20411. ! pointer to variable structure:
  20412. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  20413. IF_NOT_OK_RETURN(status=1)
  20414. ! check ...
  20415. if ( size(shape(values)) > varp%ndim ) then
  20416. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  20417. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  20418. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  20419. TRACEBACK; status=1; return
  20420. end if
  20421. ! check ...
  20422. if ( present(start ) ) then
  20423. if ( size(start ) /= varp%ndim ) then
  20424. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20425. write (gol,'(" size start : ",i6)') size(start ); call goErr
  20426. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20427. TRACEBACK; status=1; return
  20428. end if
  20429. end if
  20430. if ( present(count ) ) then
  20431. if ( size(count ) /= varp%ndim ) then
  20432. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20433. write (gol,'(" size count : ",i6)') size(count ); call goErr
  20434. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20435. TRACEBACK; status=1; return
  20436. end if
  20437. end if
  20438. if ( present(stride ) ) then
  20439. if ( size(stride ) /= varp%ndim ) then
  20440. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20441. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  20442. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20443. TRACEBACK; status=1; return
  20444. end if
  20445. end if
  20446. if ( present(map ) ) then
  20447. if ( size(map ) /= varp%ndim ) then
  20448. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20449. write (gol,'(" size map : ",i6)') size(map ); call goErr
  20450. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20451. TRACEBACK; status=1; return
  20452. end if
  20453. end if
  20454. ! loop over file types:
  20455. do iftype = 1, filep%nftype
  20456. ! current type:
  20457. ftype = filep%ftypes(iftype)
  20458. ! select appropriate routine for each type:
  20459. select case ( ftype )
  20460. #ifdef with_hdf4
  20461. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20462. case ( MDF_HDF4 )
  20463. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20464. ! check ...
  20465. if ( present(map ) ) then
  20466. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  20467. TRACEBACK; status=1; return
  20468. end if
  20469. ! fill offset (zero based!) and stride with default values:
  20470. hdf4_offset = 0
  20471. hdf4_stride = 1
  20472. ! count is by default the shape; padd with singleton dimensions:
  20473. hdf4_count = 1; hdf4_count(1:6) = shape(values)
  20474. ! replace by optional arguments if necessary:
  20475. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  20476. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  20477. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  20478. ! test target type;
  20479. ! convert to required kind before entering sfWData,
  20480. ! otherwise segmentation faults on some machines ...
  20481. select case ( varp%xtype )
  20482. case ( MDF_BYTE )
  20483. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20484. values_int1 = int(values,kind=1)
  20485. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20486. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  20487. deallocate( values_int1 )
  20488. case ( MDF_SHORT )
  20489. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20490. values_int2 = int(values,kind=2)
  20491. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20492. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  20493. deallocate( values_int2 )
  20494. case ( MDF_INT )
  20495. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20496. values_int4 = int(values,kind=4)
  20497. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20498. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  20499. deallocate( values_int4 )
  20500. case ( MDF_FLOAT )
  20501. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20502. values_real4 = real(values,kind=4)
  20503. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20504. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  20505. deallocate( values_real4 )
  20506. case ( MDF_DOUBLE )
  20507. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20508. values_real8 = real(values,kind=8)
  20509. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20510. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  20511. deallocate( values_real8 )
  20512. case default
  20513. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  20514. TRACEBACK; status=1; return
  20515. end select
  20516. if ( status == FAIL ) then
  20517. write (gol,'("writing hdf4 data set:")'); call goErr
  20518. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  20519. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  20520. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  20521. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  20522. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  20523. write (gol,'(" size : ",i12)') size(values); call goErr
  20524. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  20525. TRACEBACK; status=1; return
  20526. end if
  20527. #endif
  20528. #ifdef with_hdf5_beta
  20529. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20530. case ( MDF_HDF5 )
  20531. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20532. ! check ...
  20533. if ( present(map ) ) then
  20534. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  20535. TRACEBACK; status=1; return
  20536. end if
  20537. ! fill offset (zero based!), stride, and count :
  20538. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  20539. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  20540. hdf5_count = 1 ! default singleton dimension
  20541. if ( present(count) ) then
  20542. hdf5_count(1:varp%ndim) = count
  20543. else
  20544. hdf5_count(1:6) = shape(values)
  20545. end if
  20546. ! new dimension:
  20547. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  20548. ! target data space in file:
  20549. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  20550. IF_NOT_OK_RETURN(status=1)
  20551. ! chunked dataset ?
  20552. if ( varp%hdf5_chunked ) then
  20553. ! reset extend:
  20554. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  20555. IF_NOT_OK_RETURN(status=1)
  20556. end if
  20557. ! select hyperslab:
  20558. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  20559. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  20560. stride=hdf5_stride(1:varp%ndim) )
  20561. ! write data:
  20562. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  20563. int(shape(values),kind=HSIZE_T), status, &
  20564. file_space_id=hdf5_file_space_id )
  20565. IF_NOT_OK_RETURN(status=1)
  20566. ! release data space:
  20567. call H5SClose_f( hdf5_file_space_id, status )
  20568. IF_NOT_OK_RETURN(status=1)
  20569. #endif
  20570. #ifdef with_netcdf
  20571. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20572. case ( MDF_NETCDF, MDF_NETCDF4 )
  20573. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20574. ! test target type:
  20575. ! convert to required kind before entering NF90_Put_Var,
  20576. ! otherwise segmentation faults on some machines ...
  20577. select case ( varp%xtype )
  20578. case ( MDF_BYTE )
  20579. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20580. values_int1 = int(values,kind=1)
  20581. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  20582. start, count, stride, map )
  20583. IF_NF90_NOT_OK_RETURN(status=1)
  20584. deallocate( values_int1 )
  20585. case ( MDF_SHORT )
  20586. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20587. values_int2 = int(values,kind=2)
  20588. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  20589. start, count, stride, map )
  20590. IF_NF90_NOT_OK_RETURN(status=1)
  20591. deallocate( values_int2 )
  20592. case ( MDF_INT )
  20593. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20594. values_int4 = int(values,kind=4)
  20595. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  20596. start, count, stride, map )
  20597. IF_NF90_NOT_OK_RETURN(status=1)
  20598. deallocate( values_int4 )
  20599. case ( MDF_FLOAT )
  20600. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20601. values_real4 = real(values,kind=4)
  20602. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  20603. start, count, stride, map )
  20604. IF_NF90_NOT_OK_RETURN(status=1)
  20605. deallocate( values_real4 )
  20606. case ( MDF_DOUBLE )
  20607. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20608. values_real8 = real(values,kind=8)
  20609. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  20610. start, count, stride, map )
  20611. IF_NF90_NOT_OK_RETURN(status=1)
  20612. deallocate( values_real8 )
  20613. case default
  20614. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  20615. TRACEBACK; status=1; return
  20616. end select
  20617. ! just put; let netcdf library convert the right kind:
  20618. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  20619. ! start, count, stride, map )
  20620. !IF_NF90_NOT_OK_RETURN(status=1)
  20621. #endif
  20622. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20623. case default
  20624. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20625. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  20626. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  20627. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  20628. TRACEBACK; status=1; return
  20629. end select
  20630. end do ! file types
  20631. ! ok
  20632. status = 0
  20633. end subroutine MDF_Put_Var_r8_6d
  20634. ! ***
  20635. subroutine MDF_Get_Var_r8_6d( hid, varid, values, status, &
  20636. start, count, stride, map )
  20637. #ifdef with_netcdf
  20638. use NetCDF, only : NF90_Get_Var
  20639. #endif
  20640. ! --- in/out -------------------------------------
  20641. integer, intent(in) :: hid
  20642. integer, intent(in) :: varid
  20643. real(8), intent(out) :: values(:,:,:,:,:,:)
  20644. integer, intent(out) :: status
  20645. integer, intent(in), optional :: start (:)
  20646. integer, intent(in), optional :: count (:)
  20647. integer, intent(in), optional :: stride(:)
  20648. integer, intent(in), optional :: map (:)
  20649. ! --- const --------------------------------------
  20650. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_6d'
  20651. ! --- external -----------------------------------
  20652. #ifdef with_hdf4
  20653. integer(hdf4_wpi), external :: sfRData
  20654. #endif
  20655. ! --- local --------------------------------------
  20656. type(MDF_File), pointer :: filep
  20657. type(MDF_Var), pointer :: varp
  20658. integer :: iftype
  20659. integer :: ftype
  20660. #ifdef with_hdf4
  20661. integer :: hdf4_offset(MAX_RANK)
  20662. integer :: hdf4_stride(MAX_RANK)
  20663. integer :: hdf4_count(MAX_RANK)
  20664. integer(1), allocatable :: values_int1(:,:,:,:,:,:)
  20665. integer(2), allocatable :: values_int2(:,:,:,:,:,:)
  20666. integer(4), allocatable :: values_int4(:,:,:,:,:,:)
  20667. integer(8), allocatable :: values_int8(:,:,:,:,:,:)
  20668. real(4), allocatable :: values_real4(:,:,:,:,:,:)
  20669. real(8), allocatable :: values_real8(:,:,:,:,:,:)
  20670. #endif
  20671. ! --- begin --------------------------------------
  20672. ! pointer to file structure:
  20673. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  20674. IF_NOT_OK_RETURN(status=1)
  20675. ! pointer to variable structure:
  20676. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  20677. IF_NOT_OK_RETURN(status=1)
  20678. ! check ...
  20679. if ( size(shape(values)) > varp%ndim ) then
  20680. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  20681. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  20682. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  20683. TRACEBACK; status=1; return
  20684. end if
  20685. ! check ...
  20686. if ( present(start ) ) then
  20687. if ( size(start ) /= varp%ndim ) then
  20688. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20689. write (gol,'(" size start : ",i6)') size(start ); call goErr
  20690. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20691. TRACEBACK; status=1; return
  20692. end if
  20693. end if
  20694. if ( present(count ) ) then
  20695. if ( size(count ) /= varp%ndim ) then
  20696. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20697. write (gol,'(" size count : ",i6)') size(count ); call goErr
  20698. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20699. TRACEBACK; status=1; return
  20700. end if
  20701. end if
  20702. if ( present(stride ) ) then
  20703. if ( size(stride ) /= varp%ndim ) then
  20704. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20705. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  20706. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20707. TRACEBACK; status=1; return
  20708. end if
  20709. end if
  20710. if ( present(map ) ) then
  20711. if ( size(map ) /= varp%ndim ) then
  20712. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20713. write (gol,'(" size map : ",i6)') size(map ); call goErr
  20714. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20715. TRACEBACK; status=1; return
  20716. end if
  20717. end if
  20718. ! loop over file types:
  20719. do iftype = 1, filep%nftype
  20720. ! current type:
  20721. ftype = filep%ftypes(iftype)
  20722. ! select appropriate routine for each type:
  20723. select case ( ftype )
  20724. #ifdef with_hdf4
  20725. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20726. case ( MDF_HDF4 )
  20727. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20728. ! check ...
  20729. if ( present(map ) ) then
  20730. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  20731. TRACEBACK; status=1; return
  20732. end if
  20733. ! fill offset (zero based!), stride, and count :
  20734. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  20735. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  20736. hdf4_count = 1 ! default singleton dimension
  20737. hdf4_count(1:6) = shape(values)
  20738. ! test source type:
  20739. select case ( varp%hdf4_xtype )
  20740. case ( DFNT_INT8 )
  20741. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20742. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  20743. values = real(values_int1,kind=8)
  20744. deallocate( values_int1 )
  20745. case ( DFNT_INT16 )
  20746. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20747. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  20748. values = real(values_int2,kind=8)
  20749. deallocate( values_int2 )
  20750. case ( DFNT_INT32 )
  20751. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20752. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  20753. values = real(values_int4,kind=8)
  20754. deallocate( values_int4 )
  20755. case ( DFNT_INT64 )
  20756. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20757. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  20758. values = real(values_int8,kind=8)
  20759. deallocate( values_int8 )
  20760. case ( DFNT_FLOAT32 )
  20761. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20762. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  20763. values = real(values_real4,kind=8)
  20764. deallocate( values_real4 )
  20765. case ( DFNT_FLOAT64 )
  20766. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) )
  20767. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  20768. values = real(values_real8,kind=8)
  20769. deallocate( values_real8 )
  20770. case default
  20771. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  20772. TRACEBACK; status=1; return
  20773. end select
  20774. if ( status == FAIL ) then
  20775. write (gol,'("reading hdf4 data set:")'); call goErr
  20776. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  20777. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  20778. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  20779. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  20780. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  20781. write (gol,'(" size : ",i6)') size(values); call goErr
  20782. TRACEBACK; status=1; return
  20783. end if
  20784. #endif
  20785. #ifdef with_netcdf
  20786. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20787. case ( MDF_NETCDF, MDF_NETCDF4 )
  20788. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20789. ! read values, converted automatically:
  20790. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  20791. start, count, stride, map )
  20792. IF_NF90_NOT_OK_RETURN(status=1)
  20793. #endif
  20794. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20795. case default
  20796. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20797. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  20798. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  20799. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  20800. TRACEBACK; status=1; return
  20801. end select
  20802. end do ! file types
  20803. ! ok
  20804. status = 0
  20805. end subroutine MDF_Get_Var_r8_6d
  20806. ! ***
  20807. subroutine MDF_Put_Var_r8_7d( hid, varid, values, status, &
  20808. start, count, stride, map )
  20809. #ifdef with_hdf5_beta
  20810. use HDF5, only : HID_T, HSIZE_T
  20811. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  20812. use HDF5, only : H5T_NATIVE_CHARACTER
  20813. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  20814. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  20815. use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f
  20816. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F
  20817. use HDF5, only : H5DWrite_f, H5DSet_Extent_f
  20818. #endif
  20819. #ifdef with_netcdf
  20820. use NetCDF, only : NF90_Put_Var
  20821. #endif
  20822. ! --- in/out -------------------------------------
  20823. integer, intent(in) :: hid
  20824. integer, intent(in) :: varid
  20825. real(8), intent(in) :: values(:,:,:,:,:,:,:)
  20826. integer, intent(out) :: status
  20827. integer, intent(in), optional :: start (:)
  20828. integer, intent(in), optional :: count (:)
  20829. integer, intent(in), optional :: stride(:)
  20830. integer, intent(in), optional :: map (:)
  20831. ! --- const --------------------------------------
  20832. character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_7d'
  20833. ! --- external -----------------------------------
  20834. #ifdef with_hdf4
  20835. integer(hdf4_wpi), external :: sfWData
  20836. #endif
  20837. ! --- local --------------------------------------
  20838. type(MDF_File), pointer :: filep
  20839. type(MDF_Var), pointer :: varp
  20840. integer :: iftype
  20841. integer :: ftype
  20842. #ifdef with_hdf4
  20843. integer :: hdf4_offset(MAX_RANK)
  20844. integer :: hdf4_stride(MAX_RANK)
  20845. integer :: hdf4_count(MAX_RANK)
  20846. #endif
  20847. #ifdef with_hdf5_beta
  20848. !integer(HID_T) :: hdf5_type_id
  20849. integer(HID_T) :: hdf5_file_space_id
  20850. integer(HSIZE_T) :: hdf5_offset(MAX_RANK)
  20851. integer(HSIZE_T) :: hdf5_stride(MAX_RANK)
  20852. integer(HSIZE_T) :: hdf5_count (MAX_RANK)
  20853. #endif
  20854. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  20855. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  20856. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  20857. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  20858. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  20859. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  20860. ! --- begin --------------------------------------
  20861. ! pointer to file structure:
  20862. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  20863. IF_NOT_OK_RETURN(status=1)
  20864. ! pointer to variable structure:
  20865. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  20866. IF_NOT_OK_RETURN(status=1)
  20867. ! check ...
  20868. if ( size(shape(values)) > varp%ndim ) then
  20869. write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr
  20870. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  20871. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  20872. TRACEBACK; status=1; return
  20873. end if
  20874. ! check ...
  20875. if ( present(start ) ) then
  20876. if ( size(start ) /= varp%ndim ) then
  20877. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20878. write (gol,'(" size start : ",i6)') size(start ); call goErr
  20879. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20880. TRACEBACK; status=1; return
  20881. end if
  20882. end if
  20883. if ( present(count ) ) then
  20884. if ( size(count ) /= varp%ndim ) then
  20885. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20886. write (gol,'(" size count : ",i6)') size(count ); call goErr
  20887. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20888. TRACEBACK; status=1; return
  20889. end if
  20890. end if
  20891. if ( present(stride ) ) then
  20892. if ( size(stride ) /= varp%ndim ) then
  20893. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20894. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  20895. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20896. TRACEBACK; status=1; return
  20897. end if
  20898. end if
  20899. if ( present(map ) ) then
  20900. if ( size(map ) /= varp%ndim ) then
  20901. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  20902. write (gol,'(" size map : ",i6)') size(map ); call goErr
  20903. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  20904. TRACEBACK; status=1; return
  20905. end if
  20906. end if
  20907. ! loop over file types:
  20908. do iftype = 1, filep%nftype
  20909. ! current type:
  20910. ftype = filep%ftypes(iftype)
  20911. ! select appropriate routine for each type:
  20912. select case ( ftype )
  20913. #ifdef with_hdf4
  20914. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20915. case ( MDF_HDF4 )
  20916. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20917. ! check ...
  20918. if ( present(map ) ) then
  20919. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  20920. TRACEBACK; status=1; return
  20921. end if
  20922. ! fill offset (zero based!) and stride with default values:
  20923. hdf4_offset = 0
  20924. hdf4_stride = 1
  20925. ! count is by default the shape; padd with singleton dimensions:
  20926. hdf4_count = 1; hdf4_count(1:7) = shape(values)
  20927. ! replace by optional arguments if necessary:
  20928. if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  20929. if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  20930. if ( present(count ) ) hdf4_count (1:varp%ndim) = count
  20931. ! test target type;
  20932. ! convert to required kind before entering sfWData,
  20933. ! otherwise segmentation faults on some machines ...
  20934. select case ( varp%xtype )
  20935. case ( MDF_BYTE )
  20936. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  20937. values_int1 = int(values,kind=1)
  20938. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20939. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  20940. deallocate( values_int1 )
  20941. case ( MDF_SHORT )
  20942. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  20943. values_int2 = int(values,kind=2)
  20944. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20945. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  20946. deallocate( values_int2 )
  20947. case ( MDF_INT )
  20948. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  20949. values_int4 = int(values,kind=4)
  20950. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20951. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  20952. deallocate( values_int4 )
  20953. case ( MDF_FLOAT )
  20954. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  20955. values_real4 = real(values,kind=4)
  20956. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20957. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  20958. deallocate( values_real4 )
  20959. case ( MDF_DOUBLE )
  20960. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  20961. values_real8 = real(values,kind=8)
  20962. status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), &
  20963. hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  20964. deallocate( values_real8 )
  20965. case default
  20966. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  20967. TRACEBACK; status=1; return
  20968. end select
  20969. if ( status == FAIL ) then
  20970. write (gol,'("writing hdf4 data set:")'); call goErr
  20971. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  20972. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  20973. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  20974. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  20975. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  20976. write (gol,'(" size : ",i12)') size(values); call goErr
  20977. write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr
  20978. TRACEBACK; status=1; return
  20979. end if
  20980. #endif
  20981. #ifdef with_hdf5_beta
  20982. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20983. case ( MDF_HDF5 )
  20984. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  20985. ! check ...
  20986. if ( present(map ) ) then
  20987. write (gol,'("argument `map` not supported for HDF5")'); call goErr
  20988. TRACEBACK; status=1; return
  20989. end if
  20990. ! fill offset (zero based!), stride, and count :
  20991. hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1
  20992. hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride
  20993. hdf5_count = 1 ! default singleton dimension
  20994. if ( present(count) ) then
  20995. hdf5_count(1:varp%ndim) = count
  20996. else
  20997. hdf5_count(1:7) = shape(values)
  20998. end if
  20999. ! new dimension:
  21000. varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count )
  21001. ! target data space in file:
  21002. call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status )
  21003. IF_NOT_OK_RETURN(status=1)
  21004. ! chunked dataset ?
  21005. if ( varp%hdf5_chunked ) then
  21006. ! reset extend:
  21007. call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status )
  21008. IF_NOT_OK_RETURN(status=1)
  21009. end if
  21010. ! select hyperslab:
  21011. call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, &
  21012. hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, &
  21013. stride=hdf5_stride(1:varp%ndim) )
  21014. ! write data:
  21015. call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, &
  21016. int(shape(values),kind=HSIZE_T), status, &
  21017. file_space_id=hdf5_file_space_id )
  21018. IF_NOT_OK_RETURN(status=1)
  21019. ! release data space:
  21020. call H5SClose_f( hdf5_file_space_id, status )
  21021. IF_NOT_OK_RETURN(status=1)
  21022. #endif
  21023. #ifdef with_netcdf
  21024. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21025. case ( MDF_NETCDF, MDF_NETCDF4 )
  21026. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21027. ! test target type:
  21028. ! convert to required kind before entering NF90_Put_Var,
  21029. ! otherwise segmentation faults on some machines ...
  21030. select case ( varp%xtype )
  21031. case ( MDF_BYTE )
  21032. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21033. values_int1 = int(values,kind=1)
  21034. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, &
  21035. start, count, stride, map )
  21036. IF_NF90_NOT_OK_RETURN(status=1)
  21037. deallocate( values_int1 )
  21038. case ( MDF_SHORT )
  21039. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21040. values_int2 = int(values,kind=2)
  21041. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, &
  21042. start, count, stride, map )
  21043. IF_NF90_NOT_OK_RETURN(status=1)
  21044. deallocate( values_int2 )
  21045. case ( MDF_INT )
  21046. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21047. values_int4 = int(values,kind=4)
  21048. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, &
  21049. start, count, stride, map )
  21050. IF_NF90_NOT_OK_RETURN(status=1)
  21051. deallocate( values_int4 )
  21052. case ( MDF_FLOAT )
  21053. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21054. values_real4 = real(values,kind=4)
  21055. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, &
  21056. start, count, stride, map )
  21057. IF_NF90_NOT_OK_RETURN(status=1)
  21058. deallocate( values_real4 )
  21059. case ( MDF_DOUBLE )
  21060. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21061. values_real8 = real(values,kind=8)
  21062. status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, &
  21063. start, count, stride, map )
  21064. IF_NF90_NOT_OK_RETURN(status=1)
  21065. deallocate( values_real8 )
  21066. case default
  21067. write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr
  21068. TRACEBACK; status=1; return
  21069. end select
  21070. ! just put; let netcdf library convert the right kind:
  21071. !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  21072. ! start, count, stride, map )
  21073. !IF_NF90_NOT_OK_RETURN(status=1)
  21074. #endif
  21075. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21076. case default
  21077. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21078. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21079. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21080. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21081. TRACEBACK; status=1; return
  21082. end select
  21083. end do ! file types
  21084. ! ok
  21085. status = 0
  21086. end subroutine MDF_Put_Var_r8_7d
  21087. ! ***
  21088. subroutine MDF_Get_Var_r8_7d( hid, varid, values, status, &
  21089. start, count, stride, map )
  21090. #ifdef with_netcdf
  21091. use NetCDF, only : NF90_Get_Var
  21092. #endif
  21093. ! --- in/out -------------------------------------
  21094. integer, intent(in) :: hid
  21095. integer, intent(in) :: varid
  21096. real(8), intent(out) :: values(:,:,:,:,:,:,:)
  21097. integer, intent(out) :: status
  21098. integer, intent(in), optional :: start (:)
  21099. integer, intent(in), optional :: count (:)
  21100. integer, intent(in), optional :: stride(:)
  21101. integer, intent(in), optional :: map (:)
  21102. ! --- const --------------------------------------
  21103. character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_7d'
  21104. ! --- external -----------------------------------
  21105. #ifdef with_hdf4
  21106. integer(hdf4_wpi), external :: sfRData
  21107. #endif
  21108. ! --- local --------------------------------------
  21109. type(MDF_File), pointer :: filep
  21110. type(MDF_Var), pointer :: varp
  21111. integer :: iftype
  21112. integer :: ftype
  21113. #ifdef with_hdf4
  21114. integer :: hdf4_offset(MAX_RANK)
  21115. integer :: hdf4_stride(MAX_RANK)
  21116. integer :: hdf4_count(MAX_RANK)
  21117. integer(1), allocatable :: values_int1(:,:,:,:,:,:,:)
  21118. integer(2), allocatable :: values_int2(:,:,:,:,:,:,:)
  21119. integer(4), allocatable :: values_int4(:,:,:,:,:,:,:)
  21120. integer(8), allocatable :: values_int8(:,:,:,:,:,:,:)
  21121. real(4), allocatable :: values_real4(:,:,:,:,:,:,:)
  21122. real(8), allocatable :: values_real8(:,:,:,:,:,:,:)
  21123. #endif
  21124. ! --- begin --------------------------------------
  21125. ! pointer to file structure:
  21126. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21127. IF_NOT_OK_RETURN(status=1)
  21128. ! pointer to variable structure:
  21129. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21130. IF_NOT_OK_RETURN(status=1)
  21131. ! check ...
  21132. if ( size(shape(values)) > varp%ndim ) then
  21133. write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr
  21134. write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr
  21135. write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr
  21136. TRACEBACK; status=1; return
  21137. end if
  21138. ! check ...
  21139. if ( present(start ) ) then
  21140. if ( size(start ) /= varp%ndim ) then
  21141. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  21142. write (gol,'(" size start : ",i6)') size(start ); call goErr
  21143. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  21144. TRACEBACK; status=1; return
  21145. end if
  21146. end if
  21147. if ( present(count ) ) then
  21148. if ( size(count ) /= varp%ndim ) then
  21149. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  21150. write (gol,'(" size count : ",i6)') size(count ); call goErr
  21151. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  21152. TRACEBACK; status=1; return
  21153. end if
  21154. end if
  21155. if ( present(stride ) ) then
  21156. if ( size(stride ) /= varp%ndim ) then
  21157. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  21158. write (gol,'(" size stride : ",i6)') size(stride ); call goErr
  21159. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  21160. TRACEBACK; status=1; return
  21161. end if
  21162. end if
  21163. if ( present(map ) ) then
  21164. if ( size(map ) /= varp%ndim ) then
  21165. write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr
  21166. write (gol,'(" size map : ",i6)') size(map ); call goErr
  21167. write (gol,'(" var dim : ",i6)') varp%ndim; call goErr
  21168. TRACEBACK; status=1; return
  21169. end if
  21170. end if
  21171. ! loop over file types:
  21172. do iftype = 1, filep%nftype
  21173. ! current type:
  21174. ftype = filep%ftypes(iftype)
  21175. ! select appropriate routine for each type:
  21176. select case ( ftype )
  21177. #ifdef with_hdf4
  21178. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21179. case ( MDF_HDF4 )
  21180. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21181. ! check ...
  21182. if ( present(map ) ) then
  21183. write (gol,'("argument `map` not supported for HDF4")'); call goErr
  21184. TRACEBACK; status=1; return
  21185. end if
  21186. ! fill offset (zero based!), stride, and count :
  21187. hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1
  21188. hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride
  21189. hdf4_count = 1 ! default singleton dimension
  21190. hdf4_count(1:7) = shape(values)
  21191. ! test source type:
  21192. select case ( varp%hdf4_xtype )
  21193. case ( DFNT_INT8 )
  21194. allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21195. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 )
  21196. values = real(values_int1,kind=8)
  21197. deallocate( values_int1 )
  21198. case ( DFNT_INT16 )
  21199. allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21200. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 )
  21201. values = real(values_int2,kind=8)
  21202. deallocate( values_int2 )
  21203. case ( DFNT_INT32 )
  21204. allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21205. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 )
  21206. values = real(values_int4,kind=8)
  21207. deallocate( values_int4 )
  21208. case ( DFNT_INT64 )
  21209. allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21210. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 )
  21211. values = real(values_int8,kind=8)
  21212. deallocate( values_int8 )
  21213. case ( DFNT_FLOAT32 )
  21214. allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21215. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 )
  21216. values = real(values_real4,kind=8)
  21217. deallocate( values_real4 )
  21218. case ( DFNT_FLOAT64 )
  21219. allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) )
  21220. status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 )
  21221. values = real(values_real8,kind=8)
  21222. deallocate( values_real8 )
  21223. case default
  21224. write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr
  21225. TRACEBACK; status=1; return
  21226. end select
  21227. if ( status == FAIL ) then
  21228. write (gol,'("reading hdf4 data set:")'); call goErr
  21229. write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr
  21230. write (gol,'(" data set : ",a)') trim(varp%name); call goErr
  21231. write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr
  21232. write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr
  21233. write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr
  21234. write (gol,'(" size : ",i6)') size(values); call goErr
  21235. TRACEBACK; status=1; return
  21236. end if
  21237. #endif
  21238. #ifdef with_netcdf
  21239. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21240. case ( MDF_NETCDF, MDF_NETCDF4 )
  21241. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21242. ! read values, converted automatically:
  21243. status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, &
  21244. start, count, stride, map )
  21245. IF_NF90_NOT_OK_RETURN(status=1)
  21246. #endif
  21247. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21248. case default
  21249. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21250. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21251. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21252. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21253. TRACEBACK; status=1; return
  21254. end select
  21255. end do ! file types
  21256. ! ok
  21257. status = 0
  21258. end subroutine MDF_Get_Var_r8_7d
  21259. ! ***
  21260. ! ********************************************************************
  21261. ! ***
  21262. ! *** attributes
  21263. ! ***
  21264. ! ********************************************************************
  21265. subroutine MDF_Put_Att_c1_0d( hid, varid, name, values, status )
  21266. #ifdef with_hdf5_beta
  21267. use HDF5, only : HID_T, HSIZE_T
  21268. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  21269. use HDF5, only : H5T_NATIVE_CHARACTER
  21270. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  21271. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  21272. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  21273. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  21274. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  21275. #endif
  21276. #ifdef with_netcdf
  21277. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  21278. #endif
  21279. ! --- in/out -------------------------------------
  21280. integer, intent(in) :: hid
  21281. integer, intent(in) :: varid
  21282. character(len=*), intent(in) :: name
  21283. character(len=*), intent(in) :: values
  21284. integer, intent(out) :: status
  21285. ! --- const --------------------------------------
  21286. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_c1_0d'
  21287. ! --- external -------------------------------
  21288. #ifdef with_hdf4
  21289. integer(hdf4_wpi), external :: sfSCAtt
  21290. integer(hdf4_wpi), external :: sfSNAtt
  21291. #endif
  21292. ! --- local --------------------------------------
  21293. type(MDF_File), pointer :: filep
  21294. type(MDF_Var), pointer :: varp
  21295. integer :: iftype
  21296. integer :: ftype
  21297. #ifdef with_hdf4
  21298. integer :: hdf4_id
  21299. #endif
  21300. #ifdef with_hdf5_beta
  21301. integer(HID_T) :: hdf5_loc_id
  21302. integer(HID_T) :: hdf5_attr_id
  21303. integer(HID_T) :: hdf5_space_id
  21304. integer(HID_T) :: hdf5_type_id
  21305. #endif
  21306. #ifdef with_netcdf
  21307. integer :: netcdf_varid
  21308. #endif
  21309. ! --- begin --------------------------------------
  21310. ! pointer to file structure:
  21311. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21312. IF_NOT_OK_RETURN(status=1)
  21313. ! global or variable attribute ?
  21314. if ( varid == MDF_GLOBAL ) then
  21315. ! increase counter:
  21316. filep%natt = filep%natt + 1
  21317. else
  21318. ! pointer to variable structure:
  21319. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21320. IF_NOT_OK_RETURN(status=1)
  21321. ! increase counter:
  21322. varp%natt = varp%natt + 1
  21323. end if
  21324. ! loop over file types:
  21325. do iftype = 1, filep%nftype
  21326. ! current type:
  21327. ftype = filep%ftypes(iftype)
  21328. ! select appropriate routine for each type:
  21329. select case ( ftype )
  21330. #ifdef with_hdf4
  21331. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21332. case ( MDF_HDF4 )
  21333. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21334. ! set variable id:
  21335. if ( varid == MDF_GLOBAL ) then
  21336. hdf4_id = filep%hdf4_id
  21337. else
  21338. hdf4_id = varp%hdf4_sdid
  21339. end if
  21340. ! store character attribute:
  21341. status = sfSCAtt( hdf4_id, trim(name), DFNT_CHAR, len(values), values )
  21342. if ( status /= SUCCEED ) then
  21343. write (*,'("writing attribute : ",a)') trim(name); call goErr
  21344. TRACEBACK; status=1; return
  21345. end if
  21346. #endif
  21347. #ifdef with_hdf5_beta
  21348. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21349. case ( MDF_HDF5 )
  21350. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21351. ! set variable id:
  21352. if ( varid == MDF_GLOBAL ) then
  21353. hdf5_loc_id = filep%hdf5_file_id
  21354. else
  21355. hdf5_loc_id = varp%hdf5_dataset_id
  21356. end if
  21357. ! data type:
  21358. call H5TCopy_f( H5T_NATIVE_CHARACTER, hdf5_type_id, status )
  21359. IF_NOT_OK_RETURN(status=1)
  21360. ! set length:
  21361. call H5TSet_Size_f( hdf5_type_id, len(values), status )
  21362. IF_NOT_OK_RETURN(status=1)
  21363. ! data space:
  21364. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  21365. IF_NOT_OK_RETURN(status=1)
  21366. ! create attribute; type in file is same as type provided to this routine:
  21367. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  21368. IF_NOT_OK_RETURN(status=1)
  21369. ! write attribute values:
  21370. call H5AWrite_f( hdf5_attr_id, hdf5_type_id, values, int((/len(values)/),kind=HSIZE_T), status )
  21371. IF_NOT_OK_RETURN(status=1)
  21372. ! release attribute:
  21373. call H5AClose_f( hdf5_attr_id, status )
  21374. IF_NOT_OK_RETURN(status=1)
  21375. ! release data space:
  21376. call H5SClose_f( hdf5_space_id, status )
  21377. IF_NOT_OK_RETURN(status=1)
  21378. ! release data type:
  21379. call H5TClose_f( hdf5_type_id, status )
  21380. IF_NOT_OK_RETURN(status=1)
  21381. #endif
  21382. #ifdef with_netcdf
  21383. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21384. case ( MDF_NETCDF, MDF_NETCDF4 )
  21385. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21386. ! set variable id:
  21387. if ( varid == MDF_GLOBAL ) then
  21388. netcdf_varid = NF90_GLOBAL
  21389. else
  21390. netcdf_varid = varp%netcdf_varid
  21391. end if
  21392. ! write attribute:
  21393. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  21394. IF_NF90_NOT_OK_RETURN(status=1)
  21395. #endif
  21396. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21397. case default
  21398. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21399. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21400. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21401. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21402. TRACEBACK; status=1; return
  21403. end select
  21404. end do ! file types
  21405. ! ok
  21406. status = 0
  21407. end subroutine MDF_Put_Att_c1_0d
  21408. ! ***
  21409. subroutine MDF_Get_Att_c1_0d( hid, varid, name, values, status )
  21410. #ifdef with_hdf5_beta
  21411. use HDF5, only : HSIZE_T
  21412. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  21413. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  21414. use HDF5, only : H5T_NATIVE_CHARACTER
  21415. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  21416. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  21417. #endif
  21418. #ifdef with_netcdf
  21419. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  21420. #endif
  21421. ! --- in/out -------------------------------------
  21422. integer, intent(in) :: hid
  21423. integer, intent(in) :: varid
  21424. character(len=*), intent(in) :: name
  21425. character(len=*), intent(out) :: values
  21426. integer, intent(out) :: status
  21427. ! --- const --------------------------------------
  21428. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_c1_0d'
  21429. ! --- external -------------------------------
  21430. #ifdef with_hdf4
  21431. integer(hdf4_wpi), external :: sfFAttr
  21432. integer(hdf4_wpi), external :: sfGAInfo
  21433. integer(hdf4_wpi), external :: sfRCAtt
  21434. integer(hdf4_wpi), external :: sfRNAtt
  21435. #endif
  21436. ! --- local --------------------------------------
  21437. type(MDF_File), pointer :: filep
  21438. type(MDF_Var), pointer :: varp
  21439. integer :: ftype
  21440. #ifdef with_hdf4
  21441. integer :: hdf4_id
  21442. integer :: hdf4_iatt
  21443. character(len=LEN_NAME) :: hdf4_name
  21444. integer :: hdf4_xtype
  21445. integer :: hdf4_length
  21446. #endif
  21447. #ifdef with_hdf5_beta
  21448. integer(HID_T) :: hdf5_loc_id
  21449. character(len=LEN_NAME) :: hdf5_obj_name
  21450. integer(HID_T) :: hdf5_attr_id
  21451. integer(HID_T) :: hdf5_type_id
  21452. #endif
  21453. #ifdef with_netcdf
  21454. integer :: netcdf_varid
  21455. #endif
  21456. ! --- begin --------------------------------------
  21457. ! single type:
  21458. call MDF_Get_Type( hid, ftype, status )
  21459. IF_NOT_OK_RETURN(status=1)
  21460. ! pointer to file structure:
  21461. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21462. IF_NOT_OK_RETURN(status=1)
  21463. ! pointer to variable structure if possible:
  21464. if ( varid /= MDF_GLOBAL ) then
  21465. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21466. IF_NOT_OK_RETURN(status=1)
  21467. end if
  21468. ! select appropriate routine for each type:
  21469. select case ( ftype )
  21470. #ifdef with_hdf4
  21471. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21472. case ( MDF_HDF4 )
  21473. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21474. ! set variable id:
  21475. if ( varid == MDF_GLOBAL ) then
  21476. hdf4_id = filep%hdf4_id
  21477. else
  21478. hdf4_id = varp%hdf4_sdid
  21479. end if
  21480. ! get attribute index given name:
  21481. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  21482. if ( hdf4_iatt == FAIL ) then
  21483. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  21484. TRACEBACK; status=1; return
  21485. end if
  21486. ! get type and length:
  21487. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  21488. if ( status /= SUCCEED ) then
  21489. write (gol,'("getting attribute info")') trim(name); call goErr
  21490. TRACEBACK; status=1; return
  21491. end if
  21492. ! check ...
  21493. if ( hdf4_length > len(values) ) then
  21494. write (gol,'("length of character attribute `",a,"` (",i6,") exceeds output length (",i6,") ;")') &
  21495. trim(name), hdf4_length, len(values); call goErr
  21496. TRACEBACK; status=1; return
  21497. end if
  21498. ! read character attribute:
  21499. status = sfRCAtt( hdf4_id, hdf4_iatt, values )
  21500. if ( status /= SUCCEED ) then
  21501. write (*,'("reading attribute : ",a)') trim(name); call goErr
  21502. TRACEBACK; status=1; return
  21503. end if
  21504. ! truncate ...
  21505. values = values(1:hdf4_length)
  21506. #endif
  21507. #ifdef with_hdf5_beta
  21508. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21509. case ( MDF_HDF5 )
  21510. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21511. ! set variable id:
  21512. if ( varid == MDF_GLOBAL ) then
  21513. ! file id:
  21514. hdf5_loc_id = filep%hdf5_file_id
  21515. hdf5_obj_name = '.'
  21516. else
  21517. ! file id:
  21518. hdf5_loc_id = varp%hdf5_dataset_id
  21519. hdf5_obj_name = '.'
  21520. end if
  21521. ! data type:
  21522. call H5TCopy_f( H5T_NATIVE_CHARACTER, hdf5_type_id, status )
  21523. IF_NOT_OK_RETURN(status=1)
  21524. ! set length:
  21525. call H5TSet_Size_f( hdf5_type_id, len(values), status )
  21526. IF_NOT_OK_RETURN(status=1)
  21527. ! open attribute:
  21528. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  21529. IF_NOT_OK_RETURN(status=1)
  21530. ! read:
  21531. call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/len(values)/),HSIZE_T), status )
  21532. IF_NOT_OK_RETURN(status=1)
  21533. ! release:
  21534. call H5TClose_f( hdf5_type_id, status )
  21535. IF_NOT_OK_RETURN(status=1)
  21536. ! release:
  21537. call H5AClose_f( hdf5_attr_id, status )
  21538. IF_NOT_OK_RETURN(status=1)
  21539. #endif
  21540. #ifdef with_netcdf
  21541. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21542. case ( MDF_NETCDF, MDF_NETCDF4 )
  21543. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21544. ! set variable id:
  21545. if ( varid == MDF_GLOBAL ) then
  21546. netcdf_varid = NF90_GLOBAL
  21547. else
  21548. netcdf_varid = varp%netcdf_varid
  21549. end if
  21550. ! read attribute:
  21551. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  21552. IF_NF90_NOT_OK_RETURN(status=1)
  21553. #endif
  21554. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21555. case default
  21556. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21557. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21558. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21559. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21560. TRACEBACK; status=1; return
  21561. end select
  21562. ! ok
  21563. status = 0
  21564. end subroutine MDF_Get_Att_c1_0d
  21565. subroutine MDF_Put_Att_i1_0d( hid, varid, name, values, status )
  21566. #ifdef with_hdf5_beta
  21567. use HDF5, only : HID_T, HSIZE_T
  21568. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  21569. use HDF5, only : H5T_NATIVE_CHARACTER
  21570. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  21571. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  21572. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  21573. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  21574. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  21575. #endif
  21576. #ifdef with_netcdf
  21577. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  21578. #endif
  21579. ! --- in/out -------------------------------------
  21580. integer, intent(in) :: hid
  21581. integer, intent(in) :: varid
  21582. character(len=*), intent(in) :: name
  21583. integer(1), intent(in) :: values
  21584. integer, intent(out) :: status
  21585. ! --- const --------------------------------------
  21586. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i1_0d'
  21587. ! --- external -------------------------------
  21588. #ifdef with_hdf4
  21589. integer(hdf4_wpi), external :: sfSCAtt
  21590. integer(hdf4_wpi), external :: sfSNAtt
  21591. #endif
  21592. ! --- local --------------------------------------
  21593. type(MDF_File), pointer :: filep
  21594. type(MDF_Var), pointer :: varp
  21595. integer :: iftype
  21596. integer :: ftype
  21597. #ifdef with_hdf4
  21598. integer :: hdf4_id
  21599. #endif
  21600. #ifdef with_hdf5_beta
  21601. integer(HID_T) :: hdf5_loc_id
  21602. integer(HID_T) :: hdf5_attr_id
  21603. integer(HID_T) :: hdf5_space_id
  21604. integer(HID_T) :: hdf5_type_id
  21605. #endif
  21606. #ifdef with_netcdf
  21607. integer :: netcdf_varid
  21608. #endif
  21609. ! --- begin --------------------------------------
  21610. ! pointer to file structure:
  21611. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21612. IF_NOT_OK_RETURN(status=1)
  21613. ! global or variable attribute ?
  21614. if ( varid == MDF_GLOBAL ) then
  21615. ! increase counter:
  21616. filep%natt = filep%natt + 1
  21617. else
  21618. ! pointer to variable structure:
  21619. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21620. IF_NOT_OK_RETURN(status=1)
  21621. ! increase counter:
  21622. varp%natt = varp%natt + 1
  21623. end if
  21624. ! loop over file types:
  21625. do iftype = 1, filep%nftype
  21626. ! current type:
  21627. ftype = filep%ftypes(iftype)
  21628. ! select appropriate routine for each type:
  21629. select case ( ftype )
  21630. #ifdef with_hdf4
  21631. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21632. case ( MDF_HDF4 )
  21633. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21634. ! set variable id:
  21635. if ( varid == MDF_GLOBAL ) then
  21636. hdf4_id = filep%hdf4_id
  21637. else
  21638. hdf4_id = varp%hdf4_sdid
  21639. end if
  21640. ! store numerical attribute:
  21641. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT8, 1, values )
  21642. if ( status /= SUCCEED ) then
  21643. write (*,'("writing attribute : ",a)') trim(name); call goErr
  21644. TRACEBACK; status=1; return
  21645. end if
  21646. #endif
  21647. #ifdef with_hdf5_beta
  21648. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21649. case ( MDF_HDF5 )
  21650. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21651. ! set variable id:
  21652. if ( varid == MDF_GLOBAL ) then
  21653. hdf5_loc_id = filep%hdf5_file_id
  21654. else
  21655. hdf5_loc_id = varp%hdf5_dataset_id
  21656. end if
  21657. ! data type:
  21658. call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status )
  21659. IF_NOT_OK_RETURN(status=1)
  21660. ! data space:
  21661. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  21662. IF_NOT_OK_RETURN(status=1)
  21663. ! create attribute; type in file is same as type provided to this routine:
  21664. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  21665. IF_NOT_OK_RETURN(status=1)
  21666. ! write attribute values:
  21667. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status )
  21668. IF_NOT_OK_RETURN(status=1)
  21669. ! release attribute:
  21670. call H5AClose_f( hdf5_attr_id, status )
  21671. IF_NOT_OK_RETURN(status=1)
  21672. ! release data space:
  21673. call H5SClose_f( hdf5_space_id, status )
  21674. IF_NOT_OK_RETURN(status=1)
  21675. ! release data type:
  21676. call H5TClose_f( hdf5_type_id, status )
  21677. IF_NOT_OK_RETURN(status=1)
  21678. #endif
  21679. #ifdef with_netcdf
  21680. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21681. case ( MDF_NETCDF, MDF_NETCDF4 )
  21682. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21683. ! set variable id:
  21684. if ( varid == MDF_GLOBAL ) then
  21685. netcdf_varid = NF90_GLOBAL
  21686. else
  21687. netcdf_varid = varp%netcdf_varid
  21688. end if
  21689. ! write attribute:
  21690. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  21691. IF_NF90_NOT_OK_RETURN(status=1)
  21692. #endif
  21693. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21694. case default
  21695. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21696. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21697. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21698. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21699. TRACEBACK; status=1; return
  21700. end select
  21701. end do ! file types
  21702. ! ok
  21703. status = 0
  21704. end subroutine MDF_Put_Att_i1_0d
  21705. ! ***
  21706. subroutine MDF_Get_Att_i1_0d( hid, varid, name, values, status )
  21707. #ifdef with_hdf5_beta
  21708. use HDF5, only : HSIZE_T
  21709. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  21710. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  21711. use HDF5, only : H5T_NATIVE_CHARACTER
  21712. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  21713. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  21714. #endif
  21715. #ifdef with_netcdf
  21716. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  21717. #endif
  21718. ! --- in/out -------------------------------------
  21719. integer, intent(in) :: hid
  21720. integer, intent(in) :: varid
  21721. character(len=*), intent(in) :: name
  21722. integer(1), intent(out) :: values
  21723. integer, intent(out) :: status
  21724. ! --- const --------------------------------------
  21725. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i1_0d'
  21726. ! --- external -------------------------------
  21727. #ifdef with_hdf4
  21728. integer(hdf4_wpi), external :: sfFAttr
  21729. integer(hdf4_wpi), external :: sfGAInfo
  21730. integer(hdf4_wpi), external :: sfRCAtt
  21731. integer(hdf4_wpi), external :: sfRNAtt
  21732. #endif
  21733. ! --- local --------------------------------------
  21734. type(MDF_File), pointer :: filep
  21735. type(MDF_Var), pointer :: varp
  21736. integer :: ftype
  21737. #ifdef with_hdf4
  21738. integer :: hdf4_id
  21739. integer :: hdf4_iatt
  21740. character(len=LEN_NAME) :: hdf4_name
  21741. integer :: hdf4_xtype
  21742. integer :: hdf4_length
  21743. integer(1) :: values_int1
  21744. integer(2) :: values_int2
  21745. integer(4) :: values_int4
  21746. integer(8) :: values_int8
  21747. real(4) :: values_real4
  21748. real(8) :: values_real8
  21749. #endif
  21750. #ifdef with_hdf5_beta
  21751. integer(HID_T) :: hdf5_loc_id
  21752. character(len=LEN_NAME) :: hdf5_obj_name
  21753. integer(HID_T) :: hdf5_attr_id
  21754. integer(HID_T) :: hdf5_type_id
  21755. integer(4) :: hdf5_values_int4
  21756. #endif
  21757. #ifdef with_netcdf
  21758. integer :: netcdf_varid
  21759. #endif
  21760. ! --- begin --------------------------------------
  21761. ! single type:
  21762. call MDF_Get_Type( hid, ftype, status )
  21763. IF_NOT_OK_RETURN(status=1)
  21764. ! pointer to file structure:
  21765. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21766. IF_NOT_OK_RETURN(status=1)
  21767. ! pointer to variable structure if possible:
  21768. if ( varid /= MDF_GLOBAL ) then
  21769. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21770. IF_NOT_OK_RETURN(status=1)
  21771. end if
  21772. ! select appropriate routine for each type:
  21773. select case ( ftype )
  21774. #ifdef with_hdf4
  21775. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21776. case ( MDF_HDF4 )
  21777. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21778. ! set variable id:
  21779. if ( varid == MDF_GLOBAL ) then
  21780. hdf4_id = filep%hdf4_id
  21781. else
  21782. hdf4_id = varp%hdf4_sdid
  21783. end if
  21784. ! get attribute index given name:
  21785. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  21786. if ( hdf4_iatt == FAIL ) then
  21787. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  21788. TRACEBACK; status=1; return
  21789. end if
  21790. ! get type and length:
  21791. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  21792. if ( status /= SUCCEED ) then
  21793. write (gol,'("getting attribute info")') trim(name); call goErr
  21794. TRACEBACK; status=1; return
  21795. end if
  21796. ! read numerical attribute:
  21797. select case ( hdf4_xtype )
  21798. case ( DFNT_INT8 )
  21799. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  21800. values = int(values_int1,kind=1)
  21801. case ( DFNT_INT16 )
  21802. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  21803. values = int(values_int2,kind=1)
  21804. case ( DFNT_INT32 )
  21805. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  21806. values = int(values_int4,kind=1)
  21807. case ( DFNT_INT64 )
  21808. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  21809. values = int(values_int8,kind=1)
  21810. case ( DFNT_FLOAT32 )
  21811. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  21812. values = int(values_real4,kind=1)
  21813. case ( DFNT_FLOAT64 )
  21814. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  21815. values = int(values_real8,kind=1)
  21816. case default
  21817. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  21818. TRACEBACK; status=1; return
  21819. end select
  21820. if ( status /= SUCCEED ) then
  21821. write (*,'("reading attribute : ",a)') trim(name); call goErr
  21822. TRACEBACK; status=1; return
  21823. end if
  21824. #endif
  21825. #ifdef with_hdf5_beta
  21826. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21827. case ( MDF_HDF5 )
  21828. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21829. ! set variable id:
  21830. if ( varid == MDF_GLOBAL ) then
  21831. ! file id:
  21832. hdf5_loc_id = filep%hdf5_file_id
  21833. hdf5_obj_name = '.'
  21834. else
  21835. ! file id:
  21836. hdf5_loc_id = varp%hdf5_dataset_id
  21837. hdf5_obj_name = '.'
  21838. end if
  21839. ! data type:
  21840. call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status )
  21841. IF_NOT_OK_RETURN(status=1)
  21842. ! open attribute:
  21843. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  21844. IF_NOT_OK_RETURN(status=1)
  21845. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  21846. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status )
  21847. IF_NOT_OK_RETURN(status=1)
  21848. ! convert:
  21849. values = int(hdf5_values_int4,1)
  21850. ! release:
  21851. call H5TClose_f( hdf5_type_id, status )
  21852. IF_NOT_OK_RETURN(status=1)
  21853. ! release:
  21854. call H5AClose_f( hdf5_attr_id, status )
  21855. IF_NOT_OK_RETURN(status=1)
  21856. #endif
  21857. #ifdef with_netcdf
  21858. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21859. case ( MDF_NETCDF, MDF_NETCDF4 )
  21860. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21861. ! set variable id:
  21862. if ( varid == MDF_GLOBAL ) then
  21863. netcdf_varid = NF90_GLOBAL
  21864. else
  21865. netcdf_varid = varp%netcdf_varid
  21866. end if
  21867. ! read attribute:
  21868. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  21869. IF_NF90_NOT_OK_RETURN(status=1)
  21870. #endif
  21871. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21872. case default
  21873. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21874. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  21875. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  21876. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  21877. TRACEBACK; status=1; return
  21878. end select
  21879. ! ok
  21880. status = 0
  21881. end subroutine MDF_Get_Att_i1_0d
  21882. subroutine MDF_Put_Att_i1_1d( hid, varid, name, values, status )
  21883. #ifdef with_hdf5_beta
  21884. use HDF5, only : HID_T, HSIZE_T
  21885. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  21886. use HDF5, only : H5T_NATIVE_CHARACTER
  21887. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  21888. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  21889. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  21890. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  21891. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  21892. #endif
  21893. #ifdef with_netcdf
  21894. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  21895. #endif
  21896. ! --- in/out -------------------------------------
  21897. integer, intent(in) :: hid
  21898. integer, intent(in) :: varid
  21899. character(len=*), intent(in) :: name
  21900. integer(1), intent(in) :: values(:)
  21901. integer, intent(out) :: status
  21902. ! --- const --------------------------------------
  21903. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i1_1d'
  21904. ! --- external -------------------------------
  21905. #ifdef with_hdf4
  21906. integer(hdf4_wpi), external :: sfSCAtt
  21907. integer(hdf4_wpi), external :: sfSNAtt
  21908. #endif
  21909. ! --- local --------------------------------------
  21910. type(MDF_File), pointer :: filep
  21911. type(MDF_Var), pointer :: varp
  21912. integer :: iftype
  21913. integer :: ftype
  21914. #ifdef with_hdf4
  21915. integer :: hdf4_id
  21916. #endif
  21917. #ifdef with_hdf5_beta
  21918. integer(HID_T) :: hdf5_loc_id
  21919. integer(HID_T) :: hdf5_attr_id
  21920. integer(HID_T) :: hdf5_space_id
  21921. integer(HID_T) :: hdf5_type_id
  21922. #endif
  21923. #ifdef with_netcdf
  21924. integer :: netcdf_varid
  21925. #endif
  21926. ! --- begin --------------------------------------
  21927. ! pointer to file structure:
  21928. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  21929. IF_NOT_OK_RETURN(status=1)
  21930. ! global or variable attribute ?
  21931. if ( varid == MDF_GLOBAL ) then
  21932. ! increase counter:
  21933. filep%natt = filep%natt + 1
  21934. else
  21935. ! pointer to variable structure:
  21936. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  21937. IF_NOT_OK_RETURN(status=1)
  21938. ! increase counter:
  21939. varp%natt = varp%natt + 1
  21940. end if
  21941. ! loop over file types:
  21942. do iftype = 1, filep%nftype
  21943. ! current type:
  21944. ftype = filep%ftypes(iftype)
  21945. ! select appropriate routine for each type:
  21946. select case ( ftype )
  21947. #ifdef with_hdf4
  21948. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21949. case ( MDF_HDF4 )
  21950. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21951. ! set variable id:
  21952. if ( varid == MDF_GLOBAL ) then
  21953. hdf4_id = filep%hdf4_id
  21954. else
  21955. hdf4_id = varp%hdf4_sdid
  21956. end if
  21957. ! strore numerical attribute:
  21958. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT8, size(values), values )
  21959. if ( status /= SUCCEED ) then
  21960. write (*,'("writing attribute : ",a)') trim(name); call goErr
  21961. TRACEBACK; status=1; return
  21962. end if
  21963. #endif
  21964. #ifdef with_hdf5_beta
  21965. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21966. case ( MDF_HDF5 )
  21967. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  21968. ! set variable id:
  21969. if ( varid == MDF_GLOBAL ) then
  21970. hdf5_loc_id = filep%hdf5_file_id
  21971. else
  21972. hdf5_loc_id = varp%hdf5_dataset_id
  21973. end if
  21974. ! data type:
  21975. call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status )
  21976. IF_NOT_OK_RETURN(status=1)
  21977. ! data space:
  21978. call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status )
  21979. IF_NOT_OK_RETURN(status=1)
  21980. ! set extent of the data space:
  21981. call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status )
  21982. IF_NOT_OK_RETURN(status=1)
  21983. ! create attribute; type in file is same as type provided to this routine:
  21984. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  21985. IF_NOT_OK_RETURN(status=1)
  21986. ! write attribute values:
  21987. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status )
  21988. IF_NOT_OK_RETURN(status=1)
  21989. ! release attribute:
  21990. call H5AClose_f( hdf5_attr_id, status )
  21991. IF_NOT_OK_RETURN(status=1)
  21992. ! release data space:
  21993. call H5SClose_f( hdf5_space_id, status )
  21994. IF_NOT_OK_RETURN(status=1)
  21995. ! release data type:
  21996. call H5TClose_f( hdf5_type_id, status )
  21997. IF_NOT_OK_RETURN(status=1)
  21998. #endif
  21999. #ifdef with_netcdf
  22000. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22001. case ( MDF_NETCDF, MDF_NETCDF4 )
  22002. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22003. ! set variable id:
  22004. if ( varid == MDF_GLOBAL ) then
  22005. netcdf_varid = NF90_GLOBAL
  22006. else
  22007. netcdf_varid = varp%netcdf_varid
  22008. end if
  22009. ! write attribute:
  22010. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22011. IF_NF90_NOT_OK_RETURN(status=1)
  22012. #endif
  22013. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22014. case default
  22015. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22016. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22017. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22018. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22019. TRACEBACK; status=1; return
  22020. end select
  22021. end do ! file types
  22022. ! ok
  22023. status = 0
  22024. end subroutine MDF_Put_Att_i1_1d
  22025. ! ***
  22026. subroutine MDF_Get_Att_i1_1d( hid, varid, name, values, status )
  22027. #ifdef with_hdf5_beta
  22028. use HDF5, only : HSIZE_T
  22029. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  22030. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22031. use HDF5, only : H5T_NATIVE_CHARACTER
  22032. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  22033. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22034. #endif
  22035. #ifdef with_netcdf
  22036. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  22037. #endif
  22038. ! --- in/out -------------------------------------
  22039. integer, intent(in) :: hid
  22040. integer, intent(in) :: varid
  22041. character(len=*), intent(in) :: name
  22042. integer(1), intent(out) :: values(:)
  22043. integer, intent(out) :: status
  22044. ! --- const --------------------------------------
  22045. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i1_1d'
  22046. ! --- external -------------------------------
  22047. #ifdef with_hdf4
  22048. integer(hdf4_wpi), external :: sfFAttr
  22049. integer(hdf4_wpi), external :: sfGAInfo
  22050. integer(hdf4_wpi), external :: sfRCAtt
  22051. integer(hdf4_wpi), external :: sfRNAtt
  22052. #endif
  22053. ! --- local --------------------------------------
  22054. type(MDF_File), pointer :: filep
  22055. type(MDF_Var), pointer :: varp
  22056. integer :: ftype
  22057. #ifdef with_hdf4
  22058. integer :: hdf4_id
  22059. integer :: hdf4_iatt
  22060. character(len=LEN_NAME) :: hdf4_name
  22061. integer :: hdf4_xtype
  22062. integer :: hdf4_length
  22063. integer(1), allocatable :: values_int1(:)
  22064. integer(2), allocatable :: values_int2(:)
  22065. integer(4), allocatable :: values_int4(:)
  22066. integer(8), allocatable :: values_int8(:)
  22067. real(4), allocatable :: values_real4(:)
  22068. real(8), allocatable :: values_real8(:)
  22069. #endif
  22070. #ifdef with_hdf5_beta
  22071. integer(HID_T) :: hdf5_loc_id
  22072. character(len=LEN_NAME) :: hdf5_obj_name
  22073. integer(HID_T) :: hdf5_attr_id
  22074. integer(HID_T) :: hdf5_type_id
  22075. integer(4), allocatable :: hdf5_values_int4(:)
  22076. #endif
  22077. #ifdef with_netcdf
  22078. integer :: netcdf_varid
  22079. #endif
  22080. ! --- begin --------------------------------------
  22081. ! single type:
  22082. call MDF_Get_Type( hid, ftype, status )
  22083. IF_NOT_OK_RETURN(status=1)
  22084. ! pointer to file structure:
  22085. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22086. IF_NOT_OK_RETURN(status=1)
  22087. ! pointer to variable structure if possible:
  22088. if ( varid /= MDF_GLOBAL ) then
  22089. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22090. IF_NOT_OK_RETURN(status=1)
  22091. end if
  22092. ! select appropriate routine for each type:
  22093. select case ( ftype )
  22094. #ifdef with_hdf4
  22095. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22096. case ( MDF_HDF4 )
  22097. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22098. ! set variable id:
  22099. if ( varid == MDF_GLOBAL ) then
  22100. hdf4_id = filep%hdf4_id
  22101. else
  22102. hdf4_id = varp%hdf4_sdid
  22103. end if
  22104. ! get attribute index given name:
  22105. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  22106. if ( hdf4_iatt == FAIL ) then
  22107. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  22108. TRACEBACK; status=1; return
  22109. end if
  22110. ! get type and length:
  22111. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  22112. if ( status /= SUCCEED ) then
  22113. write (gol,'("getting attribute info")') trim(name); call goErr
  22114. TRACEBACK; status=1; return
  22115. end if
  22116. ! read numerical attribute:
  22117. select case ( hdf4_xtype )
  22118. case ( DFNT_INT8 )
  22119. allocate( values_int1(hdf4_length) )
  22120. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  22121. values = int(values_int1,kind=1)
  22122. deallocate( values_int1 )
  22123. case ( DFNT_INT16 )
  22124. allocate( values_int2(hdf4_length) )
  22125. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  22126. values = int(values_int2,kind=1)
  22127. deallocate( values_int2 )
  22128. case ( DFNT_INT32 )
  22129. allocate( values_int4(hdf4_length) )
  22130. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  22131. values = int(values_int4,kind=1)
  22132. deallocate( values_int4 )
  22133. case ( DFNT_INT64 )
  22134. allocate( values_int8(hdf4_length) )
  22135. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  22136. values = int(values_int8,kind=1)
  22137. deallocate( values_int8 )
  22138. case ( DFNT_FLOAT32 )
  22139. allocate( values_real4(hdf4_length) )
  22140. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  22141. values = int(values_real4,kind=1)
  22142. deallocate( values_real4 )
  22143. case ( DFNT_FLOAT64 )
  22144. allocate( values_real8(hdf4_length) )
  22145. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  22146. values = int(values_real8,kind=1)
  22147. deallocate( values_real8 )
  22148. case default
  22149. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  22150. TRACEBACK; status=1; return
  22151. end select
  22152. if ( status /= SUCCEED ) then
  22153. write (*,'("reading attribute : ",a)') trim(name); call goErr
  22154. TRACEBACK; status=1; return
  22155. end if
  22156. #endif
  22157. #ifdef with_hdf5_beta
  22158. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22159. case ( MDF_HDF5 )
  22160. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22161. ! set variable id:
  22162. if ( varid == MDF_GLOBAL ) then
  22163. ! file id:
  22164. hdf5_loc_id = filep%hdf5_file_id
  22165. hdf5_obj_name = '.'
  22166. else
  22167. ! file id:
  22168. hdf5_loc_id = varp%hdf5_dataset_id
  22169. hdf5_obj_name = '.'
  22170. end if
  22171. ! data type:
  22172. call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status )
  22173. IF_NOT_OK_RETURN(status=1)
  22174. ! open attribute:
  22175. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  22176. IF_NOT_OK_RETURN(status=1)
  22177. ! storage:
  22178. allocate( hdf5_values_int4(size(values)) )
  22179. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  22180. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status )
  22181. IF_NOT_OK_RETURN(status=1)
  22182. ! convert:
  22183. values = int(hdf5_values_int4,1)
  22184. ! clear:
  22185. deallocate( hdf5_values_int4 )
  22186. ! release:
  22187. call H5TClose_f( hdf5_type_id, status )
  22188. IF_NOT_OK_RETURN(status=1)
  22189. ! release:
  22190. call H5AClose_f( hdf5_attr_id, status )
  22191. IF_NOT_OK_RETURN(status=1)
  22192. #endif
  22193. #ifdef with_netcdf
  22194. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22195. case ( MDF_NETCDF, MDF_NETCDF4 )
  22196. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22197. ! set variable id:
  22198. if ( varid == MDF_GLOBAL ) then
  22199. netcdf_varid = NF90_GLOBAL
  22200. else
  22201. netcdf_varid = varp%netcdf_varid
  22202. end if
  22203. ! read attribute:
  22204. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22205. IF_NF90_NOT_OK_RETURN(status=1)
  22206. #endif
  22207. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22208. case default
  22209. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22210. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22211. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22212. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22213. TRACEBACK; status=1; return
  22214. end select
  22215. ! ok
  22216. status = 0
  22217. end subroutine MDF_Get_Att_i1_1d
  22218. subroutine MDF_Put_Att_i2_0d( hid, varid, name, values, status )
  22219. #ifdef with_hdf5_beta
  22220. use HDF5, only : HID_T, HSIZE_T
  22221. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22222. use HDF5, only : H5T_NATIVE_CHARACTER
  22223. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  22224. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22225. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  22226. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  22227. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  22228. #endif
  22229. #ifdef with_netcdf
  22230. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  22231. #endif
  22232. ! --- in/out -------------------------------------
  22233. integer, intent(in) :: hid
  22234. integer, intent(in) :: varid
  22235. character(len=*), intent(in) :: name
  22236. integer(2), intent(in) :: values
  22237. integer, intent(out) :: status
  22238. ! --- const --------------------------------------
  22239. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i2_0d'
  22240. ! --- external -------------------------------
  22241. #ifdef with_hdf4
  22242. integer(hdf4_wpi), external :: sfSCAtt
  22243. integer(hdf4_wpi), external :: sfSNAtt
  22244. #endif
  22245. ! --- local --------------------------------------
  22246. type(MDF_File), pointer :: filep
  22247. type(MDF_Var), pointer :: varp
  22248. integer :: iftype
  22249. integer :: ftype
  22250. #ifdef with_hdf4
  22251. integer :: hdf4_id
  22252. #endif
  22253. #ifdef with_hdf5_beta
  22254. integer(HID_T) :: hdf5_loc_id
  22255. integer(HID_T) :: hdf5_attr_id
  22256. integer(HID_T) :: hdf5_space_id
  22257. integer(HID_T) :: hdf5_type_id
  22258. #endif
  22259. #ifdef with_netcdf
  22260. integer :: netcdf_varid
  22261. #endif
  22262. ! --- begin --------------------------------------
  22263. ! pointer to file structure:
  22264. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22265. IF_NOT_OK_RETURN(status=1)
  22266. ! global or variable attribute ?
  22267. if ( varid == MDF_GLOBAL ) then
  22268. ! increase counter:
  22269. filep%natt = filep%natt + 1
  22270. else
  22271. ! pointer to variable structure:
  22272. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22273. IF_NOT_OK_RETURN(status=1)
  22274. ! increase counter:
  22275. varp%natt = varp%natt + 1
  22276. end if
  22277. ! loop over file types:
  22278. do iftype = 1, filep%nftype
  22279. ! current type:
  22280. ftype = filep%ftypes(iftype)
  22281. ! select appropriate routine for each type:
  22282. select case ( ftype )
  22283. #ifdef with_hdf4
  22284. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22285. case ( MDF_HDF4 )
  22286. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22287. ! set variable id:
  22288. if ( varid == MDF_GLOBAL ) then
  22289. hdf4_id = filep%hdf4_id
  22290. else
  22291. hdf4_id = varp%hdf4_sdid
  22292. end if
  22293. ! store numerical attribute:
  22294. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT16, 1, values )
  22295. if ( status /= SUCCEED ) then
  22296. write (*,'("writing attribute : ",a)') trim(name); call goErr
  22297. TRACEBACK; status=1; return
  22298. end if
  22299. #endif
  22300. #ifdef with_hdf5_beta
  22301. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22302. case ( MDF_HDF5 )
  22303. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22304. ! set variable id:
  22305. if ( varid == MDF_GLOBAL ) then
  22306. hdf5_loc_id = filep%hdf5_file_id
  22307. else
  22308. hdf5_loc_id = varp%hdf5_dataset_id
  22309. end if
  22310. ! data type:
  22311. call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status )
  22312. IF_NOT_OK_RETURN(status=1)
  22313. ! data space:
  22314. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  22315. IF_NOT_OK_RETURN(status=1)
  22316. ! create attribute; type in file is same as type provided to this routine:
  22317. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  22318. IF_NOT_OK_RETURN(status=1)
  22319. ! write attribute values:
  22320. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status )
  22321. IF_NOT_OK_RETURN(status=1)
  22322. ! release attribute:
  22323. call H5AClose_f( hdf5_attr_id, status )
  22324. IF_NOT_OK_RETURN(status=1)
  22325. ! release data space:
  22326. call H5SClose_f( hdf5_space_id, status )
  22327. IF_NOT_OK_RETURN(status=1)
  22328. ! release data type:
  22329. call H5TClose_f( hdf5_type_id, status )
  22330. IF_NOT_OK_RETURN(status=1)
  22331. #endif
  22332. #ifdef with_netcdf
  22333. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22334. case ( MDF_NETCDF, MDF_NETCDF4 )
  22335. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22336. ! set variable id:
  22337. if ( varid == MDF_GLOBAL ) then
  22338. netcdf_varid = NF90_GLOBAL
  22339. else
  22340. netcdf_varid = varp%netcdf_varid
  22341. end if
  22342. ! write attribute:
  22343. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22344. IF_NF90_NOT_OK_RETURN(status=1)
  22345. #endif
  22346. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22347. case default
  22348. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22349. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22350. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22351. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22352. TRACEBACK; status=1; return
  22353. end select
  22354. end do ! file types
  22355. ! ok
  22356. status = 0
  22357. end subroutine MDF_Put_Att_i2_0d
  22358. ! ***
  22359. subroutine MDF_Get_Att_i2_0d( hid, varid, name, values, status )
  22360. #ifdef with_hdf5_beta
  22361. use HDF5, only : HSIZE_T
  22362. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  22363. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22364. use HDF5, only : H5T_NATIVE_CHARACTER
  22365. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  22366. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22367. #endif
  22368. #ifdef with_netcdf
  22369. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  22370. #endif
  22371. ! --- in/out -------------------------------------
  22372. integer, intent(in) :: hid
  22373. integer, intent(in) :: varid
  22374. character(len=*), intent(in) :: name
  22375. integer(2), intent(out) :: values
  22376. integer, intent(out) :: status
  22377. ! --- const --------------------------------------
  22378. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i2_0d'
  22379. ! --- external -------------------------------
  22380. #ifdef with_hdf4
  22381. integer(hdf4_wpi), external :: sfFAttr
  22382. integer(hdf4_wpi), external :: sfGAInfo
  22383. integer(hdf4_wpi), external :: sfRCAtt
  22384. integer(hdf4_wpi), external :: sfRNAtt
  22385. #endif
  22386. ! --- local --------------------------------------
  22387. type(MDF_File), pointer :: filep
  22388. type(MDF_Var), pointer :: varp
  22389. integer :: ftype
  22390. #ifdef with_hdf4
  22391. integer :: hdf4_id
  22392. integer :: hdf4_iatt
  22393. character(len=LEN_NAME) :: hdf4_name
  22394. integer :: hdf4_xtype
  22395. integer :: hdf4_length
  22396. integer(1) :: values_int1
  22397. integer(2) :: values_int2
  22398. integer(4) :: values_int4
  22399. integer(8) :: values_int8
  22400. real(4) :: values_real4
  22401. real(8) :: values_real8
  22402. #endif
  22403. #ifdef with_hdf5_beta
  22404. integer(HID_T) :: hdf5_loc_id
  22405. character(len=LEN_NAME) :: hdf5_obj_name
  22406. integer(HID_T) :: hdf5_attr_id
  22407. integer(HID_T) :: hdf5_type_id
  22408. integer(4) :: hdf5_values_int4
  22409. #endif
  22410. #ifdef with_netcdf
  22411. integer :: netcdf_varid
  22412. #endif
  22413. ! --- begin --------------------------------------
  22414. ! single type:
  22415. call MDF_Get_Type( hid, ftype, status )
  22416. IF_NOT_OK_RETURN(status=1)
  22417. ! pointer to file structure:
  22418. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22419. IF_NOT_OK_RETURN(status=1)
  22420. ! pointer to variable structure if possible:
  22421. if ( varid /= MDF_GLOBAL ) then
  22422. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22423. IF_NOT_OK_RETURN(status=1)
  22424. end if
  22425. ! select appropriate routine for each type:
  22426. select case ( ftype )
  22427. #ifdef with_hdf4
  22428. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22429. case ( MDF_HDF4 )
  22430. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22431. ! set variable id:
  22432. if ( varid == MDF_GLOBAL ) then
  22433. hdf4_id = filep%hdf4_id
  22434. else
  22435. hdf4_id = varp%hdf4_sdid
  22436. end if
  22437. ! get attribute index given name:
  22438. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  22439. if ( hdf4_iatt == FAIL ) then
  22440. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  22441. TRACEBACK; status=1; return
  22442. end if
  22443. ! get type and length:
  22444. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  22445. if ( status /= SUCCEED ) then
  22446. write (gol,'("getting attribute info")') trim(name); call goErr
  22447. TRACEBACK; status=1; return
  22448. end if
  22449. ! read numerical attribute:
  22450. select case ( hdf4_xtype )
  22451. case ( DFNT_INT8 )
  22452. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  22453. values = int(values_int1,kind=2)
  22454. case ( DFNT_INT16 )
  22455. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  22456. values = int(values_int2,kind=2)
  22457. case ( DFNT_INT32 )
  22458. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  22459. values = int(values_int4,kind=2)
  22460. case ( DFNT_INT64 )
  22461. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  22462. values = int(values_int8,kind=2)
  22463. case ( DFNT_FLOAT32 )
  22464. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  22465. values = int(values_real4,kind=2)
  22466. case ( DFNT_FLOAT64 )
  22467. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  22468. values = int(values_real8,kind=2)
  22469. case default
  22470. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  22471. TRACEBACK; status=1; return
  22472. end select
  22473. if ( status /= SUCCEED ) then
  22474. write (*,'("reading attribute : ",a)') trim(name); call goErr
  22475. TRACEBACK; status=1; return
  22476. end if
  22477. #endif
  22478. #ifdef with_hdf5_beta
  22479. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22480. case ( MDF_HDF5 )
  22481. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22482. ! set variable id:
  22483. if ( varid == MDF_GLOBAL ) then
  22484. ! file id:
  22485. hdf5_loc_id = filep%hdf5_file_id
  22486. hdf5_obj_name = '.'
  22487. else
  22488. ! file id:
  22489. hdf5_loc_id = varp%hdf5_dataset_id
  22490. hdf5_obj_name = '.'
  22491. end if
  22492. ! data type:
  22493. call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status )
  22494. IF_NOT_OK_RETURN(status=1)
  22495. ! open attribute:
  22496. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  22497. IF_NOT_OK_RETURN(status=1)
  22498. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  22499. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status )
  22500. IF_NOT_OK_RETURN(status=1)
  22501. ! convert:
  22502. values = int(hdf5_values_int4,2)
  22503. ! release:
  22504. call H5TClose_f( hdf5_type_id, status )
  22505. IF_NOT_OK_RETURN(status=1)
  22506. ! release:
  22507. call H5AClose_f( hdf5_attr_id, status )
  22508. IF_NOT_OK_RETURN(status=1)
  22509. #endif
  22510. #ifdef with_netcdf
  22511. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22512. case ( MDF_NETCDF, MDF_NETCDF4 )
  22513. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22514. ! set variable id:
  22515. if ( varid == MDF_GLOBAL ) then
  22516. netcdf_varid = NF90_GLOBAL
  22517. else
  22518. netcdf_varid = varp%netcdf_varid
  22519. end if
  22520. ! read attribute:
  22521. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22522. IF_NF90_NOT_OK_RETURN(status=1)
  22523. #endif
  22524. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22525. case default
  22526. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22527. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22528. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22529. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22530. TRACEBACK; status=1; return
  22531. end select
  22532. ! ok
  22533. status = 0
  22534. end subroutine MDF_Get_Att_i2_0d
  22535. subroutine MDF_Put_Att_i2_1d( hid, varid, name, values, status )
  22536. #ifdef with_hdf5_beta
  22537. use HDF5, only : HID_T, HSIZE_T
  22538. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22539. use HDF5, only : H5T_NATIVE_CHARACTER
  22540. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  22541. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22542. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  22543. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  22544. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  22545. #endif
  22546. #ifdef with_netcdf
  22547. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  22548. #endif
  22549. ! --- in/out -------------------------------------
  22550. integer, intent(in) :: hid
  22551. integer, intent(in) :: varid
  22552. character(len=*), intent(in) :: name
  22553. integer(2), intent(in) :: values(:)
  22554. integer, intent(out) :: status
  22555. ! --- const --------------------------------------
  22556. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i2_1d'
  22557. ! --- external -------------------------------
  22558. #ifdef with_hdf4
  22559. integer(hdf4_wpi), external :: sfSCAtt
  22560. integer(hdf4_wpi), external :: sfSNAtt
  22561. #endif
  22562. ! --- local --------------------------------------
  22563. type(MDF_File), pointer :: filep
  22564. type(MDF_Var), pointer :: varp
  22565. integer :: iftype
  22566. integer :: ftype
  22567. #ifdef with_hdf4
  22568. integer :: hdf4_id
  22569. #endif
  22570. #ifdef with_hdf5_beta
  22571. integer(HID_T) :: hdf5_loc_id
  22572. integer(HID_T) :: hdf5_attr_id
  22573. integer(HID_T) :: hdf5_space_id
  22574. integer(HID_T) :: hdf5_type_id
  22575. #endif
  22576. #ifdef with_netcdf
  22577. integer :: netcdf_varid
  22578. #endif
  22579. ! --- begin --------------------------------------
  22580. ! pointer to file structure:
  22581. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22582. IF_NOT_OK_RETURN(status=1)
  22583. ! global or variable attribute ?
  22584. if ( varid == MDF_GLOBAL ) then
  22585. ! increase counter:
  22586. filep%natt = filep%natt + 1
  22587. else
  22588. ! pointer to variable structure:
  22589. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22590. IF_NOT_OK_RETURN(status=1)
  22591. ! increase counter:
  22592. varp%natt = varp%natt + 1
  22593. end if
  22594. ! loop over file types:
  22595. do iftype = 1, filep%nftype
  22596. ! current type:
  22597. ftype = filep%ftypes(iftype)
  22598. ! select appropriate routine for each type:
  22599. select case ( ftype )
  22600. #ifdef with_hdf4
  22601. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22602. case ( MDF_HDF4 )
  22603. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22604. ! set variable id:
  22605. if ( varid == MDF_GLOBAL ) then
  22606. hdf4_id = filep%hdf4_id
  22607. else
  22608. hdf4_id = varp%hdf4_sdid
  22609. end if
  22610. ! strore numerical attribute:
  22611. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT16, size(values), values )
  22612. if ( status /= SUCCEED ) then
  22613. write (*,'("writing attribute : ",a)') trim(name); call goErr
  22614. TRACEBACK; status=1; return
  22615. end if
  22616. #endif
  22617. #ifdef with_hdf5_beta
  22618. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22619. case ( MDF_HDF5 )
  22620. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22621. ! set variable id:
  22622. if ( varid == MDF_GLOBAL ) then
  22623. hdf5_loc_id = filep%hdf5_file_id
  22624. else
  22625. hdf5_loc_id = varp%hdf5_dataset_id
  22626. end if
  22627. ! data type:
  22628. call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status )
  22629. IF_NOT_OK_RETURN(status=1)
  22630. ! data space:
  22631. call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status )
  22632. IF_NOT_OK_RETURN(status=1)
  22633. ! set extent of the data space:
  22634. call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status )
  22635. IF_NOT_OK_RETURN(status=1)
  22636. ! create attribute; type in file is same as type provided to this routine:
  22637. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  22638. IF_NOT_OK_RETURN(status=1)
  22639. ! write attribute values:
  22640. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status )
  22641. IF_NOT_OK_RETURN(status=1)
  22642. ! release attribute:
  22643. call H5AClose_f( hdf5_attr_id, status )
  22644. IF_NOT_OK_RETURN(status=1)
  22645. ! release data space:
  22646. call H5SClose_f( hdf5_space_id, status )
  22647. IF_NOT_OK_RETURN(status=1)
  22648. ! release data type:
  22649. call H5TClose_f( hdf5_type_id, status )
  22650. IF_NOT_OK_RETURN(status=1)
  22651. #endif
  22652. #ifdef with_netcdf
  22653. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22654. case ( MDF_NETCDF, MDF_NETCDF4 )
  22655. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22656. ! set variable id:
  22657. if ( varid == MDF_GLOBAL ) then
  22658. netcdf_varid = NF90_GLOBAL
  22659. else
  22660. netcdf_varid = varp%netcdf_varid
  22661. end if
  22662. ! write attribute:
  22663. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22664. IF_NF90_NOT_OK_RETURN(status=1)
  22665. #endif
  22666. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22667. case default
  22668. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22669. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22670. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22671. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22672. TRACEBACK; status=1; return
  22673. end select
  22674. end do ! file types
  22675. ! ok
  22676. status = 0
  22677. end subroutine MDF_Put_Att_i2_1d
  22678. ! ***
  22679. subroutine MDF_Get_Att_i2_1d( hid, varid, name, values, status )
  22680. #ifdef with_hdf5_beta
  22681. use HDF5, only : HSIZE_T
  22682. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  22683. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22684. use HDF5, only : H5T_NATIVE_CHARACTER
  22685. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  22686. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22687. #endif
  22688. #ifdef with_netcdf
  22689. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  22690. #endif
  22691. ! --- in/out -------------------------------------
  22692. integer, intent(in) :: hid
  22693. integer, intent(in) :: varid
  22694. character(len=*), intent(in) :: name
  22695. integer(2), intent(out) :: values(:)
  22696. integer, intent(out) :: status
  22697. ! --- const --------------------------------------
  22698. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i2_1d'
  22699. ! --- external -------------------------------
  22700. #ifdef with_hdf4
  22701. integer(hdf4_wpi), external :: sfFAttr
  22702. integer(hdf4_wpi), external :: sfGAInfo
  22703. integer(hdf4_wpi), external :: sfRCAtt
  22704. integer(hdf4_wpi), external :: sfRNAtt
  22705. #endif
  22706. ! --- local --------------------------------------
  22707. type(MDF_File), pointer :: filep
  22708. type(MDF_Var), pointer :: varp
  22709. integer :: ftype
  22710. #ifdef with_hdf4
  22711. integer :: hdf4_id
  22712. integer :: hdf4_iatt
  22713. character(len=LEN_NAME) :: hdf4_name
  22714. integer :: hdf4_xtype
  22715. integer :: hdf4_length
  22716. integer(1), allocatable :: values_int1(:)
  22717. integer(2), allocatable :: values_int2(:)
  22718. integer(4), allocatable :: values_int4(:)
  22719. integer(8), allocatable :: values_int8(:)
  22720. real(4), allocatable :: values_real4(:)
  22721. real(8), allocatable :: values_real8(:)
  22722. #endif
  22723. #ifdef with_hdf5_beta
  22724. integer(HID_T) :: hdf5_loc_id
  22725. character(len=LEN_NAME) :: hdf5_obj_name
  22726. integer(HID_T) :: hdf5_attr_id
  22727. integer(HID_T) :: hdf5_type_id
  22728. integer(4), allocatable :: hdf5_values_int4(:)
  22729. #endif
  22730. #ifdef with_netcdf
  22731. integer :: netcdf_varid
  22732. #endif
  22733. ! --- begin --------------------------------------
  22734. ! single type:
  22735. call MDF_Get_Type( hid, ftype, status )
  22736. IF_NOT_OK_RETURN(status=1)
  22737. ! pointer to file structure:
  22738. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22739. IF_NOT_OK_RETURN(status=1)
  22740. ! pointer to variable structure if possible:
  22741. if ( varid /= MDF_GLOBAL ) then
  22742. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22743. IF_NOT_OK_RETURN(status=1)
  22744. end if
  22745. ! select appropriate routine for each type:
  22746. select case ( ftype )
  22747. #ifdef with_hdf4
  22748. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22749. case ( MDF_HDF4 )
  22750. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22751. ! set variable id:
  22752. if ( varid == MDF_GLOBAL ) then
  22753. hdf4_id = filep%hdf4_id
  22754. else
  22755. hdf4_id = varp%hdf4_sdid
  22756. end if
  22757. ! get attribute index given name:
  22758. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  22759. if ( hdf4_iatt == FAIL ) then
  22760. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  22761. TRACEBACK; status=1; return
  22762. end if
  22763. ! get type and length:
  22764. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  22765. if ( status /= SUCCEED ) then
  22766. write (gol,'("getting attribute info")') trim(name); call goErr
  22767. TRACEBACK; status=1; return
  22768. end if
  22769. ! read numerical attribute:
  22770. select case ( hdf4_xtype )
  22771. case ( DFNT_INT8 )
  22772. allocate( values_int1(hdf4_length) )
  22773. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  22774. values = int(values_int1,kind=2)
  22775. deallocate( values_int1 )
  22776. case ( DFNT_INT16 )
  22777. allocate( values_int2(hdf4_length) )
  22778. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  22779. values = int(values_int2,kind=2)
  22780. deallocate( values_int2 )
  22781. case ( DFNT_INT32 )
  22782. allocate( values_int4(hdf4_length) )
  22783. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  22784. values = int(values_int4,kind=2)
  22785. deallocate( values_int4 )
  22786. case ( DFNT_INT64 )
  22787. allocate( values_int8(hdf4_length) )
  22788. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  22789. values = int(values_int8,kind=2)
  22790. deallocate( values_int8 )
  22791. case ( DFNT_FLOAT32 )
  22792. allocate( values_real4(hdf4_length) )
  22793. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  22794. values = int(values_real4,kind=2)
  22795. deallocate( values_real4 )
  22796. case ( DFNT_FLOAT64 )
  22797. allocate( values_real8(hdf4_length) )
  22798. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  22799. values = int(values_real8,kind=2)
  22800. deallocate( values_real8 )
  22801. case default
  22802. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  22803. TRACEBACK; status=1; return
  22804. end select
  22805. if ( status /= SUCCEED ) then
  22806. write (*,'("reading attribute : ",a)') trim(name); call goErr
  22807. TRACEBACK; status=1; return
  22808. end if
  22809. #endif
  22810. #ifdef with_hdf5_beta
  22811. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22812. case ( MDF_HDF5 )
  22813. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22814. ! set variable id:
  22815. if ( varid == MDF_GLOBAL ) then
  22816. ! file id:
  22817. hdf5_loc_id = filep%hdf5_file_id
  22818. hdf5_obj_name = '.'
  22819. else
  22820. ! file id:
  22821. hdf5_loc_id = varp%hdf5_dataset_id
  22822. hdf5_obj_name = '.'
  22823. end if
  22824. ! data type:
  22825. call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status )
  22826. IF_NOT_OK_RETURN(status=1)
  22827. ! open attribute:
  22828. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  22829. IF_NOT_OK_RETURN(status=1)
  22830. ! storage:
  22831. allocate( hdf5_values_int4(size(values)) )
  22832. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  22833. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status )
  22834. IF_NOT_OK_RETURN(status=1)
  22835. ! convert:
  22836. values = int(hdf5_values_int4,2)
  22837. ! clear:
  22838. deallocate( hdf5_values_int4 )
  22839. ! release:
  22840. call H5TClose_f( hdf5_type_id, status )
  22841. IF_NOT_OK_RETURN(status=1)
  22842. ! release:
  22843. call H5AClose_f( hdf5_attr_id, status )
  22844. IF_NOT_OK_RETURN(status=1)
  22845. #endif
  22846. #ifdef with_netcdf
  22847. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22848. case ( MDF_NETCDF, MDF_NETCDF4 )
  22849. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22850. ! set variable id:
  22851. if ( varid == MDF_GLOBAL ) then
  22852. netcdf_varid = NF90_GLOBAL
  22853. else
  22854. netcdf_varid = varp%netcdf_varid
  22855. end if
  22856. ! read attribute:
  22857. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22858. IF_NF90_NOT_OK_RETURN(status=1)
  22859. #endif
  22860. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22861. case default
  22862. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22863. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  22864. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  22865. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  22866. TRACEBACK; status=1; return
  22867. end select
  22868. ! ok
  22869. status = 0
  22870. end subroutine MDF_Get_Att_i2_1d
  22871. subroutine MDF_Put_Att_i4_0d( hid, varid, name, values, status )
  22872. #ifdef with_hdf5_beta
  22873. use HDF5, only : HID_T, HSIZE_T
  22874. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  22875. use HDF5, only : H5T_NATIVE_CHARACTER
  22876. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  22877. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  22878. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  22879. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  22880. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  22881. #endif
  22882. #ifdef with_netcdf
  22883. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  22884. #endif
  22885. ! --- in/out -------------------------------------
  22886. integer, intent(in) :: hid
  22887. integer, intent(in) :: varid
  22888. character(len=*), intent(in) :: name
  22889. integer(4), intent(in) :: values
  22890. integer, intent(out) :: status
  22891. ! --- const --------------------------------------
  22892. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i4_0d'
  22893. ! --- external -------------------------------
  22894. #ifdef with_hdf4
  22895. integer(hdf4_wpi), external :: sfSCAtt
  22896. integer(hdf4_wpi), external :: sfSNAtt
  22897. #endif
  22898. ! --- local --------------------------------------
  22899. type(MDF_File), pointer :: filep
  22900. type(MDF_Var), pointer :: varp
  22901. integer :: iftype
  22902. integer :: ftype
  22903. #ifdef with_hdf4
  22904. integer :: hdf4_id
  22905. #endif
  22906. #ifdef with_hdf5_beta
  22907. integer(HID_T) :: hdf5_loc_id
  22908. integer(HID_T) :: hdf5_attr_id
  22909. integer(HID_T) :: hdf5_space_id
  22910. integer(HID_T) :: hdf5_type_id
  22911. #endif
  22912. #ifdef with_netcdf
  22913. integer :: netcdf_varid
  22914. #endif
  22915. ! --- begin --------------------------------------
  22916. ! pointer to file structure:
  22917. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  22918. IF_NOT_OK_RETURN(status=1)
  22919. ! global or variable attribute ?
  22920. if ( varid == MDF_GLOBAL ) then
  22921. ! increase counter:
  22922. filep%natt = filep%natt + 1
  22923. else
  22924. ! pointer to variable structure:
  22925. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  22926. IF_NOT_OK_RETURN(status=1)
  22927. ! increase counter:
  22928. varp%natt = varp%natt + 1
  22929. end if
  22930. ! loop over file types:
  22931. do iftype = 1, filep%nftype
  22932. ! current type:
  22933. ftype = filep%ftypes(iftype)
  22934. ! select appropriate routine for each type:
  22935. select case ( ftype )
  22936. #ifdef with_hdf4
  22937. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22938. case ( MDF_HDF4 )
  22939. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22940. ! set variable id:
  22941. if ( varid == MDF_GLOBAL ) then
  22942. hdf4_id = filep%hdf4_id
  22943. else
  22944. hdf4_id = varp%hdf4_sdid
  22945. end if
  22946. ! store numerical attribute:
  22947. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT32, 1, values )
  22948. if ( status /= SUCCEED ) then
  22949. write (*,'("writing attribute : ",a)') trim(name); call goErr
  22950. TRACEBACK; status=1; return
  22951. end if
  22952. #endif
  22953. #ifdef with_hdf5_beta
  22954. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22955. case ( MDF_HDF5 )
  22956. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22957. ! set variable id:
  22958. if ( varid == MDF_GLOBAL ) then
  22959. hdf5_loc_id = filep%hdf5_file_id
  22960. else
  22961. hdf5_loc_id = varp%hdf5_dataset_id
  22962. end if
  22963. ! data type:
  22964. call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status )
  22965. IF_NOT_OK_RETURN(status=1)
  22966. ! data space:
  22967. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  22968. IF_NOT_OK_RETURN(status=1)
  22969. ! create attribute; type in file is same as type provided to this routine:
  22970. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  22971. IF_NOT_OK_RETURN(status=1)
  22972. ! write attribute values:
  22973. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status )
  22974. IF_NOT_OK_RETURN(status=1)
  22975. ! release attribute:
  22976. call H5AClose_f( hdf5_attr_id, status )
  22977. IF_NOT_OK_RETURN(status=1)
  22978. ! release data space:
  22979. call H5SClose_f( hdf5_space_id, status )
  22980. IF_NOT_OK_RETURN(status=1)
  22981. ! release data type:
  22982. call H5TClose_f( hdf5_type_id, status )
  22983. IF_NOT_OK_RETURN(status=1)
  22984. #endif
  22985. #ifdef with_netcdf
  22986. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22987. case ( MDF_NETCDF, MDF_NETCDF4 )
  22988. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  22989. ! set variable id:
  22990. if ( varid == MDF_GLOBAL ) then
  22991. netcdf_varid = NF90_GLOBAL
  22992. else
  22993. netcdf_varid = varp%netcdf_varid
  22994. end if
  22995. ! write attribute:
  22996. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  22997. IF_NF90_NOT_OK_RETURN(status=1)
  22998. #endif
  22999. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23000. case default
  23001. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23002. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23003. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23004. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23005. TRACEBACK; status=1; return
  23006. end select
  23007. end do ! file types
  23008. ! ok
  23009. status = 0
  23010. end subroutine MDF_Put_Att_i4_0d
  23011. ! ***
  23012. subroutine MDF_Get_Att_i4_0d( hid, varid, name, values, status )
  23013. #ifdef with_hdf5_beta
  23014. use HDF5, only : HSIZE_T
  23015. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  23016. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23017. use HDF5, only : H5T_NATIVE_CHARACTER
  23018. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  23019. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23020. #endif
  23021. #ifdef with_netcdf
  23022. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  23023. #endif
  23024. ! --- in/out -------------------------------------
  23025. integer, intent(in) :: hid
  23026. integer, intent(in) :: varid
  23027. character(len=*), intent(in) :: name
  23028. integer(4), intent(out) :: values
  23029. integer, intent(out) :: status
  23030. ! --- const --------------------------------------
  23031. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i4_0d'
  23032. ! --- external -------------------------------
  23033. #ifdef with_hdf4
  23034. integer(hdf4_wpi), external :: sfFAttr
  23035. integer(hdf4_wpi), external :: sfGAInfo
  23036. integer(hdf4_wpi), external :: sfRCAtt
  23037. integer(hdf4_wpi), external :: sfRNAtt
  23038. #endif
  23039. ! --- local --------------------------------------
  23040. type(MDF_File), pointer :: filep
  23041. type(MDF_Var), pointer :: varp
  23042. integer :: ftype
  23043. #ifdef with_hdf4
  23044. integer :: hdf4_id
  23045. integer :: hdf4_iatt
  23046. character(len=LEN_NAME) :: hdf4_name
  23047. integer :: hdf4_xtype
  23048. integer :: hdf4_length
  23049. integer(1) :: values_int1
  23050. integer(2) :: values_int2
  23051. integer(4) :: values_int4
  23052. integer(8) :: values_int8
  23053. real(4) :: values_real4
  23054. real(8) :: values_real8
  23055. #endif
  23056. #ifdef with_hdf5_beta
  23057. integer(HID_T) :: hdf5_loc_id
  23058. character(len=LEN_NAME) :: hdf5_obj_name
  23059. integer(HID_T) :: hdf5_attr_id
  23060. integer(HID_T) :: hdf5_type_id
  23061. integer(4) :: hdf5_values_int4
  23062. #endif
  23063. #ifdef with_netcdf
  23064. integer :: netcdf_varid
  23065. #endif
  23066. ! --- begin --------------------------------------
  23067. ! single type:
  23068. call MDF_Get_Type( hid, ftype, status )
  23069. IF_NOT_OK_RETURN(status=1)
  23070. ! pointer to file structure:
  23071. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23072. IF_NOT_OK_RETURN(status=1)
  23073. ! pointer to variable structure if possible:
  23074. if ( varid /= MDF_GLOBAL ) then
  23075. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23076. IF_NOT_OK_RETURN(status=1)
  23077. end if
  23078. ! select appropriate routine for each type:
  23079. select case ( ftype )
  23080. #ifdef with_hdf4
  23081. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23082. case ( MDF_HDF4 )
  23083. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23084. ! set variable id:
  23085. if ( varid == MDF_GLOBAL ) then
  23086. hdf4_id = filep%hdf4_id
  23087. else
  23088. hdf4_id = varp%hdf4_sdid
  23089. end if
  23090. ! get attribute index given name:
  23091. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  23092. if ( hdf4_iatt == FAIL ) then
  23093. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  23094. TRACEBACK; status=1; return
  23095. end if
  23096. ! get type and length:
  23097. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  23098. if ( status /= SUCCEED ) then
  23099. write (gol,'("getting attribute info")') trim(name); call goErr
  23100. TRACEBACK; status=1; return
  23101. end if
  23102. ! read numerical attribute:
  23103. select case ( hdf4_xtype )
  23104. case ( DFNT_INT8 )
  23105. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  23106. values = int(values_int1,kind=4)
  23107. case ( DFNT_INT16 )
  23108. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  23109. values = int(values_int2,kind=4)
  23110. case ( DFNT_INT32 )
  23111. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  23112. values = int(values_int4,kind=4)
  23113. case ( DFNT_INT64 )
  23114. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  23115. values = int(values_int8,kind=4)
  23116. case ( DFNT_FLOAT32 )
  23117. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  23118. values = int(values_real4,kind=4)
  23119. case ( DFNT_FLOAT64 )
  23120. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  23121. values = int(values_real8,kind=4)
  23122. case default
  23123. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  23124. TRACEBACK; status=1; return
  23125. end select
  23126. if ( status /= SUCCEED ) then
  23127. write (*,'("reading attribute : ",a)') trim(name); call goErr
  23128. TRACEBACK; status=1; return
  23129. end if
  23130. #endif
  23131. #ifdef with_hdf5_beta
  23132. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23133. case ( MDF_HDF5 )
  23134. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23135. ! set variable id:
  23136. if ( varid == MDF_GLOBAL ) then
  23137. ! file id:
  23138. hdf5_loc_id = filep%hdf5_file_id
  23139. hdf5_obj_name = '.'
  23140. else
  23141. ! file id:
  23142. hdf5_loc_id = varp%hdf5_dataset_id
  23143. hdf5_obj_name = '.'
  23144. end if
  23145. ! data type:
  23146. call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status )
  23147. IF_NOT_OK_RETURN(status=1)
  23148. ! open attribute:
  23149. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  23150. IF_NOT_OK_RETURN(status=1)
  23151. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  23152. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status )
  23153. IF_NOT_OK_RETURN(status=1)
  23154. ! convert:
  23155. values = int(hdf5_values_int4,4)
  23156. ! release:
  23157. call H5TClose_f( hdf5_type_id, status )
  23158. IF_NOT_OK_RETURN(status=1)
  23159. ! release:
  23160. call H5AClose_f( hdf5_attr_id, status )
  23161. IF_NOT_OK_RETURN(status=1)
  23162. #endif
  23163. #ifdef with_netcdf
  23164. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23165. case ( MDF_NETCDF, MDF_NETCDF4 )
  23166. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23167. ! set variable id:
  23168. if ( varid == MDF_GLOBAL ) then
  23169. netcdf_varid = NF90_GLOBAL
  23170. else
  23171. netcdf_varid = varp%netcdf_varid
  23172. end if
  23173. ! read attribute:
  23174. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23175. IF_NF90_NOT_OK_RETURN(status=1)
  23176. #endif
  23177. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23178. case default
  23179. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23180. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23181. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23182. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23183. TRACEBACK; status=1; return
  23184. end select
  23185. ! ok
  23186. status = 0
  23187. end subroutine MDF_Get_Att_i4_0d
  23188. subroutine MDF_Put_Att_i4_1d( hid, varid, name, values, status )
  23189. #ifdef with_hdf5_beta
  23190. use HDF5, only : HID_T, HSIZE_T
  23191. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23192. use HDF5, only : H5T_NATIVE_CHARACTER
  23193. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  23194. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23195. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  23196. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  23197. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  23198. #endif
  23199. #ifdef with_netcdf
  23200. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  23201. #endif
  23202. ! --- in/out -------------------------------------
  23203. integer, intent(in) :: hid
  23204. integer, intent(in) :: varid
  23205. character(len=*), intent(in) :: name
  23206. integer(4), intent(in) :: values(:)
  23207. integer, intent(out) :: status
  23208. ! --- const --------------------------------------
  23209. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i4_1d'
  23210. ! --- external -------------------------------
  23211. #ifdef with_hdf4
  23212. integer(hdf4_wpi), external :: sfSCAtt
  23213. integer(hdf4_wpi), external :: sfSNAtt
  23214. #endif
  23215. ! --- local --------------------------------------
  23216. type(MDF_File), pointer :: filep
  23217. type(MDF_Var), pointer :: varp
  23218. integer :: iftype
  23219. integer :: ftype
  23220. #ifdef with_hdf4
  23221. integer :: hdf4_id
  23222. #endif
  23223. #ifdef with_hdf5_beta
  23224. integer(HID_T) :: hdf5_loc_id
  23225. integer(HID_T) :: hdf5_attr_id
  23226. integer(HID_T) :: hdf5_space_id
  23227. integer(HID_T) :: hdf5_type_id
  23228. #endif
  23229. #ifdef with_netcdf
  23230. integer :: netcdf_varid
  23231. #endif
  23232. ! --- begin --------------------------------------
  23233. ! pointer to file structure:
  23234. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23235. IF_NOT_OK_RETURN(status=1)
  23236. ! global or variable attribute ?
  23237. if ( varid == MDF_GLOBAL ) then
  23238. ! increase counter:
  23239. filep%natt = filep%natt + 1
  23240. else
  23241. ! pointer to variable structure:
  23242. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23243. IF_NOT_OK_RETURN(status=1)
  23244. ! increase counter:
  23245. varp%natt = varp%natt + 1
  23246. end if
  23247. ! loop over file types:
  23248. do iftype = 1, filep%nftype
  23249. ! current type:
  23250. ftype = filep%ftypes(iftype)
  23251. ! select appropriate routine for each type:
  23252. select case ( ftype )
  23253. #ifdef with_hdf4
  23254. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23255. case ( MDF_HDF4 )
  23256. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23257. ! set variable id:
  23258. if ( varid == MDF_GLOBAL ) then
  23259. hdf4_id = filep%hdf4_id
  23260. else
  23261. hdf4_id = varp%hdf4_sdid
  23262. end if
  23263. ! strore numerical attribute:
  23264. status = sfSNAtt( hdf4_id, trim(name), DFNT_INT32, size(values), values )
  23265. if ( status /= SUCCEED ) then
  23266. write (*,'("writing attribute : ",a)') trim(name); call goErr
  23267. TRACEBACK; status=1; return
  23268. end if
  23269. #endif
  23270. #ifdef with_hdf5_beta
  23271. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23272. case ( MDF_HDF5 )
  23273. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23274. ! set variable id:
  23275. if ( varid == MDF_GLOBAL ) then
  23276. hdf5_loc_id = filep%hdf5_file_id
  23277. else
  23278. hdf5_loc_id = varp%hdf5_dataset_id
  23279. end if
  23280. ! data type:
  23281. call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status )
  23282. IF_NOT_OK_RETURN(status=1)
  23283. ! data space:
  23284. call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status )
  23285. IF_NOT_OK_RETURN(status=1)
  23286. ! set extent of the data space:
  23287. call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status )
  23288. IF_NOT_OK_RETURN(status=1)
  23289. ! create attribute; type in file is same as type provided to this routine:
  23290. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  23291. IF_NOT_OK_RETURN(status=1)
  23292. ! write attribute values:
  23293. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status )
  23294. IF_NOT_OK_RETURN(status=1)
  23295. ! release attribute:
  23296. call H5AClose_f( hdf5_attr_id, status )
  23297. IF_NOT_OK_RETURN(status=1)
  23298. ! release data space:
  23299. call H5SClose_f( hdf5_space_id, status )
  23300. IF_NOT_OK_RETURN(status=1)
  23301. ! release data type:
  23302. call H5TClose_f( hdf5_type_id, status )
  23303. IF_NOT_OK_RETURN(status=1)
  23304. #endif
  23305. #ifdef with_netcdf
  23306. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23307. case ( MDF_NETCDF, MDF_NETCDF4 )
  23308. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23309. ! set variable id:
  23310. if ( varid == MDF_GLOBAL ) then
  23311. netcdf_varid = NF90_GLOBAL
  23312. else
  23313. netcdf_varid = varp%netcdf_varid
  23314. end if
  23315. ! write attribute:
  23316. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23317. IF_NF90_NOT_OK_RETURN(status=1)
  23318. #endif
  23319. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23320. case default
  23321. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23322. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23323. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23324. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23325. TRACEBACK; status=1; return
  23326. end select
  23327. end do ! file types
  23328. ! ok
  23329. status = 0
  23330. end subroutine MDF_Put_Att_i4_1d
  23331. ! ***
  23332. subroutine MDF_Get_Att_i4_1d( hid, varid, name, values, status )
  23333. #ifdef with_hdf5_beta
  23334. use HDF5, only : HSIZE_T
  23335. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  23336. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23337. use HDF5, only : H5T_NATIVE_CHARACTER
  23338. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  23339. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23340. #endif
  23341. #ifdef with_netcdf
  23342. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  23343. #endif
  23344. ! --- in/out -------------------------------------
  23345. integer, intent(in) :: hid
  23346. integer, intent(in) :: varid
  23347. character(len=*), intent(in) :: name
  23348. integer(4), intent(out) :: values(:)
  23349. integer, intent(out) :: status
  23350. ! --- const --------------------------------------
  23351. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i4_1d'
  23352. ! --- external -------------------------------
  23353. #ifdef with_hdf4
  23354. integer(hdf4_wpi), external :: sfFAttr
  23355. integer(hdf4_wpi), external :: sfGAInfo
  23356. integer(hdf4_wpi), external :: sfRCAtt
  23357. integer(hdf4_wpi), external :: sfRNAtt
  23358. #endif
  23359. ! --- local --------------------------------------
  23360. type(MDF_File), pointer :: filep
  23361. type(MDF_Var), pointer :: varp
  23362. integer :: ftype
  23363. #ifdef with_hdf4
  23364. integer :: hdf4_id
  23365. integer :: hdf4_iatt
  23366. character(len=LEN_NAME) :: hdf4_name
  23367. integer :: hdf4_xtype
  23368. integer :: hdf4_length
  23369. integer(1), allocatable :: values_int1(:)
  23370. integer(2), allocatable :: values_int2(:)
  23371. integer(4), allocatable :: values_int4(:)
  23372. integer(8), allocatable :: values_int8(:)
  23373. real(4), allocatable :: values_real4(:)
  23374. real(8), allocatable :: values_real8(:)
  23375. #endif
  23376. #ifdef with_hdf5_beta
  23377. integer(HID_T) :: hdf5_loc_id
  23378. character(len=LEN_NAME) :: hdf5_obj_name
  23379. integer(HID_T) :: hdf5_attr_id
  23380. integer(HID_T) :: hdf5_type_id
  23381. integer(4), allocatable :: hdf5_values_int4(:)
  23382. #endif
  23383. #ifdef with_netcdf
  23384. integer :: netcdf_varid
  23385. #endif
  23386. ! --- begin --------------------------------------
  23387. ! single type:
  23388. call MDF_Get_Type( hid, ftype, status )
  23389. IF_NOT_OK_RETURN(status=1)
  23390. ! pointer to file structure:
  23391. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23392. IF_NOT_OK_RETURN(status=1)
  23393. ! pointer to variable structure if possible:
  23394. if ( varid /= MDF_GLOBAL ) then
  23395. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23396. IF_NOT_OK_RETURN(status=1)
  23397. end if
  23398. ! select appropriate routine for each type:
  23399. select case ( ftype )
  23400. #ifdef with_hdf4
  23401. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23402. case ( MDF_HDF4 )
  23403. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23404. ! set variable id:
  23405. if ( varid == MDF_GLOBAL ) then
  23406. hdf4_id = filep%hdf4_id
  23407. else
  23408. hdf4_id = varp%hdf4_sdid
  23409. end if
  23410. ! get attribute index given name:
  23411. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  23412. if ( hdf4_iatt == FAIL ) then
  23413. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  23414. TRACEBACK; status=1; return
  23415. end if
  23416. ! get type and length:
  23417. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  23418. if ( status /= SUCCEED ) then
  23419. write (gol,'("getting attribute info")') trim(name); call goErr
  23420. TRACEBACK; status=1; return
  23421. end if
  23422. ! read numerical attribute:
  23423. select case ( hdf4_xtype )
  23424. case ( DFNT_INT8 )
  23425. allocate( values_int1(hdf4_length) )
  23426. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  23427. values = int(values_int1,kind=4)
  23428. deallocate( values_int1 )
  23429. case ( DFNT_INT16 )
  23430. allocate( values_int2(hdf4_length) )
  23431. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  23432. values = int(values_int2,kind=4)
  23433. deallocate( values_int2 )
  23434. case ( DFNT_INT32 )
  23435. allocate( values_int4(hdf4_length) )
  23436. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  23437. values = int(values_int4,kind=4)
  23438. deallocate( values_int4 )
  23439. case ( DFNT_INT64 )
  23440. allocate( values_int8(hdf4_length) )
  23441. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  23442. values = int(values_int8,kind=4)
  23443. deallocate( values_int8 )
  23444. case ( DFNT_FLOAT32 )
  23445. allocate( values_real4(hdf4_length) )
  23446. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  23447. values = int(values_real4,kind=4)
  23448. deallocate( values_real4 )
  23449. case ( DFNT_FLOAT64 )
  23450. allocate( values_real8(hdf4_length) )
  23451. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  23452. values = int(values_real8,kind=4)
  23453. deallocate( values_real8 )
  23454. case default
  23455. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  23456. TRACEBACK; status=1; return
  23457. end select
  23458. if ( status /= SUCCEED ) then
  23459. write (*,'("reading attribute : ",a)') trim(name); call goErr
  23460. TRACEBACK; status=1; return
  23461. end if
  23462. #endif
  23463. #ifdef with_hdf5_beta
  23464. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23465. case ( MDF_HDF5 )
  23466. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23467. ! set variable id:
  23468. if ( varid == MDF_GLOBAL ) then
  23469. ! file id:
  23470. hdf5_loc_id = filep%hdf5_file_id
  23471. hdf5_obj_name = '.'
  23472. else
  23473. ! file id:
  23474. hdf5_loc_id = varp%hdf5_dataset_id
  23475. hdf5_obj_name = '.'
  23476. end if
  23477. ! data type:
  23478. call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status )
  23479. IF_NOT_OK_RETURN(status=1)
  23480. ! open attribute:
  23481. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  23482. IF_NOT_OK_RETURN(status=1)
  23483. ! storage:
  23484. allocate( hdf5_values_int4(size(values)) )
  23485. ! read into integer(4), since no specific routines for kinds 1 and 2 seem available::
  23486. call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status )
  23487. IF_NOT_OK_RETURN(status=1)
  23488. ! convert:
  23489. values = int(hdf5_values_int4,4)
  23490. ! clear:
  23491. deallocate( hdf5_values_int4 )
  23492. ! release:
  23493. call H5TClose_f( hdf5_type_id, status )
  23494. IF_NOT_OK_RETURN(status=1)
  23495. ! release:
  23496. call H5AClose_f( hdf5_attr_id, status )
  23497. IF_NOT_OK_RETURN(status=1)
  23498. #endif
  23499. #ifdef with_netcdf
  23500. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23501. case ( MDF_NETCDF, MDF_NETCDF4 )
  23502. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23503. ! set variable id:
  23504. if ( varid == MDF_GLOBAL ) then
  23505. netcdf_varid = NF90_GLOBAL
  23506. else
  23507. netcdf_varid = varp%netcdf_varid
  23508. end if
  23509. ! read attribute:
  23510. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23511. IF_NF90_NOT_OK_RETURN(status=1)
  23512. #endif
  23513. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23514. case default
  23515. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23516. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23517. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23518. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23519. TRACEBACK; status=1; return
  23520. end select
  23521. ! ok
  23522. status = 0
  23523. end subroutine MDF_Get_Att_i4_1d
  23524. subroutine MDF_Put_Att_r4_0d( hid, varid, name, values, status )
  23525. #ifdef with_hdf5_beta
  23526. use HDF5, only : HID_T, HSIZE_T
  23527. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23528. use HDF5, only : H5T_NATIVE_CHARACTER
  23529. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  23530. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23531. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  23532. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  23533. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  23534. #endif
  23535. #ifdef with_netcdf
  23536. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  23537. #endif
  23538. ! --- in/out -------------------------------------
  23539. integer, intent(in) :: hid
  23540. integer, intent(in) :: varid
  23541. character(len=*), intent(in) :: name
  23542. real(4), intent(in) :: values
  23543. integer, intent(out) :: status
  23544. ! --- const --------------------------------------
  23545. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r4_0d'
  23546. ! --- external -------------------------------
  23547. #ifdef with_hdf4
  23548. integer(hdf4_wpi), external :: sfSCAtt
  23549. integer(hdf4_wpi), external :: sfSNAtt
  23550. #endif
  23551. ! --- local --------------------------------------
  23552. type(MDF_File), pointer :: filep
  23553. type(MDF_Var), pointer :: varp
  23554. integer :: iftype
  23555. integer :: ftype
  23556. #ifdef with_hdf4
  23557. integer :: hdf4_id
  23558. #endif
  23559. #ifdef with_hdf5_beta
  23560. integer(HID_T) :: hdf5_loc_id
  23561. integer(HID_T) :: hdf5_attr_id
  23562. integer(HID_T) :: hdf5_space_id
  23563. integer(HID_T) :: hdf5_type_id
  23564. #endif
  23565. #ifdef with_netcdf
  23566. integer :: netcdf_varid
  23567. #endif
  23568. ! --- begin --------------------------------------
  23569. ! pointer to file structure:
  23570. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23571. IF_NOT_OK_RETURN(status=1)
  23572. ! global or variable attribute ?
  23573. if ( varid == MDF_GLOBAL ) then
  23574. ! increase counter:
  23575. filep%natt = filep%natt + 1
  23576. else
  23577. ! pointer to variable structure:
  23578. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23579. IF_NOT_OK_RETURN(status=1)
  23580. ! increase counter:
  23581. varp%natt = varp%natt + 1
  23582. end if
  23583. ! loop over file types:
  23584. do iftype = 1, filep%nftype
  23585. ! current type:
  23586. ftype = filep%ftypes(iftype)
  23587. ! select appropriate routine for each type:
  23588. select case ( ftype )
  23589. #ifdef with_hdf4
  23590. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23591. case ( MDF_HDF4 )
  23592. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23593. ! set variable id:
  23594. if ( varid == MDF_GLOBAL ) then
  23595. hdf4_id = filep%hdf4_id
  23596. else
  23597. hdf4_id = varp%hdf4_sdid
  23598. end if
  23599. ! store numerical attribute:
  23600. status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT32, 1, values )
  23601. if ( status /= SUCCEED ) then
  23602. write (*,'("writing attribute : ",a)') trim(name); call goErr
  23603. TRACEBACK; status=1; return
  23604. end if
  23605. #endif
  23606. #ifdef with_hdf5_beta
  23607. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23608. case ( MDF_HDF5 )
  23609. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23610. ! set variable id:
  23611. if ( varid == MDF_GLOBAL ) then
  23612. hdf5_loc_id = filep%hdf5_file_id
  23613. else
  23614. hdf5_loc_id = varp%hdf5_dataset_id
  23615. end if
  23616. ! data type:
  23617. call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status )
  23618. IF_NOT_OK_RETURN(status=1)
  23619. ! data space:
  23620. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  23621. IF_NOT_OK_RETURN(status=1)
  23622. ! create attribute; type in file is same as type provided to this routine:
  23623. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  23624. IF_NOT_OK_RETURN(status=1)
  23625. ! write attribute values:
  23626. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_REAL, values, int((/1/),kind=HSIZE_T), status )
  23627. IF_NOT_OK_RETURN(status=1)
  23628. ! release attribute:
  23629. call H5AClose_f( hdf5_attr_id, status )
  23630. IF_NOT_OK_RETURN(status=1)
  23631. ! release data space:
  23632. call H5SClose_f( hdf5_space_id, status )
  23633. IF_NOT_OK_RETURN(status=1)
  23634. ! release data type:
  23635. call H5TClose_f( hdf5_type_id, status )
  23636. IF_NOT_OK_RETURN(status=1)
  23637. #endif
  23638. #ifdef with_netcdf
  23639. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23640. case ( MDF_NETCDF, MDF_NETCDF4 )
  23641. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23642. ! set variable id:
  23643. if ( varid == MDF_GLOBAL ) then
  23644. netcdf_varid = NF90_GLOBAL
  23645. else
  23646. netcdf_varid = varp%netcdf_varid
  23647. end if
  23648. ! write attribute:
  23649. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23650. IF_NF90_NOT_OK_RETURN(status=1)
  23651. #endif
  23652. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23653. case default
  23654. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23655. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23656. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23657. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23658. TRACEBACK; status=1; return
  23659. end select
  23660. end do ! file types
  23661. ! ok
  23662. status = 0
  23663. end subroutine MDF_Put_Att_r4_0d
  23664. ! ***
  23665. subroutine MDF_Get_Att_r4_0d( hid, varid, name, values, status )
  23666. #ifdef with_hdf5_beta
  23667. use HDF5, only : HSIZE_T
  23668. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  23669. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23670. use HDF5, only : H5T_NATIVE_CHARACTER
  23671. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  23672. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23673. #endif
  23674. #ifdef with_netcdf
  23675. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  23676. #endif
  23677. ! --- in/out -------------------------------------
  23678. integer, intent(in) :: hid
  23679. integer, intent(in) :: varid
  23680. character(len=*), intent(in) :: name
  23681. real(4), intent(out) :: values
  23682. integer, intent(out) :: status
  23683. ! --- const --------------------------------------
  23684. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r4_0d'
  23685. ! --- external -------------------------------
  23686. #ifdef with_hdf4
  23687. integer(hdf4_wpi), external :: sfFAttr
  23688. integer(hdf4_wpi), external :: sfGAInfo
  23689. integer(hdf4_wpi), external :: sfRCAtt
  23690. integer(hdf4_wpi), external :: sfRNAtt
  23691. #endif
  23692. ! --- local --------------------------------------
  23693. type(MDF_File), pointer :: filep
  23694. type(MDF_Var), pointer :: varp
  23695. integer :: ftype
  23696. #ifdef with_hdf4
  23697. integer :: hdf4_id
  23698. integer :: hdf4_iatt
  23699. character(len=LEN_NAME) :: hdf4_name
  23700. integer :: hdf4_xtype
  23701. integer :: hdf4_length
  23702. integer(1) :: values_int1
  23703. integer(2) :: values_int2
  23704. integer(4) :: values_int4
  23705. integer(8) :: values_int8
  23706. real(4) :: values_real4
  23707. real(8) :: values_real8
  23708. #endif
  23709. #ifdef with_hdf5_beta
  23710. integer(HID_T) :: hdf5_loc_id
  23711. character(len=LEN_NAME) :: hdf5_obj_name
  23712. integer(HID_T) :: hdf5_attr_id
  23713. integer(HID_T) :: hdf5_type_id
  23714. #endif
  23715. #ifdef with_netcdf
  23716. integer :: netcdf_varid
  23717. #endif
  23718. ! --- begin --------------------------------------
  23719. ! single type:
  23720. call MDF_Get_Type( hid, ftype, status )
  23721. IF_NOT_OK_RETURN(status=1)
  23722. ! pointer to file structure:
  23723. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23724. IF_NOT_OK_RETURN(status=1)
  23725. ! pointer to variable structure if possible:
  23726. if ( varid /= MDF_GLOBAL ) then
  23727. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23728. IF_NOT_OK_RETURN(status=1)
  23729. end if
  23730. ! select appropriate routine for each type:
  23731. select case ( ftype )
  23732. #ifdef with_hdf4
  23733. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23734. case ( MDF_HDF4 )
  23735. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23736. ! set variable id:
  23737. if ( varid == MDF_GLOBAL ) then
  23738. hdf4_id = filep%hdf4_id
  23739. else
  23740. hdf4_id = varp%hdf4_sdid
  23741. end if
  23742. ! get attribute index given name:
  23743. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  23744. if ( hdf4_iatt == FAIL ) then
  23745. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  23746. TRACEBACK; status=1; return
  23747. end if
  23748. ! get type and length:
  23749. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  23750. if ( status /= SUCCEED ) then
  23751. write (gol,'("getting attribute info")') trim(name); call goErr
  23752. TRACEBACK; status=1; return
  23753. end if
  23754. ! read numerical attribute:
  23755. select case ( hdf4_xtype )
  23756. case ( DFNT_INT8 )
  23757. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  23758. values = real(values_int1,kind=4)
  23759. case ( DFNT_INT16 )
  23760. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  23761. values = real(values_int2,kind=4)
  23762. case ( DFNT_INT32 )
  23763. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  23764. values = real(values_int4,kind=4)
  23765. case ( DFNT_INT64 )
  23766. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  23767. values = real(values_int8,kind=4)
  23768. case ( DFNT_FLOAT32 )
  23769. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  23770. values = real(values_real4,kind=4)
  23771. case ( DFNT_FLOAT64 )
  23772. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  23773. values = real(values_real8,kind=4)
  23774. case default
  23775. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  23776. TRACEBACK; status=1; return
  23777. end select
  23778. if ( status /= SUCCEED ) then
  23779. write (*,'("reading attribute : ",a)') trim(name); call goErr
  23780. TRACEBACK; status=1; return
  23781. end if
  23782. #endif
  23783. #ifdef with_hdf5_beta
  23784. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23785. case ( MDF_HDF5 )
  23786. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23787. ! set variable id:
  23788. if ( varid == MDF_GLOBAL ) then
  23789. ! file id:
  23790. hdf5_loc_id = filep%hdf5_file_id
  23791. hdf5_obj_name = '.'
  23792. else
  23793. ! file id:
  23794. hdf5_loc_id = varp%hdf5_dataset_id
  23795. hdf5_obj_name = '.'
  23796. end if
  23797. ! data type:
  23798. call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status )
  23799. IF_NOT_OK_RETURN(status=1)
  23800. ! open attribute:
  23801. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  23802. IF_NOT_OK_RETURN(status=1)
  23803. ! read:
  23804. call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/1/),HSIZE_T), status )
  23805. IF_NOT_OK_RETURN(status=1)
  23806. ! release:
  23807. call H5TClose_f( hdf5_type_id, status )
  23808. IF_NOT_OK_RETURN(status=1)
  23809. ! release:
  23810. call H5AClose_f( hdf5_attr_id, status )
  23811. IF_NOT_OK_RETURN(status=1)
  23812. #endif
  23813. #ifdef with_netcdf
  23814. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23815. case ( MDF_NETCDF, MDF_NETCDF4 )
  23816. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23817. ! set variable id:
  23818. if ( varid == MDF_GLOBAL ) then
  23819. netcdf_varid = NF90_GLOBAL
  23820. else
  23821. netcdf_varid = varp%netcdf_varid
  23822. end if
  23823. ! read attribute:
  23824. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23825. IF_NF90_NOT_OK_RETURN(status=1)
  23826. #endif
  23827. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23828. case default
  23829. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23830. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23831. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23832. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23833. TRACEBACK; status=1; return
  23834. end select
  23835. ! ok
  23836. status = 0
  23837. end subroutine MDF_Get_Att_r4_0d
  23838. subroutine MDF_Put_Att_r4_1d( hid, varid, name, values, status )
  23839. #ifdef with_hdf5_beta
  23840. use HDF5, only : HID_T, HSIZE_T
  23841. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23842. use HDF5, only : H5T_NATIVE_CHARACTER
  23843. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  23844. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23845. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  23846. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  23847. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  23848. #endif
  23849. #ifdef with_netcdf
  23850. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  23851. #endif
  23852. ! --- in/out -------------------------------------
  23853. integer, intent(in) :: hid
  23854. integer, intent(in) :: varid
  23855. character(len=*), intent(in) :: name
  23856. real(4), intent(in) :: values(:)
  23857. integer, intent(out) :: status
  23858. ! --- const --------------------------------------
  23859. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r4_1d'
  23860. ! --- external -------------------------------
  23861. #ifdef with_hdf4
  23862. integer(hdf4_wpi), external :: sfSCAtt
  23863. integer(hdf4_wpi), external :: sfSNAtt
  23864. #endif
  23865. ! --- local --------------------------------------
  23866. type(MDF_File), pointer :: filep
  23867. type(MDF_Var), pointer :: varp
  23868. integer :: iftype
  23869. integer :: ftype
  23870. #ifdef with_hdf4
  23871. integer :: hdf4_id
  23872. #endif
  23873. #ifdef with_hdf5_beta
  23874. integer(HID_T) :: hdf5_loc_id
  23875. integer(HID_T) :: hdf5_attr_id
  23876. integer(HID_T) :: hdf5_space_id
  23877. integer(HID_T) :: hdf5_type_id
  23878. #endif
  23879. #ifdef with_netcdf
  23880. integer :: netcdf_varid
  23881. #endif
  23882. ! --- begin --------------------------------------
  23883. ! pointer to file structure:
  23884. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  23885. IF_NOT_OK_RETURN(status=1)
  23886. ! global or variable attribute ?
  23887. if ( varid == MDF_GLOBAL ) then
  23888. ! increase counter:
  23889. filep%natt = filep%natt + 1
  23890. else
  23891. ! pointer to variable structure:
  23892. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  23893. IF_NOT_OK_RETURN(status=1)
  23894. ! increase counter:
  23895. varp%natt = varp%natt + 1
  23896. end if
  23897. ! loop over file types:
  23898. do iftype = 1, filep%nftype
  23899. ! current type:
  23900. ftype = filep%ftypes(iftype)
  23901. ! select appropriate routine for each type:
  23902. select case ( ftype )
  23903. #ifdef with_hdf4
  23904. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23905. case ( MDF_HDF4 )
  23906. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23907. ! set variable id:
  23908. if ( varid == MDF_GLOBAL ) then
  23909. hdf4_id = filep%hdf4_id
  23910. else
  23911. hdf4_id = varp%hdf4_sdid
  23912. end if
  23913. ! strore numerical attribute:
  23914. status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT32, size(values), values )
  23915. if ( status /= SUCCEED ) then
  23916. write (*,'("writing attribute : ",a)') trim(name); call goErr
  23917. TRACEBACK; status=1; return
  23918. end if
  23919. #endif
  23920. #ifdef with_hdf5_beta
  23921. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23922. case ( MDF_HDF5 )
  23923. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23924. ! set variable id:
  23925. if ( varid == MDF_GLOBAL ) then
  23926. hdf5_loc_id = filep%hdf5_file_id
  23927. else
  23928. hdf5_loc_id = varp%hdf5_dataset_id
  23929. end if
  23930. ! data type:
  23931. call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status )
  23932. IF_NOT_OK_RETURN(status=1)
  23933. ! data space:
  23934. call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status )
  23935. IF_NOT_OK_RETURN(status=1)
  23936. ! set extent of the data space:
  23937. call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status )
  23938. IF_NOT_OK_RETURN(status=1)
  23939. ! create attribute; type in file is same as type provided to this routine:
  23940. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  23941. IF_NOT_OK_RETURN(status=1)
  23942. ! write attribute values:
  23943. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_REAL, values, int(shape(values),kind=HSIZE_T), status )
  23944. IF_NOT_OK_RETURN(status=1)
  23945. ! release attribute:
  23946. call H5AClose_f( hdf5_attr_id, status )
  23947. IF_NOT_OK_RETURN(status=1)
  23948. ! release data space:
  23949. call H5SClose_f( hdf5_space_id, status )
  23950. IF_NOT_OK_RETURN(status=1)
  23951. ! release data type:
  23952. call H5TClose_f( hdf5_type_id, status )
  23953. IF_NOT_OK_RETURN(status=1)
  23954. #endif
  23955. #ifdef with_netcdf
  23956. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23957. case ( MDF_NETCDF, MDF_NETCDF4 )
  23958. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23959. ! set variable id:
  23960. if ( varid == MDF_GLOBAL ) then
  23961. netcdf_varid = NF90_GLOBAL
  23962. else
  23963. netcdf_varid = varp%netcdf_varid
  23964. end if
  23965. ! write attribute:
  23966. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  23967. IF_NF90_NOT_OK_RETURN(status=1)
  23968. #endif
  23969. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23970. case default
  23971. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  23972. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  23973. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  23974. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  23975. TRACEBACK; status=1; return
  23976. end select
  23977. end do ! file types
  23978. ! ok
  23979. status = 0
  23980. end subroutine MDF_Put_Att_r4_1d
  23981. ! ***
  23982. subroutine MDF_Get_Att_r4_1d( hid, varid, name, values, status )
  23983. #ifdef with_hdf5_beta
  23984. use HDF5, only : HSIZE_T
  23985. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  23986. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  23987. use HDF5, only : H5T_NATIVE_CHARACTER
  23988. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  23989. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  23990. #endif
  23991. #ifdef with_netcdf
  23992. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  23993. #endif
  23994. ! --- in/out -------------------------------------
  23995. integer, intent(in) :: hid
  23996. integer, intent(in) :: varid
  23997. character(len=*), intent(in) :: name
  23998. real(4), intent(out) :: values(:)
  23999. integer, intent(out) :: status
  24000. ! --- const --------------------------------------
  24001. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r4_1d'
  24002. ! --- external -------------------------------
  24003. #ifdef with_hdf4
  24004. integer(hdf4_wpi), external :: sfFAttr
  24005. integer(hdf4_wpi), external :: sfGAInfo
  24006. integer(hdf4_wpi), external :: sfRCAtt
  24007. integer(hdf4_wpi), external :: sfRNAtt
  24008. #endif
  24009. ! --- local --------------------------------------
  24010. type(MDF_File), pointer :: filep
  24011. type(MDF_Var), pointer :: varp
  24012. integer :: ftype
  24013. #ifdef with_hdf4
  24014. integer :: hdf4_id
  24015. integer :: hdf4_iatt
  24016. character(len=LEN_NAME) :: hdf4_name
  24017. integer :: hdf4_xtype
  24018. integer :: hdf4_length
  24019. integer(1), allocatable :: values_int1(:)
  24020. integer(2), allocatable :: values_int2(:)
  24021. integer(4), allocatable :: values_int4(:)
  24022. integer(8), allocatable :: values_int8(:)
  24023. real(4), allocatable :: values_real4(:)
  24024. real(8), allocatable :: values_real8(:)
  24025. #endif
  24026. #ifdef with_hdf5_beta
  24027. integer(HID_T) :: hdf5_loc_id
  24028. character(len=LEN_NAME) :: hdf5_obj_name
  24029. integer(HID_T) :: hdf5_attr_id
  24030. integer(HID_T) :: hdf5_type_id
  24031. #endif
  24032. #ifdef with_netcdf
  24033. integer :: netcdf_varid
  24034. #endif
  24035. ! --- begin --------------------------------------
  24036. ! single type:
  24037. call MDF_Get_Type( hid, ftype, status )
  24038. IF_NOT_OK_RETURN(status=1)
  24039. ! pointer to file structure:
  24040. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24041. IF_NOT_OK_RETURN(status=1)
  24042. ! pointer to variable structure if possible:
  24043. if ( varid /= MDF_GLOBAL ) then
  24044. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  24045. IF_NOT_OK_RETURN(status=1)
  24046. end if
  24047. ! select appropriate routine for each type:
  24048. select case ( ftype )
  24049. #ifdef with_hdf4
  24050. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24051. case ( MDF_HDF4 )
  24052. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24053. ! set variable id:
  24054. if ( varid == MDF_GLOBAL ) then
  24055. hdf4_id = filep%hdf4_id
  24056. else
  24057. hdf4_id = varp%hdf4_sdid
  24058. end if
  24059. ! get attribute index given name:
  24060. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  24061. if ( hdf4_iatt == FAIL ) then
  24062. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  24063. TRACEBACK; status=1; return
  24064. end if
  24065. ! get type and length:
  24066. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  24067. if ( status /= SUCCEED ) then
  24068. write (gol,'("getting attribute info")') trim(name); call goErr
  24069. TRACEBACK; status=1; return
  24070. end if
  24071. ! read numerical attribute:
  24072. select case ( hdf4_xtype )
  24073. case ( DFNT_INT8 )
  24074. allocate( values_int1(hdf4_length) )
  24075. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  24076. values = real(values_int1,kind=4)
  24077. deallocate( values_int1 )
  24078. case ( DFNT_INT16 )
  24079. allocate( values_int2(hdf4_length) )
  24080. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  24081. values = real(values_int2,kind=4)
  24082. deallocate( values_int2 )
  24083. case ( DFNT_INT32 )
  24084. allocate( values_int4(hdf4_length) )
  24085. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  24086. values = real(values_int4,kind=4)
  24087. deallocate( values_int4 )
  24088. case ( DFNT_INT64 )
  24089. allocate( values_int8(hdf4_length) )
  24090. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  24091. values = real(values_int8,kind=4)
  24092. deallocate( values_int8 )
  24093. case ( DFNT_FLOAT32 )
  24094. allocate( values_real4(hdf4_length) )
  24095. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  24096. values = real(values_real4,kind=4)
  24097. deallocate( values_real4 )
  24098. case ( DFNT_FLOAT64 )
  24099. allocate( values_real8(hdf4_length) )
  24100. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  24101. values = real(values_real8,kind=4)
  24102. deallocate( values_real8 )
  24103. case default
  24104. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  24105. TRACEBACK; status=1; return
  24106. end select
  24107. if ( status /= SUCCEED ) then
  24108. write (*,'("reading attribute : ",a)') trim(name); call goErr
  24109. TRACEBACK; status=1; return
  24110. end if
  24111. #endif
  24112. #ifdef with_hdf5_beta
  24113. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24114. case ( MDF_HDF5 )
  24115. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24116. ! set variable id:
  24117. if ( varid == MDF_GLOBAL ) then
  24118. ! file id:
  24119. hdf5_loc_id = filep%hdf5_file_id
  24120. hdf5_obj_name = '.'
  24121. else
  24122. ! file id:
  24123. hdf5_loc_id = varp%hdf5_dataset_id
  24124. hdf5_obj_name = '.'
  24125. end if
  24126. ! data type:
  24127. call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status )
  24128. IF_NOT_OK_RETURN(status=1)
  24129. ! open attribute:
  24130. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  24131. IF_NOT_OK_RETURN(status=1)
  24132. ! read:
  24133. call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int(shape(values),HSIZE_T), status )
  24134. IF_NOT_OK_RETURN(status=1)
  24135. ! release:
  24136. call H5TClose_f( hdf5_type_id, status )
  24137. IF_NOT_OK_RETURN(status=1)
  24138. ! release:
  24139. call H5AClose_f( hdf5_attr_id, status )
  24140. IF_NOT_OK_RETURN(status=1)
  24141. #endif
  24142. #ifdef with_netcdf
  24143. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24144. case ( MDF_NETCDF, MDF_NETCDF4 )
  24145. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24146. ! set variable id:
  24147. if ( varid == MDF_GLOBAL ) then
  24148. netcdf_varid = NF90_GLOBAL
  24149. else
  24150. netcdf_varid = varp%netcdf_varid
  24151. end if
  24152. ! read attribute:
  24153. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  24154. IF_NF90_NOT_OK_RETURN(status=1)
  24155. #endif
  24156. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24157. case default
  24158. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24159. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  24160. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  24161. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  24162. TRACEBACK; status=1; return
  24163. end select
  24164. ! ok
  24165. status = 0
  24166. end subroutine MDF_Get_Att_r4_1d
  24167. subroutine MDF_Put_Att_r8_0d( hid, varid, name, values, status )
  24168. #ifdef with_hdf5_beta
  24169. use HDF5, only : HID_T, HSIZE_T
  24170. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  24171. use HDF5, only : H5T_NATIVE_CHARACTER
  24172. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  24173. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  24174. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  24175. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  24176. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  24177. #endif
  24178. #ifdef with_netcdf
  24179. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  24180. #endif
  24181. ! --- in/out -------------------------------------
  24182. integer, intent(in) :: hid
  24183. integer, intent(in) :: varid
  24184. character(len=*), intent(in) :: name
  24185. real(8), intent(in) :: values
  24186. integer, intent(out) :: status
  24187. ! --- const --------------------------------------
  24188. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r8_0d'
  24189. ! --- external -------------------------------
  24190. #ifdef with_hdf4
  24191. integer(hdf4_wpi), external :: sfSCAtt
  24192. integer(hdf4_wpi), external :: sfSNAtt
  24193. #endif
  24194. ! --- local --------------------------------------
  24195. type(MDF_File), pointer :: filep
  24196. type(MDF_Var), pointer :: varp
  24197. integer :: iftype
  24198. integer :: ftype
  24199. #ifdef with_hdf4
  24200. integer :: hdf4_id
  24201. #endif
  24202. #ifdef with_hdf5_beta
  24203. integer(HID_T) :: hdf5_loc_id
  24204. integer(HID_T) :: hdf5_attr_id
  24205. integer(HID_T) :: hdf5_space_id
  24206. integer(HID_T) :: hdf5_type_id
  24207. #endif
  24208. #ifdef with_netcdf
  24209. integer :: netcdf_varid
  24210. #endif
  24211. ! --- begin --------------------------------------
  24212. ! pointer to file structure:
  24213. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24214. IF_NOT_OK_RETURN(status=1)
  24215. ! global or variable attribute ?
  24216. if ( varid == MDF_GLOBAL ) then
  24217. ! increase counter:
  24218. filep%natt = filep%natt + 1
  24219. else
  24220. ! pointer to variable structure:
  24221. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  24222. IF_NOT_OK_RETURN(status=1)
  24223. ! increase counter:
  24224. varp%natt = varp%natt + 1
  24225. end if
  24226. ! loop over file types:
  24227. do iftype = 1, filep%nftype
  24228. ! current type:
  24229. ftype = filep%ftypes(iftype)
  24230. ! select appropriate routine for each type:
  24231. select case ( ftype )
  24232. #ifdef with_hdf4
  24233. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24234. case ( MDF_HDF4 )
  24235. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24236. ! set variable id:
  24237. if ( varid == MDF_GLOBAL ) then
  24238. hdf4_id = filep%hdf4_id
  24239. else
  24240. hdf4_id = varp%hdf4_sdid
  24241. end if
  24242. ! store numerical attribute:
  24243. status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT64, 1, values )
  24244. if ( status /= SUCCEED ) then
  24245. write (*,'("writing attribute : ",a)') trim(name); call goErr
  24246. TRACEBACK; status=1; return
  24247. end if
  24248. #endif
  24249. #ifdef with_hdf5_beta
  24250. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24251. case ( MDF_HDF5 )
  24252. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24253. ! set variable id:
  24254. if ( varid == MDF_GLOBAL ) then
  24255. hdf5_loc_id = filep%hdf5_file_id
  24256. else
  24257. hdf5_loc_id = varp%hdf5_dataset_id
  24258. end if
  24259. ! data type:
  24260. call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status )
  24261. IF_NOT_OK_RETURN(status=1)
  24262. ! data space:
  24263. call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status )
  24264. IF_NOT_OK_RETURN(status=1)
  24265. ! create attribute; type in file is same as type provided to this routine:
  24266. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  24267. IF_NOT_OK_RETURN(status=1)
  24268. ! write attribute values:
  24269. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_DOUBLE, values, int((/1/),kind=HSIZE_T), status )
  24270. IF_NOT_OK_RETURN(status=1)
  24271. ! release attribute:
  24272. call H5AClose_f( hdf5_attr_id, status )
  24273. IF_NOT_OK_RETURN(status=1)
  24274. ! release data space:
  24275. call H5SClose_f( hdf5_space_id, status )
  24276. IF_NOT_OK_RETURN(status=1)
  24277. ! release data type:
  24278. call H5TClose_f( hdf5_type_id, status )
  24279. IF_NOT_OK_RETURN(status=1)
  24280. #endif
  24281. #ifdef with_netcdf
  24282. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24283. case ( MDF_NETCDF, MDF_NETCDF4 )
  24284. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24285. ! set variable id:
  24286. if ( varid == MDF_GLOBAL ) then
  24287. netcdf_varid = NF90_GLOBAL
  24288. else
  24289. netcdf_varid = varp%netcdf_varid
  24290. end if
  24291. ! write attribute:
  24292. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  24293. IF_NF90_NOT_OK_RETURN(status=1)
  24294. #endif
  24295. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24296. case default
  24297. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24298. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  24299. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  24300. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  24301. TRACEBACK; status=1; return
  24302. end select
  24303. end do ! file types
  24304. ! ok
  24305. status = 0
  24306. end subroutine MDF_Put_Att_r8_0d
  24307. ! ***
  24308. subroutine MDF_Get_Att_r8_0d( hid, varid, name, values, status )
  24309. #ifdef with_hdf5_beta
  24310. use HDF5, only : HSIZE_T
  24311. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  24312. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  24313. use HDF5, only : H5T_NATIVE_CHARACTER
  24314. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  24315. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  24316. #endif
  24317. #ifdef with_netcdf
  24318. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  24319. #endif
  24320. ! --- in/out -------------------------------------
  24321. integer, intent(in) :: hid
  24322. integer, intent(in) :: varid
  24323. character(len=*), intent(in) :: name
  24324. real(8), intent(out) :: values
  24325. integer, intent(out) :: status
  24326. ! --- const --------------------------------------
  24327. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r8_0d'
  24328. ! --- external -------------------------------
  24329. #ifdef with_hdf4
  24330. integer(hdf4_wpi), external :: sfFAttr
  24331. integer(hdf4_wpi), external :: sfGAInfo
  24332. integer(hdf4_wpi), external :: sfRCAtt
  24333. integer(hdf4_wpi), external :: sfRNAtt
  24334. #endif
  24335. ! --- local --------------------------------------
  24336. type(MDF_File), pointer :: filep
  24337. type(MDF_Var), pointer :: varp
  24338. integer :: ftype
  24339. #ifdef with_hdf4
  24340. integer :: hdf4_id
  24341. integer :: hdf4_iatt
  24342. character(len=LEN_NAME) :: hdf4_name
  24343. integer :: hdf4_xtype
  24344. integer :: hdf4_length
  24345. integer(1) :: values_int1
  24346. integer(2) :: values_int2
  24347. integer(4) :: values_int4
  24348. integer(8) :: values_int8
  24349. real(4) :: values_real4
  24350. real(8) :: values_real8
  24351. #endif
  24352. #ifdef with_hdf5_beta
  24353. integer(HID_T) :: hdf5_loc_id
  24354. character(len=LEN_NAME) :: hdf5_obj_name
  24355. integer(HID_T) :: hdf5_attr_id
  24356. integer(HID_T) :: hdf5_type_id
  24357. #endif
  24358. #ifdef with_netcdf
  24359. integer :: netcdf_varid
  24360. #endif
  24361. ! --- begin --------------------------------------
  24362. ! single type:
  24363. call MDF_Get_Type( hid, ftype, status )
  24364. IF_NOT_OK_RETURN(status=1)
  24365. ! pointer to file structure:
  24366. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24367. IF_NOT_OK_RETURN(status=1)
  24368. ! pointer to variable structure if possible:
  24369. if ( varid /= MDF_GLOBAL ) then
  24370. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  24371. IF_NOT_OK_RETURN(status=1)
  24372. end if
  24373. ! select appropriate routine for each type:
  24374. select case ( ftype )
  24375. #ifdef with_hdf4
  24376. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24377. case ( MDF_HDF4 )
  24378. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24379. ! set variable id:
  24380. if ( varid == MDF_GLOBAL ) then
  24381. hdf4_id = filep%hdf4_id
  24382. else
  24383. hdf4_id = varp%hdf4_sdid
  24384. end if
  24385. ! get attribute index given name:
  24386. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  24387. if ( hdf4_iatt == FAIL ) then
  24388. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  24389. TRACEBACK; status=1; return
  24390. end if
  24391. ! get type and length:
  24392. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  24393. if ( status /= SUCCEED ) then
  24394. write (gol,'("getting attribute info")') trim(name); call goErr
  24395. TRACEBACK; status=1; return
  24396. end if
  24397. ! read numerical attribute:
  24398. select case ( hdf4_xtype )
  24399. case ( DFNT_INT8 )
  24400. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  24401. values = real(values_int1,kind=8)
  24402. case ( DFNT_INT16 )
  24403. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  24404. values = real(values_int2,kind=8)
  24405. case ( DFNT_INT32 )
  24406. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  24407. values = real(values_int4,kind=8)
  24408. case ( DFNT_INT64 )
  24409. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  24410. values = real(values_int8,kind=8)
  24411. case ( DFNT_FLOAT32 )
  24412. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  24413. values = real(values_real4,kind=8)
  24414. case ( DFNT_FLOAT64 )
  24415. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  24416. values = real(values_real8,kind=8)
  24417. case default
  24418. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  24419. TRACEBACK; status=1; return
  24420. end select
  24421. if ( status /= SUCCEED ) then
  24422. write (*,'("reading attribute : ",a)') trim(name); call goErr
  24423. TRACEBACK; status=1; return
  24424. end if
  24425. #endif
  24426. #ifdef with_hdf5_beta
  24427. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24428. case ( MDF_HDF5 )
  24429. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24430. ! set variable id:
  24431. if ( varid == MDF_GLOBAL ) then
  24432. ! file id:
  24433. hdf5_loc_id = filep%hdf5_file_id
  24434. hdf5_obj_name = '.'
  24435. else
  24436. ! file id:
  24437. hdf5_loc_id = varp%hdf5_dataset_id
  24438. hdf5_obj_name = '.'
  24439. end if
  24440. ! data type:
  24441. call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status )
  24442. IF_NOT_OK_RETURN(status=1)
  24443. ! open attribute:
  24444. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  24445. IF_NOT_OK_RETURN(status=1)
  24446. ! read:
  24447. call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/1/),HSIZE_T), status )
  24448. IF_NOT_OK_RETURN(status=1)
  24449. ! release:
  24450. call H5TClose_f( hdf5_type_id, status )
  24451. IF_NOT_OK_RETURN(status=1)
  24452. ! release:
  24453. call H5AClose_f( hdf5_attr_id, status )
  24454. IF_NOT_OK_RETURN(status=1)
  24455. #endif
  24456. #ifdef with_netcdf
  24457. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24458. case ( MDF_NETCDF, MDF_NETCDF4 )
  24459. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24460. ! set variable id:
  24461. if ( varid == MDF_GLOBAL ) then
  24462. netcdf_varid = NF90_GLOBAL
  24463. else
  24464. netcdf_varid = varp%netcdf_varid
  24465. end if
  24466. ! read attribute:
  24467. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  24468. IF_NF90_NOT_OK_RETURN(status=1)
  24469. #endif
  24470. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24471. case default
  24472. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24473. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  24474. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  24475. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  24476. TRACEBACK; status=1; return
  24477. end select
  24478. ! ok
  24479. status = 0
  24480. end subroutine MDF_Get_Att_r8_0d
  24481. subroutine MDF_Put_Att_r8_1d( hid, varid, name, values, status )
  24482. #ifdef with_hdf5_beta
  24483. use HDF5, only : HID_T, HSIZE_T
  24484. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  24485. use HDF5, only : H5T_NATIVE_CHARACTER
  24486. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER
  24487. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  24488. use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f
  24489. use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F
  24490. use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f
  24491. #endif
  24492. #ifdef with_netcdf
  24493. use NetCDF, only : NF90_Put_Att, NF90_GLOBAL
  24494. #endif
  24495. ! --- in/out -------------------------------------
  24496. integer, intent(in) :: hid
  24497. integer, intent(in) :: varid
  24498. character(len=*), intent(in) :: name
  24499. real(8), intent(in) :: values(:)
  24500. integer, intent(out) :: status
  24501. ! --- const --------------------------------------
  24502. character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r8_1d'
  24503. ! --- external -------------------------------
  24504. #ifdef with_hdf4
  24505. integer(hdf4_wpi), external :: sfSCAtt
  24506. integer(hdf4_wpi), external :: sfSNAtt
  24507. #endif
  24508. ! --- local --------------------------------------
  24509. type(MDF_File), pointer :: filep
  24510. type(MDF_Var), pointer :: varp
  24511. integer :: iftype
  24512. integer :: ftype
  24513. #ifdef with_hdf4
  24514. integer :: hdf4_id
  24515. #endif
  24516. #ifdef with_hdf5_beta
  24517. integer(HID_T) :: hdf5_loc_id
  24518. integer(HID_T) :: hdf5_attr_id
  24519. integer(HID_T) :: hdf5_space_id
  24520. integer(HID_T) :: hdf5_type_id
  24521. #endif
  24522. #ifdef with_netcdf
  24523. integer :: netcdf_varid
  24524. #endif
  24525. ! --- begin --------------------------------------
  24526. ! pointer to file structure:
  24527. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24528. IF_NOT_OK_RETURN(status=1)
  24529. ! global or variable attribute ?
  24530. if ( varid == MDF_GLOBAL ) then
  24531. ! increase counter:
  24532. filep%natt = filep%natt + 1
  24533. else
  24534. ! pointer to variable structure:
  24535. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  24536. IF_NOT_OK_RETURN(status=1)
  24537. ! increase counter:
  24538. varp%natt = varp%natt + 1
  24539. end if
  24540. ! loop over file types:
  24541. do iftype = 1, filep%nftype
  24542. ! current type:
  24543. ftype = filep%ftypes(iftype)
  24544. ! select appropriate routine for each type:
  24545. select case ( ftype )
  24546. #ifdef with_hdf4
  24547. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24548. case ( MDF_HDF4 )
  24549. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24550. ! set variable id:
  24551. if ( varid == MDF_GLOBAL ) then
  24552. hdf4_id = filep%hdf4_id
  24553. else
  24554. hdf4_id = varp%hdf4_sdid
  24555. end if
  24556. ! strore numerical attribute:
  24557. status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT64, size(values), values )
  24558. if ( status /= SUCCEED ) then
  24559. write (*,'("writing attribute : ",a)') trim(name); call goErr
  24560. TRACEBACK; status=1; return
  24561. end if
  24562. #endif
  24563. #ifdef with_hdf5_beta
  24564. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24565. case ( MDF_HDF5 )
  24566. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24567. ! set variable id:
  24568. if ( varid == MDF_GLOBAL ) then
  24569. hdf5_loc_id = filep%hdf5_file_id
  24570. else
  24571. hdf5_loc_id = varp%hdf5_dataset_id
  24572. end if
  24573. ! data type:
  24574. call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status )
  24575. IF_NOT_OK_RETURN(status=1)
  24576. ! data space:
  24577. call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status )
  24578. IF_NOT_OK_RETURN(status=1)
  24579. ! set extent of the data space:
  24580. call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status )
  24581. IF_NOT_OK_RETURN(status=1)
  24582. ! create attribute; type in file is same as type provided to this routine:
  24583. call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status )
  24584. IF_NOT_OK_RETURN(status=1)
  24585. ! write attribute values:
  24586. call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_DOUBLE, values, int(shape(values),kind=HSIZE_T), status )
  24587. IF_NOT_OK_RETURN(status=1)
  24588. ! release attribute:
  24589. call H5AClose_f( hdf5_attr_id, status )
  24590. IF_NOT_OK_RETURN(status=1)
  24591. ! release data space:
  24592. call H5SClose_f( hdf5_space_id, status )
  24593. IF_NOT_OK_RETURN(status=1)
  24594. ! release data type:
  24595. call H5TClose_f( hdf5_type_id, status )
  24596. IF_NOT_OK_RETURN(status=1)
  24597. #endif
  24598. #ifdef with_netcdf
  24599. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24600. case ( MDF_NETCDF, MDF_NETCDF4 )
  24601. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24602. ! set variable id:
  24603. if ( varid == MDF_GLOBAL ) then
  24604. netcdf_varid = NF90_GLOBAL
  24605. else
  24606. netcdf_varid = varp%netcdf_varid
  24607. end if
  24608. ! write attribute:
  24609. status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  24610. IF_NF90_NOT_OK_RETURN(status=1)
  24611. #endif
  24612. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24613. case default
  24614. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24615. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  24616. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  24617. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  24618. TRACEBACK; status=1; return
  24619. end select
  24620. end do ! file types
  24621. ! ok
  24622. status = 0
  24623. end subroutine MDF_Put_Att_r8_1d
  24624. ! ***
  24625. subroutine MDF_Get_Att_r8_1d( hid, varid, name, values, status )
  24626. #ifdef with_hdf5_beta
  24627. use HDF5, only : HSIZE_T
  24628. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f
  24629. use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f
  24630. use HDF5, only : H5T_NATIVE_CHARACTER
  24631. use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE
  24632. use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE
  24633. #endif
  24634. #ifdef with_netcdf
  24635. use NetCDF, only : NF90_Get_Att, NF90_GLOBAL
  24636. #endif
  24637. ! --- in/out -------------------------------------
  24638. integer, intent(in) :: hid
  24639. integer, intent(in) :: varid
  24640. character(len=*), intent(in) :: name
  24641. real(8), intent(out) :: values(:)
  24642. integer, intent(out) :: status
  24643. ! --- const --------------------------------------
  24644. character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r8_1d'
  24645. ! --- external -------------------------------
  24646. #ifdef with_hdf4
  24647. integer(hdf4_wpi), external :: sfFAttr
  24648. integer(hdf4_wpi), external :: sfGAInfo
  24649. integer(hdf4_wpi), external :: sfRCAtt
  24650. integer(hdf4_wpi), external :: sfRNAtt
  24651. #endif
  24652. ! --- local --------------------------------------
  24653. type(MDF_File), pointer :: filep
  24654. type(MDF_Var), pointer :: varp
  24655. integer :: ftype
  24656. #ifdef with_hdf4
  24657. integer :: hdf4_id
  24658. integer :: hdf4_iatt
  24659. character(len=LEN_NAME) :: hdf4_name
  24660. integer :: hdf4_xtype
  24661. integer :: hdf4_length
  24662. integer(1), allocatable :: values_int1(:)
  24663. integer(2), allocatable :: values_int2(:)
  24664. integer(4), allocatable :: values_int4(:)
  24665. integer(8), allocatable :: values_int8(:)
  24666. real(4), allocatable :: values_real4(:)
  24667. real(8), allocatable :: values_real8(:)
  24668. #endif
  24669. #ifdef with_hdf5_beta
  24670. integer(HID_T) :: hdf5_loc_id
  24671. character(len=LEN_NAME) :: hdf5_obj_name
  24672. integer(HID_T) :: hdf5_attr_id
  24673. integer(HID_T) :: hdf5_type_id
  24674. #endif
  24675. #ifdef with_netcdf
  24676. integer :: netcdf_varid
  24677. #endif
  24678. ! --- begin --------------------------------------
  24679. ! single type:
  24680. call MDF_Get_Type( hid, ftype, status )
  24681. IF_NOT_OK_RETURN(status=1)
  24682. ! pointer to file structure:
  24683. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24684. IF_NOT_OK_RETURN(status=1)
  24685. ! pointer to variable structure if possible:
  24686. if ( varid /= MDF_GLOBAL ) then
  24687. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  24688. IF_NOT_OK_RETURN(status=1)
  24689. end if
  24690. ! select appropriate routine for each type:
  24691. select case ( ftype )
  24692. #ifdef with_hdf4
  24693. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24694. case ( MDF_HDF4 )
  24695. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24696. ! set variable id:
  24697. if ( varid == MDF_GLOBAL ) then
  24698. hdf4_id = filep%hdf4_id
  24699. else
  24700. hdf4_id = varp%hdf4_sdid
  24701. end if
  24702. ! get attribute index given name:
  24703. hdf4_iatt = sfFAttr( hdf4_id , trim(name) )
  24704. if ( hdf4_iatt == FAIL ) then
  24705. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  24706. TRACEBACK; status=1; return
  24707. end if
  24708. ! get type and length:
  24709. status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length )
  24710. if ( status /= SUCCEED ) then
  24711. write (gol,'("getting attribute info")') trim(name); call goErr
  24712. TRACEBACK; status=1; return
  24713. end if
  24714. ! read numerical attribute:
  24715. select case ( hdf4_xtype )
  24716. case ( DFNT_INT8 )
  24717. allocate( values_int1(hdf4_length) )
  24718. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 )
  24719. values = real(values_int1,kind=8)
  24720. deallocate( values_int1 )
  24721. case ( DFNT_INT16 )
  24722. allocate( values_int2(hdf4_length) )
  24723. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 )
  24724. values = real(values_int2,kind=8)
  24725. deallocate( values_int2 )
  24726. case ( DFNT_INT32 )
  24727. allocate( values_int4(hdf4_length) )
  24728. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 )
  24729. values = real(values_int4,kind=8)
  24730. deallocate( values_int4 )
  24731. case ( DFNT_INT64 )
  24732. allocate( values_int8(hdf4_length) )
  24733. status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 )
  24734. values = real(values_int8,kind=8)
  24735. deallocate( values_int8 )
  24736. case ( DFNT_FLOAT32 )
  24737. allocate( values_real4(hdf4_length) )
  24738. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 )
  24739. values = real(values_real4,kind=8)
  24740. deallocate( values_real4 )
  24741. case ( DFNT_FLOAT64 )
  24742. allocate( values_real8(hdf4_length) )
  24743. status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 )
  24744. values = real(values_real8,kind=8)
  24745. deallocate( values_real8 )
  24746. case default
  24747. write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype
  24748. TRACEBACK; status=1; return
  24749. end select
  24750. if ( status /= SUCCEED ) then
  24751. write (*,'("reading attribute : ",a)') trim(name); call goErr
  24752. TRACEBACK; status=1; return
  24753. end if
  24754. #endif
  24755. #ifdef with_hdf5_beta
  24756. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24757. case ( MDF_HDF5 )
  24758. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24759. ! set variable id:
  24760. if ( varid == MDF_GLOBAL ) then
  24761. ! file id:
  24762. hdf5_loc_id = filep%hdf5_file_id
  24763. hdf5_obj_name = '.'
  24764. else
  24765. ! file id:
  24766. hdf5_loc_id = varp%hdf5_dataset_id
  24767. hdf5_obj_name = '.'
  24768. end if
  24769. ! data type:
  24770. call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status )
  24771. IF_NOT_OK_RETURN(status=1)
  24772. ! open attribute:
  24773. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  24774. IF_NOT_OK_RETURN(status=1)
  24775. ! read:
  24776. call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int(shape(values),HSIZE_T), status )
  24777. IF_NOT_OK_RETURN(status=1)
  24778. ! release:
  24779. call H5TClose_f( hdf5_type_id, status )
  24780. IF_NOT_OK_RETURN(status=1)
  24781. ! release:
  24782. call H5AClose_f( hdf5_attr_id, status )
  24783. IF_NOT_OK_RETURN(status=1)
  24784. #endif
  24785. #ifdef with_netcdf
  24786. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24787. case ( MDF_NETCDF, MDF_NETCDF4 )
  24788. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24789. ! set variable id:
  24790. if ( varid == MDF_GLOBAL ) then
  24791. netcdf_varid = NF90_GLOBAL
  24792. else
  24793. netcdf_varid = varp%netcdf_varid
  24794. end if
  24795. ! read attribute:
  24796. status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values )
  24797. IF_NF90_NOT_OK_RETURN(status=1)
  24798. #endif
  24799. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24800. case default
  24801. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  24802. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  24803. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  24804. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  24805. TRACEBACK; status=1; return
  24806. end select
  24807. ! ok
  24808. status = 0
  24809. end subroutine MDF_Get_Att_r8_1d
  24810. ! ********************************************************************
  24811. ! ***
  24812. ! *** inquire
  24813. ! ***
  24814. ! ********************************************************************
  24815. subroutine MDF_Get_Type( hid, ftype, status )
  24816. ! --- in/out -------------------------------------
  24817. integer, intent(in) :: hid
  24818. integer, intent(out) :: ftype
  24819. integer, intent(out) :: status
  24820. ! --- const --------------------------------------
  24821. character(len=*), parameter :: rname = mname//'/MDF_Get_Type'
  24822. ! --- local --------------------------------------
  24823. type(MDF_File), pointer :: filep
  24824. integer :: iftype
  24825. ! --- begin --------------------------------------
  24826. ! pointer to file structure:
  24827. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24828. IF_NOT_OK_RETURN(status=1)
  24829. ! check ...
  24830. if ( filep%nftype /= 1 ) then
  24831. write (gol,'("mdf file not defined for single type but for ",i6," ...")') filep%nftype; call goErr
  24832. do iftype = 1, filep%nftype
  24833. select case ( filep%ftypes(iftype) )
  24834. #ifdef with_hdf4
  24835. case ( MDF_HDF4 )
  24836. write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr
  24837. #endif
  24838. #ifdef with_netcdf
  24839. case ( MDF_NETCDF, MDF_NETCDF4 )
  24840. write (gol,'(" netcdf file : ",a)') trim(filep%netcdf_fname); call goErr
  24841. #endif
  24842. case default
  24843. write (gol,'(" (unsupported type)")'); call goErr
  24844. end select
  24845. end do
  24846. TRACEBACK; status=1; return
  24847. end if
  24848. ! return single type:
  24849. ftype = filep%ftypes(1)
  24850. ! ok
  24851. status = 0
  24852. end subroutine MDF_Get_Type
  24853. ! ***
  24854. subroutine MDF_Inquire( hid, status, &
  24855. nDimensions, nVariables, nAttributes )
  24856. ! --- in/out -------------------------------------
  24857. integer, intent(in) :: hid
  24858. integer, intent(out) :: status
  24859. integer, intent(out), optional :: nDimensions
  24860. integer, intent(out), optional :: nVariables
  24861. integer, intent(out), optional :: nAttributes
  24862. ! --- const --------------------------------------
  24863. character(len=*), parameter :: rname = mname//'/MDF_Inquire'
  24864. ! --- local --------------------------------------
  24865. type(MDF_File), pointer :: filep
  24866. ! --- begin --------------------------------------
  24867. ! pointer to file structure:
  24868. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24869. IF_NOT_OK_RETURN(status=1)
  24870. ! return number of dimensions ?
  24871. if ( present(nDimensions) ) then
  24872. ! get number of elements in list:
  24873. call MDF_Dim_List_Inquire( filep%Dim_List, status, n=nDimensions )
  24874. IF_NOT_OK_RETURN(status=1)
  24875. end if
  24876. ! return number of variables ?
  24877. if ( present(nVariables) ) then
  24878. ! get number of elements in list:
  24879. call MDF_Var_List_Inquire( filep%Var_List, status, n=nVariables )
  24880. IF_NOT_OK_RETURN(status=1)
  24881. end if
  24882. ! return number of global attributes ?
  24883. if ( present(nAttributes) ) then
  24884. ! copy from structure:
  24885. nAttributes = filep%natt
  24886. end if
  24887. ! ok
  24888. status = 0
  24889. end subroutine MDF_Inquire
  24890. ! ***
  24891. subroutine MDF_Inq_DimID( hid, name, dimid, status )
  24892. ! --- in/out -------------------------------------
  24893. integer, intent(in) :: hid
  24894. character(len=*), intent(in) :: name
  24895. integer, intent(out) :: dimid
  24896. integer, intent(out) :: status
  24897. ! --- const --------------------------------------
  24898. character(len=*), parameter :: rname = mname//'/MDF_Inq_DimID'
  24899. ! --- local --------------------------------------
  24900. type(MDF_File), pointer :: filep
  24901. integer :: ndim, idim
  24902. character(len=LEN_NAME) :: dimname
  24903. ! --- begin --------------------------------------
  24904. ! pointer to file structure:
  24905. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24906. IF_NOT_OK_RETURN(status=1)
  24907. ! dummy ...
  24908. dimid = -1
  24909. ! number of variables:
  24910. call MDF_Inquire( hid, status, ndimensions=ndim )
  24911. IF_NOT_OK_RETURN(status=1)
  24912. ! list variables ?
  24913. if ( ndim > 0 ) then
  24914. ! loop over variables:
  24915. do idim = 1, ndim
  24916. ! get name:
  24917. call MDF_Inquire_Dimension( hid, idim, status, name=dimname )
  24918. IF_NOT_OK_RETURN(status=1)
  24919. ! similar ?
  24920. if ( trim(name) == trim(dimname) ) then
  24921. ! store current id:
  24922. dimid = idim
  24923. ! leave:
  24924. exit
  24925. end if
  24926. end do ! variables
  24927. end if
  24928. ! check ...
  24929. if ( dimid < 0 ) then
  24930. write (gol,'("no dimension `",a,"` found in file : ",a)') trim(name), trim(filep%filename); call goErr
  24931. TRACEBACK; status=1; return
  24932. end if
  24933. ! ok
  24934. status = 0
  24935. end subroutine MDF_Inq_DimID
  24936. ! ***
  24937. subroutine MDF_Inquire_Dimension( hid, dimid, status, name, length, unlimited, named )
  24938. ! --- in/out -------------------------------------
  24939. integer, intent(in) :: hid
  24940. integer, intent(in) :: dimid
  24941. integer, intent(out) :: status
  24942. character(len=*), intent(out), optional :: name
  24943. integer, intent(out), optional :: length
  24944. logical, intent(out), optional :: unlimited
  24945. logical, intent(out), optional :: named
  24946. ! --- const --------------------------------------
  24947. character(len=*), parameter :: rname = mname//'/MDF_Inquire_Dimension'
  24948. ! --- local --------------------------------------
  24949. type(MDF_File), pointer :: filep
  24950. type(MDF_Dim), pointer :: dimp
  24951. ! --- begin --------------------------------------
  24952. ! pointer to file structure:
  24953. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24954. IF_NOT_OK_RETURN(status=1)
  24955. ! pointer to dimension structure:
  24956. call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status )
  24957. IF_NOT_OK_RETURN(status=1)
  24958. ! return value ?
  24959. if ( present(name ) ) name = trim(dimp%name)
  24960. if ( present(length ) ) length = dimp%length
  24961. if ( present(unlimited) ) unlimited = dimp%unlimited
  24962. if ( present(named ) ) named = dimp%named
  24963. ! ok
  24964. status = 0
  24965. end subroutine MDF_Inquire_Dimension
  24966. ! ***
  24967. subroutine MDF_Inq_VarID( hid, name, varid, status )
  24968. ! --- in/out -------------------------------------
  24969. integer, intent(in) :: hid
  24970. character(len=*), intent(in) :: name
  24971. integer, intent(out) :: varid
  24972. integer, intent(out) :: status
  24973. ! --- const --------------------------------------
  24974. character(len=*), parameter :: rname = mname//'/MDF_Inq_VarID'
  24975. ! --- local --------------------------------------
  24976. type(MDF_File), pointer :: filep
  24977. integer :: nvar, ivar
  24978. character(len=LEN_NAME) :: varname
  24979. ! --- begin --------------------------------------
  24980. ! pointer to file structure:
  24981. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  24982. IF_NOT_OK_RETURN(status=1)
  24983. ! dummy ...
  24984. varid = -1
  24985. ! number of variables:
  24986. call MDF_Inquire( hid, status, nVariables=nvar )
  24987. IF_NOT_OK_RETURN(status=1)
  24988. ! list variables ?
  24989. if ( nvar > 0 ) then
  24990. ! loop over variables:
  24991. do ivar = 1, nvar
  24992. ! get name:
  24993. call MDF_Inquire_Variable( hid, ivar, status, name=varname )
  24994. IF_NOT_OK_RETURN(status=1)
  24995. ! similar ?
  24996. if ( trim(name) == trim(varname) ) then
  24997. ! store current id:
  24998. varid = ivar
  24999. ! leave:
  25000. exit
  25001. end if
  25002. end do ! variables
  25003. end if
  25004. ! check ...
  25005. if ( varid < 0 ) then
  25006. write (gol,'("no variable `",a,"` found in file : ",a)') trim(name), trim(filep%filename); call goErr
  25007. TRACEBACK; status=varid; return
  25008. end if
  25009. ! ok
  25010. status = 0
  25011. end subroutine MDF_Inq_VarID
  25012. ! ***
  25013. subroutine MDF_Inquire_Variable( hid, varid, status, &
  25014. name, xtype, ndims, dimids, natts, &
  25015. shp )
  25016. ! --- in/out -------------------------------------
  25017. integer, intent(in) :: hid
  25018. integer, intent(in) :: varid
  25019. integer, intent(out) :: status
  25020. character(len=*), intent(out), optional :: name
  25021. integer, intent(out), optional :: xtype
  25022. integer, intent(out), optional :: ndims
  25023. integer, intent(out), optional :: dimids(:)
  25024. integer, intent(out), optional :: natts
  25025. integer, intent(out), optional :: shp(:)
  25026. ! --- const --------------------------------------
  25027. character(len=*), parameter :: rname = mname//'/MDF_Inquire_Variable'
  25028. ! --- local --------------------------------------
  25029. integer :: ftype
  25030. type(MDF_File), pointer :: filep
  25031. type(MDF_Var), pointer :: varp
  25032. ! --- begin --------------------------------------
  25033. ! single type:
  25034. call MDF_Get_Type( hid, ftype, status )
  25035. IF_NOT_OK_RETURN(status=1)
  25036. ! pointer to file structure:
  25037. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  25038. IF_NOT_OK_RETURN(status=1)
  25039. ! pointer to variable structure:
  25040. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  25041. IF_NOT_OK_RETURN(status=1)
  25042. ! return value ?
  25043. if ( present(name ) ) name = trim(varp%name)
  25044. if ( present(xtype ) ) xtype = varp%xtype
  25045. if ( present(ndims ) ) ndims = varp%ndim
  25046. if ( present(dimids ) ) then
  25047. if ( size(dimids) /= varp%ndim ) then
  25048. write (gol,'("size of dimension id array (",i6,") should equal number of dimensions (",i6,")")') size(dimids), varp%ndim; call goErr
  25049. TRACEBACK; status=1; return
  25050. end if
  25051. dimids = varp%dimids(1:varp%ndim)
  25052. end if
  25053. if ( present(natts) ) then
  25054. natts = varp%natt
  25055. end if
  25056. ! special:
  25057. if ( present(shp) ) then
  25058. if ( size(shp) /= varp%ndim ) then
  25059. write (gol,'("size of shape array (",i6,") should equal number of dimensions (",i6,")")') size(shp), varp%ndim; call goErr
  25060. TRACEBACK; status=1; return
  25061. end if
  25062. shp = varp%shp(1:varp%ndim)
  25063. end if
  25064. ! ok
  25065. status = 0
  25066. end subroutine MDF_Inquire_Variable
  25067. ! ***
  25068. subroutine MDF_Inquire_Attribute( hid, varid, name, status, xtype, length )
  25069. #ifdef with_hdf5_beta
  25070. use HDF5, only : HSIZE_T
  25071. use HDF5, only : H5AOpen_By_Name_f, H5AClose_f
  25072. use HDF5, only : H5AGet_Type_f
  25073. use HDF5, only : H5TGet_Native_Type_f, H5TClose_f
  25074. use HDF5, only : H5T_DIR_ASCEND_F
  25075. use HDF5, only : H5AGet_Space_f
  25076. use HDF5, only : H5SGet_Simple_Extent_Dims_f, H5SClose_f
  25077. #endif
  25078. #ifdef with_netcdf
  25079. use NetCDF, only : NF90_Inquire_Attribute
  25080. use NetCDF, only : NF90_GLOBAL
  25081. use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE
  25082. #endif
  25083. ! --- in/out -------------------------------------
  25084. integer, intent(in) :: hid
  25085. integer, intent(in) :: varid
  25086. character(len=*), intent(in) :: name
  25087. integer, intent(out) :: status
  25088. integer, intent(out), optional :: xtype
  25089. integer, intent(out), optional :: length
  25090. ! --- const --------------------------------------
  25091. character(len=*), parameter :: rname = mname//'/MDF_Inquire_Attribute'
  25092. ! --- external -------------------------------
  25093. #ifdef with_hdf4
  25094. integer(hdf4_wpi), external :: sfFAttr
  25095. integer(hdf4_wpi), external :: sfGAInfo
  25096. #endif
  25097. ! --- local --------------------------------------
  25098. integer :: ftype
  25099. type(MDF_File), pointer :: filep
  25100. type(MDF_Var), pointer :: varp
  25101. #ifdef with_hdf4
  25102. integer :: hdf4_id
  25103. integer :: hdf4_attind
  25104. character(len=LEN_NAME) :: hdf4_name
  25105. integer :: hdf4_xtype
  25106. #endif
  25107. #ifdef with_hdf5_beta
  25108. integer(HID_T) :: hdf5_loc_id
  25109. character(len=LEN_NAME) :: hdf5_obj_name
  25110. integer(HID_T) :: hdf5_attr_id
  25111. integer(HID_T) :: hdf5_type_id
  25112. integer(HID_T) :: hdf5_space_id
  25113. integer(HSIZE_T) :: hdf5_dims(MAX_RANK)
  25114. integer(HSIZE_T) :: hdf5_maxdims(MAX_RANK)
  25115. integer :: hdf5_rank
  25116. #endif
  25117. #ifdef with_netcdf
  25118. integer :: netcdf_id
  25119. #endif
  25120. ! --- begin --------------------------------------
  25121. ! single type:
  25122. call MDF_Get_Type( hid, ftype, status )
  25123. IF_NOT_OK_RETURN(status=1)
  25124. ! pointer to file structure:
  25125. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  25126. IF_NOT_OK_RETURN(status=1)
  25127. ! select appropriate routine:
  25128. select case ( ftype )
  25129. #ifdef with_hdf4
  25130. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25131. case ( MDF_HDF4 )
  25132. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25133. ! global or variable attribute ?
  25134. if ( varid == MDF_GLOBAL ) then
  25135. ! file id:
  25136. hdf4_id = filep%hdf4_id
  25137. else
  25138. ! pointer to variable structure:
  25139. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  25140. IF_NOT_OK_RETURN(status=1)
  25141. ! variable id:
  25142. hdf4_id = varp%hdf4_sdid
  25143. end if
  25144. ! get attribute number given name:
  25145. hdf4_attind = sfFAttr( hdf4_id, trim(name) )
  25146. if ( hdf4_attind == FAIL ) then
  25147. write (gol,'("finding attribute `",a,"`")') trim(name); call goErr
  25148. TRACEBACK; status=1; return
  25149. status=-1; return
  25150. end if
  25151. ! extract info:
  25152. status = sfGAInfo( hdf4_id, hdf4_attind, hdf4_name, hdf4_xtype, length )
  25153. if ( status /= SUCCEED ) then
  25154. write (gol,'("getting attribute info:")'); call goErr
  25155. write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr
  25156. if ( varid /= MDF_GLOBAL ) then
  25157. write (gol,'(" variable name : ",a)') trim(varp%name); call goErr
  25158. end if
  25159. write (gol,'(" hdf4 attribute index : ",i6)') hdf4_attind; call goErr
  25160. TRACEBACK; status=1; return
  25161. end if
  25162. ! return type ?
  25163. if ( present(xtype) ) then
  25164. ! convert:
  25165. select case ( hdf4_xtype )
  25166. case ( DFNT_CHAR ) ; xtype = MDF_CHAR
  25167. case ( DFNT_INT8 ) ; xtype = MDF_BYTE
  25168. case ( DFNT_INT16 ) ; xtype = MDF_SHORT
  25169. case ( DFNT_INT32 ) ; xtype = MDF_INT
  25170. case ( DFNT_FLOAT32 ) ; xtype = MDF_FLOAT
  25171. case ( DFNT_FLOAT64 ) ; xtype = MDF_DOUBLE
  25172. case default
  25173. write (gol,'("unsupported data type : ",i6)') hdf4_xtype; call goErr
  25174. TRACEBACK; status=1; return
  25175. end select
  25176. end if
  25177. #endif
  25178. #ifdef with_hdf5_beta
  25179. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25180. case ( MDF_HDF5 )
  25181. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25182. ! global or variable attribute ?
  25183. if ( varid == MDF_GLOBAL ) then
  25184. ! file id:
  25185. hdf5_loc_id = filep%hdf5_file_id
  25186. hdf5_obj_name = '.'
  25187. else
  25188. ! pointer to variable structure:
  25189. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  25190. IF_NOT_OK_RETURN(status=1)
  25191. ! dataset id:
  25192. hdf5_loc_id = varp%hdf5_dataset_id
  25193. hdf5_obj_name = '.'
  25194. end if
  25195. ! open attribute:
  25196. call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status )
  25197. IF_NOT_OK_RETURN(status=1)
  25198. ! get type ?
  25199. if ( present(xtype) ) then
  25200. ! get data type id:
  25201. call H5AGet_Type_f( hdf5_attr_id, hdf5_type_id, status )
  25202. IF_NOT_OK_RETURN(status=1)
  25203. ! convert to mdf type code:
  25204. call HDF5_Get_MDF_Type( hdf5_type_id, xtype, status )
  25205. IF_NOT_OK_RETURN(status=1)
  25206. ! release:
  25207. call H5TClose_f( hdf5_type_id, status )
  25208. IF_NOT_OK_RETURN(status=1)
  25209. end if
  25210. ! return length ?
  25211. if ( present(length) ) then
  25212. ! get data space id:
  25213. call H5AGet_Space_f( hdf5_attr_id, hdf5_space_id, status )
  25214. IF_NOT_OK_RETURN(status=1)
  25215. ! get dimensions:
  25216. call H5SGet_Simple_Extent_Dims_f( hdf5_space_id, hdf5_dims, hdf5_maxdims, status )
  25217. if ( status < 0 ) then
  25218. write (gol,'("could not extract dimensions for attribute : ",a)') trim(name); call goErr
  25219. TRACEBACK; status=1; return
  25220. else
  25221. hdf5_rank = status
  25222. end if
  25223. ! extract length:
  25224. if ( hdf5_rank == 0 ) then
  25225. length = 1 ! scalar
  25226. else if ( hdf5_rank == 1 ) then
  25227. length = hdf5_dims(1) ! 1d array
  25228. else
  25229. write (gol,'("hdf5 attributes not supported for rank ",i6)') hdf5_rank; call goErr
  25230. TRACEBACK; status=1; return
  25231. endif
  25232. ! release:
  25233. call H5SClose_f( hdf5_space_id, status )
  25234. IF_NOT_OK_RETURN(status=1)
  25235. end if
  25236. ! release:
  25237. call H5AClose_f( hdf5_attr_id, status )
  25238. IF_NOT_OK_RETURN(status=1)
  25239. #endif
  25240. #ifdef with_netcdf
  25241. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25242. case ( MDF_NETCDF, MDF_NETCDF4 )
  25243. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25244. ! global or variable attribute ?
  25245. if ( varid == MDF_GLOBAL ) then
  25246. ! file id:
  25247. netcdf_id = NF90_GLOBAL
  25248. else
  25249. ! pointer to variable structure:
  25250. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  25251. IF_NOT_OK_RETURN(status=1)
  25252. ! variable id:
  25253. netcdf_id = varp%netcdf_varid
  25254. end if
  25255. ! get type etc:
  25256. status = NF90_Inquire_Attribute( filep%netcdf_id, netcdf_id, trim(name), &
  25257. xtype=xtype, len=length )
  25258. IF_NF90_NOT_OK_RETURN(status=1)
  25259. ! return type ?
  25260. if ( present(xtype) ) then
  25261. ! convert:
  25262. select case ( xtype )
  25263. case ( NF90_CHAR ) ; xtype = MDF_CHAR
  25264. case ( NF90_BYTE ) ; xtype = MDF_BYTE
  25265. case ( NF90_SHORT ) ; xtype = MDF_SHORT
  25266. case ( NF90_INT ) ; xtype = MDF_INT
  25267. case ( NF90_FLOAT ) ; xtype = MDF_FLOAT
  25268. case ( NF90_DOUBLE ) ; xtype = MDF_DOUBLE
  25269. case default
  25270. write (gol,'("unsupported data type : ",i6)') xtype; call goErr
  25271. TRACEBACK; status=1; return
  25272. end select
  25273. end if
  25274. #endif
  25275. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25276. case default
  25277. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25278. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  25279. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  25280. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  25281. TRACEBACK; status=1; return
  25282. end select
  25283. ! ok
  25284. status = 0
  25285. end subroutine MDF_Inquire_Attribute
  25286. ! ***
  25287. subroutine MDF_Inq_AttName( hid, varid, attnum, name, status )
  25288. #ifdef with_hdf5_beta
  25289. use HDF5, only : HSIZE_T
  25290. use HDF5, only : H5AGet_Name_By_Idx_f
  25291. use HDF5, only : H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F
  25292. #endif
  25293. #ifdef with_netcdf
  25294. use NetCDF, only : NF90_Inq_AttName, NF90_GLOBAL
  25295. #endif
  25296. ! --- in/out -------------------------------------
  25297. integer, intent(in) :: hid
  25298. integer, intent(in) :: varid
  25299. integer, intent(in) :: attnum ! 1,..,natt
  25300. character(len=*), intent(out) :: name
  25301. integer, intent(out) :: status
  25302. ! --- const --------------------------------------
  25303. character(len=*), parameter :: rname = mname//'/MDF_Inq_AttName'
  25304. ! --- external -------------------------------
  25305. #ifdef with_hdf4
  25306. integer(hdf4_wpi), external :: sfGAInfo
  25307. #endif
  25308. ! --- local --------------------------------------
  25309. integer :: ftype
  25310. type(MDF_File), pointer :: filep
  25311. type(MDF_Var), pointer :: varp
  25312. #ifdef with_hdf4
  25313. integer :: hdf4_xtype
  25314. integer :: hdf4_length
  25315. #endif
  25316. #ifdef with_hdf5_beta
  25317. integer(HSIZE_T) :: hdf5_idx
  25318. #endif
  25319. ! --- begin --------------------------------------
  25320. ! single type:
  25321. call MDF_Get_Type( hid, ftype, status )
  25322. IF_NOT_OK_RETURN(status=1)
  25323. ! pointer to file structure:
  25324. call MDF_File_List_Get_Pointer( File_List, hid, filep, status )
  25325. IF_NOT_OK_RETURN(status=1)
  25326. ! global attribute ?
  25327. if ( varid == MDF_GLOBAL ) then
  25328. ! select appropriate routine:
  25329. select case ( ftype )
  25330. #ifdef with_hdf4
  25331. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25332. case ( MDF_HDF4 )
  25333. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25334. ! extract info:
  25335. status = sfGAInfo( filep%hdf4_id, attnum-1, name, hdf4_xtype, hdf4_length )
  25336. if ( status /= SUCCEED ) then
  25337. write (gol,'("getting attribute info:")'); call goErr
  25338. write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr
  25339. write (gol,'(" attribute number : ",i6)') attnum; call goErr
  25340. TRACEBACK; status=1; return
  25341. end if
  25342. #endif
  25343. #ifdef with_hdf5_beta
  25344. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25345. case ( MDF_HDF5 )
  25346. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25347. ! open attribute:
  25348. call H5AGet_Name_By_Idx_f( filep%hdf5_file_id, '.', &
  25349. H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, int(attnum-1,HSIZE_T), &
  25350. name, status )
  25351. IF_NOT_OK_RETURN(status=1)
  25352. #endif
  25353. #ifdef with_netcdf
  25354. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25355. case ( MDF_NETCDF, MDF_NETCDF4 )
  25356. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25357. ! get name:
  25358. status = NF90_Inq_AttName( filep%netcdf_id, NF90_GLOBAL, attnum, name )
  25359. IF_NF90_NOT_OK_RETURN(status=1)
  25360. #endif
  25361. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25362. case default
  25363. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25364. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  25365. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  25366. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  25367. TRACEBACK; status=1; return
  25368. end select
  25369. else ! variable attribute
  25370. ! pointer to variable structure:
  25371. call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status )
  25372. IF_NOT_OK_RETURN(status=1)
  25373. ! select appropriate routine:
  25374. select case ( ftype )
  25375. #ifdef with_hdf4
  25376. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25377. case ( MDF_HDF4 )
  25378. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25379. ! extract info:
  25380. status = sfGAInfo( varp%hdf4_sdid, attnum-1, name, hdf4_xtype, hdf4_length )
  25381. if ( status /= SUCCEED ) then
  25382. write (gol,'("getting attribute info:")'); call goErr
  25383. write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr
  25384. write (gol,'(" variable name : ",a)') trim(varp%name); call goErr
  25385. write (gol,'(" attribute number : ",i6)') attnum; call goErr
  25386. TRACEBACK; status=1; return
  25387. end if
  25388. #endif
  25389. #ifdef with_hdf5_beta
  25390. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25391. case ( MDF_HDF5 )
  25392. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25393. ! index number:
  25394. hdf5_idx = attnum-1
  25395. ! open attribute:
  25396. call H5AGet_Name_By_Idx_f( varp%hdf5_dataset_id, '.', &
  25397. H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, hdf5_idx, &
  25398. name, status )
  25399. IF_NOT_OK_RETURN(status=1)
  25400. #endif
  25401. #ifdef with_netcdf
  25402. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25403. case ( MDF_NETCDF, MDF_NETCDF4 )
  25404. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25405. ! get name:
  25406. status = NF90_Inq_AttName( filep%netcdf_id, varp%netcdf_varid, attnum, name )
  25407. IF_NF90_NOT_OK_RETURN(status=1)
  25408. #endif
  25409. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25410. case default
  25411. ! ~~~~~~~~~~~~~~~~~~~~~~~~~~
  25412. write (gol,'("unsupported filetype : ",i6)') ftype; call goErr
  25413. write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr
  25414. write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr
  25415. TRACEBACK; status=1; return
  25416. end select
  25417. end if ! global or variable attribute
  25418. ! ok
  25419. status = 0
  25420. end subroutine MDF_Inq_AttName
  25421. ! ********************************************************************
  25422. ! ***
  25423. ! *** show content
  25424. ! ***
  25425. ! ********************************************************************
  25426. subroutine MDF_Show( filename, status, filetype, show_data )
  25427. ! --- in/out -------------------------------------
  25428. character(len=*), intent(in) :: filename
  25429. integer, intent(out) :: status
  25430. integer, intent(in), optional :: filetype
  25431. logical, intent(in), optional :: show_data
  25432. ! --- const --------------------------------------
  25433. character(len=*), parameter :: rname = mname//'/MDF_Show'
  25434. ! --- local --------------------------------------
  25435. integer :: l
  25436. integer :: ftype
  25437. logical :: do_show_data
  25438. integer :: hid
  25439. integer :: ndim, idim
  25440. integer :: nvar, ivar
  25441. integer :: natt
  25442. logical :: named
  25443. character(len=LEN_NAME) :: ftype_name
  25444. character(len=LEN_NAME) :: name
  25445. integer :: length
  25446. logical :: unlimited
  25447. logical :: isfirst
  25448. integer :: xtype
  25449. integer :: dimids(MAX_RANK)
  25450. integer :: shp(MAX_RANK)
  25451. character(len=LEN_LINE) :: line
  25452. character(len=LEN_NAME) :: val
  25453. ! --- begin --------------------------------------
  25454. ! show data ?
  25455. do_show_data = .false.
  25456. if ( present(show_data) ) do_show_data = show_data
  25457. ! guess file type by default, or set to optional argument:
  25458. ftype = MDF_NONE
  25459. if ( present(filetype) ) ftype = filetype
  25460. ! guess file type ?
  25461. if ( ftype == MDF_NONE ) then
  25462. ! length of filename:
  25463. l = len_trim(filename)
  25464. ! guess ...
  25465. if ( (l > 3) .and. (filename(l-2:l) == '.nc') ) then
  25466. ftype = MDF_NETCDF
  25467. else if ( (l > 3) .and. (filename(l-2:l) == '.h5') ) then
  25468. ftype = MDF_HDF5
  25469. else if ( (l > 4) .and. (filename(l-3:l) == '.hdf') ) then
  25470. ftype = MDF_HDF4
  25471. else
  25472. write (gol,'("could not guess file type from file name:")'); call goErr
  25473. write (gol,'(" ",a)') trim(filename); call goErr
  25474. TRACEBACK; status=1; return
  25475. end if
  25476. end if
  25477. ! filetype name:
  25478. ftype_name = trim(MDF_FILETYPE_NAME(ftype))
  25479. #ifdef with_netcdf
  25480. if ( ftype == MDF_NETCDF ) then
  25481. call NetCDF_Get_FileType( trim(filename), ftype_name, status )
  25482. IF_NOT_OK_RETURN(status=1)
  25483. end if
  25484. #endif
  25485. ! open file:
  25486. call MDF_Open( trim(filename), ftype, MDF_READ, hid, status )
  25487. IF_NOT_OK_RETURN(status=1)
  25488. ! header line:
  25489. ! <filetype> <filename> {
  25490. write (gol,'(a," ",a," {")') trim(ftype_name), trim(filename); call goPr
  25491. ! number of dimensions:
  25492. call MDF_Inquire( hid, status, nDimensions=ndim )
  25493. IF_NOT_OK_RETURN(status=1)
  25494. ! list dimensions ?
  25495. if ( ndim > 0 ) then
  25496. ! init flag:
  25497. isfirst = .true.
  25498. ! loop over dimensions:
  25499. do idim = 1, ndim
  25500. ! write lines:
  25501. ! x = 4 ;
  25502. ! t = UNLIMITED ; // (5 currently)
  25503. ! ...
  25504. ! get name and length:
  25505. call MDF_Inquire_Dimension( hid, idim, status, name=name, named=named, &
  25506. length=length, unlimited=unlimited )
  25507. IF_NOT_OK_RETURN(status=1)
  25508. ! skip ?
  25509. if ( .not. named ) cycle
  25510. ! display header ?
  25511. if ( isfirst ) then
  25512. write (gol,'("dimensions:")'); call goPr
  25513. isfirst = .false.
  25514. end if
  25515. ! display:
  25516. if ( unlimited ) then
  25517. write (val,*) length
  25518. val = adjustl(val)
  25519. write (gol,'(" ",a," = UNLIMITED ; // (",a," currently)")') trim(name), trim(val); call goPr
  25520. else if ( named ) then
  25521. write (gol,'(" ",a," = ",i6," ;")') trim(name), length; call goPr
  25522. end if
  25523. end do ! dimensions
  25524. end if ! ndim > 0
  25525. ! number of variables:
  25526. call MDF_Inquire( hid, status, nVariables=nvar )
  25527. IF_NOT_OK_RETURN(status=1)
  25528. ! list variables ?
  25529. if ( nvar > 0 ) then
  25530. ! start:
  25531. write (gol,'("variables:")'); call goPr
  25532. ! loop over variables:
  25533. do ivar = 1, nvar
  25534. ! write lines:
  25535. ! float afield(y, x) ;
  25536. ! afield:unit = "m" ;
  25537. ! ...
  25538. ! get name etc:
  25539. call MDF_Inquire_Variable( hid, ivar, status, name=name, xtype=xtype, ndims=ndim, natts=natt )
  25540. IF_NOT_OK_RETURN(status=1)
  25541. ! get dimension id's now the number is known:
  25542. call MDF_Inquire_Variable( hid, ivar, status, dimids=dimids(1:ndim) )
  25543. IF_NOT_OK_RETURN(status=1)
  25544. ! start line with type and variable name:
  25545. write (line,'(" ",a," ",a,"(")') trim(MDF_DATATYPE_NAME(xtype)), trim(name)
  25546. ! loop over dimensions:
  25547. shp = 1
  25548. do idim = 1, ndim
  25549. ! get dimension name:
  25550. call MDF_Inquire_Dimension( hid, dimids(idim), status, name=name, named=named, &
  25551. length=length, unlimited=unlimited )
  25552. IF_NOT_OK_RETURN(status=1)
  25553. ! add to line:
  25554. if ( idim > 1 ) line = trim(line)//','
  25555. ! name or number ...
  25556. if ( named ) then
  25557. line = trim(line)//' '//trim(name)
  25558. else
  25559. write (val,*) length
  25560. line = trim(line)//' '//adjustl(val)
  25561. if (unlimited) line = trim(line)//'/Inf'
  25562. end if
  25563. ! store for show_data:
  25564. shp(idim) = length
  25565. end do
  25566. ! close line:
  25567. line = trim(line)//' ) ;'
  25568. ! display dimension name(dims) line:
  25569. write (gol,'(a)') trim(line); call goPr
  25570. ! write attributes:
  25571. call MDF_Show_Attributes( hid, ivar, natt, status )
  25572. IF_NOT_OK_RETURN(status=1)
  25573. ! show data ?
  25574. if ( do_show_data ) then
  25575. ! display data:
  25576. call MDF_Show_Data( hid, ivar, xtype, ndim, shp, status )
  25577. IF_NOT_OK_RETURN(status=1)
  25578. end if
  25579. end do ! variables
  25580. end if ! nvar > 0
  25581. ! number of global attributes:
  25582. call MDF_Inquire( hid, status, nAttributes=natt )
  25583. IF_NOT_OK_RETURN(status=1)
  25584. ! global attributes ?
  25585. if ( natt > 0 ) then
  25586. ! intro:
  25587. write (gol,'("")'); call goPr
  25588. write (gol,'("// global attributes:")'); call goPr
  25589. ! display attributes:
  25590. call MDF_Show_Attributes( hid, MDF_GLOBAL, natt, status )
  25591. IF_NOT_OK_RETURN(status=1)
  25592. end if
  25593. ! closure:
  25594. ! }
  25595. write (gol,'("}")'); call goPr
  25596. ! close file:
  25597. call MDF_Close( hid, status )
  25598. IF_NOT_OK_RETURN(status=1)
  25599. ! ok
  25600. status = 0
  25601. end subroutine MDF_Show
  25602. ! ***
  25603. subroutine MDF_Show_Attributes( hid, ivar, natt, status )
  25604. ! --- in/out -------------------------------------
  25605. integer, intent(in) :: hid
  25606. integer, intent(in) :: ivar
  25607. integer, intent(in) :: natt
  25608. integer, intent(out) :: status
  25609. ! --- const --------------------------------------
  25610. character(len=*), parameter :: rname = mname//'/MDF_Show_Attributes'
  25611. ! --- local --------------------------------------
  25612. integer :: l
  25613. integer :: iatt
  25614. character(len=LEN_NAME) :: name
  25615. integer :: length
  25616. integer :: xtype
  25617. character(len=LEN_LINE) :: line
  25618. character(len=LEN_NAME) :: val
  25619. integer :: ival
  25620. integer(4), allocatable :: values_i4(:)
  25621. real(8), allocatable :: values_r8(:)
  25622. ! --- begin --------------------------------------
  25623. ! loop over attributes:
  25624. do iatt = 1, natt
  25625. ! get name:
  25626. call MDF_Inq_AttName( hid, ivar, iatt, name, status )
  25627. IF_NOT_OK_RETURN(status=1)
  25628. ! get type and length:
  25629. call MDF_Inquire_Attribute( hid, ivar, name, status, xtype=xtype, length=length )
  25630. IF_NOT_OK_RETURN(status=1)
  25631. !! info ...
  25632. !write (gol,'(" ",a," <",a,"> ",i4," ;")') trim(name), trim(MDF_DATATYPE_NAME(xtype)), length; call goPr
  25633. ! different per type ...
  25634. select case ( xtype )
  25635. !character values
  25636. case ( MDF_CHAR )
  25637. ! get value:
  25638. call MDF_Get_Att( hid, ivar, name, line, status )
  25639. if (status/=0) then
  25640. ! somthing went wrong (attribute too large ?)
  25641. line = '...'
  25642. else
  25643. ! ok; but not too much to the screen ...
  25644. if ( len_trim(line) > 400 ) line = line(1:400)//'...'
  25645. end if
  25646. ! display ..
  25647. ! variable rank etc:
  25648. write (gol,'(" ",a," = """,a,""" ;")') trim(name), trim(line); call goPr
  25649. !integer values
  25650. case ( MDF_BYTE, MDF_SHORT, MDF_INT )
  25651. ! storage:
  25652. allocate( values_i4(length) )
  25653. ! fill:
  25654. call MDF_Get_Att( hid, ivar, name, values_i4, status )
  25655. if (status/=0) then
  25656. ! somthing went wrong (attribute too large ?)
  25657. line = '...'
  25658. else
  25659. ! loop over values:
  25660. line = ''
  25661. do ival = 1, min(length,50)
  25662. ! add seperation if necessary:
  25663. if ( ival > 1 ) line = trim(line)//','
  25664. ! dump value:
  25665. write (val,*) values_i4(ival)
  25666. ! shift to left:
  25667. val = adjustl(val)
  25668. ! add to line:
  25669. line = trim(line)//' '//trim(val)
  25670. ! add type indicator if necessary:
  25671. if ( xtype == MDF_BYTE ) line = trim(line)//'b'
  25672. if ( xtype == MDF_SHORT ) line = trim(line)//'s'
  25673. end do
  25674. if ( ival < length ) line=trim(line)//' ...'
  25675. end if
  25676. ! display:
  25677. write (gol,'(" ",a," =",a)') trim(name), trim(line); call goPr
  25678. ! clear:
  25679. deallocate( values_i4 )
  25680. !floating point values
  25681. case ( MDF_FLOAT, MDF_DOUBLE )
  25682. ! storage:
  25683. allocate( values_r8(length) )
  25684. ! fill:
  25685. call MDF_Get_Att( hid, ivar, name, values_r8, status )
  25686. if (status/=0) then
  25687. ! somthing went wrong (attribute too large ?)
  25688. line = '...'
  25689. else
  25690. ! loop over values:
  25691. line = ''
  25692. do ival = 1, min(length,50)
  25693. ! add seperation if necessary:
  25694. if ( ival > 1 ) line = trim(line)//','
  25695. ! dump value:
  25696. write (val,*) values_r8(ival)
  25697. ! remove tailing zeros:
  25698. do l = len_trim(val), 1, -1
  25699. if ( val(l:l) /= '0' ) exit
  25700. val(l:l) = ' '
  25701. end do
  25702. ! shift to left:
  25703. val = adjustl(val)
  25704. ! add to line:
  25705. line = trim(line)//' '//trim(val)
  25706. ! add type indicator if necessary:
  25707. if ( xtype == MDF_FLOAT ) line = trim(line)//'f'
  25708. end do
  25709. if ( ival < length ) line=trim(line)//' ...'
  25710. end if
  25711. ! display:
  25712. write (gol,'(" ",a," =",a)') trim(name), trim(line); call goPr
  25713. ! clear:
  25714. deallocate( values_r8 )
  25715. !other ...
  25716. case default
  25717. write (gol,'("INTERNAL - unsupported data type : ",i6)') xtype; call goErr
  25718. TRACEBACK; status=1; return
  25719. end select
  25720. end do
  25721. ! ok
  25722. status = 0
  25723. end subroutine MDF_Show_Attributes
  25724. ! ***
  25725. subroutine MDF_Show_Data( hid, ivar, xtype, rank, shp, status )
  25726. ! --- in/out -------------------------------------
  25727. integer, intent(in) :: hid
  25728. integer, intent(in) :: ivar
  25729. integer, intent(in) :: xtype
  25730. integer, intent(in) :: rank
  25731. integer, intent(in) :: shp(MAX_RANK)
  25732. integer, intent(out) :: status
  25733. ! --- const --------------------------------------
  25734. character(len=*), parameter :: rname = mname//'/MDF_Show_Data'
  25735. ! --- local --------------------------------------
  25736. character(len=LEN_LINE) :: line
  25737. character(len=LEN_NAME) :: val
  25738. integer :: l
  25739. integer :: i1,i2,i3,i4,i5,i6,i7
  25740. integer(4), allocatable :: values_i4(:,:,:,:,:,:,:)
  25741. real(8), allocatable :: values_r8(:,:,:,:,:,:,:)
  25742. character(len=shp(1)), allocatable :: values_c (:,:,:,:,:,:)
  25743. ! --- begin --------------------------------------
  25744. ! per type:
  25745. select case ( xtype )
  25746. ! character values:
  25747. case ( MDF_CHAR )
  25748. ! storage:
  25749. allocate( values_c(shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status )
  25750. IF_NOT_OK_RETURN(status=1)
  25751. ! read:
  25752. select case ( rank )
  25753. case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_c(1,1,1,1,1,1), status, count=shp(1:rank) )
  25754. case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_c(:,1,1,1,1,1), status, count=shp(1:rank) )
  25755. case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,1,1,1,1), status, count=shp(1:rank) )
  25756. case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,1,1,1), status, count=shp(1:rank) )
  25757. case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,1,1), status, count=shp(1:rank) )
  25758. case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,:,1), status, count=shp(1:rank) )
  25759. case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,:,:), status, count=shp(1:rank) )
  25760. case default
  25761. write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr
  25762. TRACEBACK; status=1; return
  25763. end select
  25764. IF_NOT_OK_RETURN(status=1)
  25765. ! loop over higher dimensions:
  25766. do i7 = 1, shp(7)
  25767. do i6 = 1, shp(6)
  25768. do i5 = 1, shp(5)
  25769. do i4 = 1, shp(4)
  25770. do i3 = 1, shp(3)
  25771. ! plot index of higer dimensions ?
  25772. if ( rank > 2 ) then
  25773. line = ' (:,:'
  25774. if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3
  25775. if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4
  25776. if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5
  25777. if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6
  25778. if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7
  25779. line = trim(line)//')'
  25780. write (gol,'(a)') trim(line); call goPr
  25781. end if
  25782. ! display matrix:
  25783. do i2 = 1, shp(2)
  25784. ! copy value:
  25785. line = values_c(i2,i3,i4,i5,i6,i7)
  25786. ! display:
  25787. write (gol,'(" `",a,"` ;")') trim(line); call goPr
  25788. end do ! i2
  25789. end do ! i3
  25790. end do ! i4
  25791. end do ! i5
  25792. end do ! i6
  25793. end do ! i7
  25794. ! clear:
  25795. deallocate( values_c, stat=status )
  25796. IF_NOT_OK_RETURN(status=1)
  25797. ! integer values:
  25798. case ( MDF_BYTE, MDF_SHORT, MDF_INT )
  25799. ! storage:
  25800. allocate( values_i4(shp(1),shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status )
  25801. IF_NOT_OK_RETURN(status=1)
  25802. ! read:
  25803. select case ( rank )
  25804. case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,1,1,1,1,1,1), status )
  25805. case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,1,1,1,1,1), status )
  25806. case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,1,1,1,1), status )
  25807. case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,1,1,1), status )
  25808. case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,1,1), status )
  25809. case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,:,1), status )
  25810. case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,:,:), status )
  25811. case default
  25812. write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr
  25813. TRACEBACK; status=1; return
  25814. end select
  25815. IF_NOT_OK_RETURN(status=1)
  25816. ! loop over higher dimensions:
  25817. do i7 = 1, shp(7)
  25818. do i6 = 1, shp(6)
  25819. do i5 = 1, shp(5)
  25820. do i4 = 1, shp(4)
  25821. do i3 = 1, shp(3)
  25822. ! plot index of higer dimensions ?
  25823. if ( rank > 2 ) then
  25824. line = ' (:,:'
  25825. if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3
  25826. if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4
  25827. if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5
  25828. if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6
  25829. if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7
  25830. line = trim(line)//')'
  25831. write (gol,'(a)') trim(line); call goPr
  25832. end if
  25833. ! display matrix:
  25834. do i2 = 1, shp(2)
  25835. line = ''
  25836. do i1 = 1, shp(1)
  25837. !! not all ?
  25838. !if ( i1 > 10 ) then
  25839. ! line = trim(line)//' ...'
  25840. ! exit
  25841. !end if
  25842. ! add seperation if necessary:
  25843. if ( i1 > 1 ) line = trim(line)//','
  25844. ! dump value:
  25845. write (val,*) values_i4(i1,i2,i3,i4,i5,i6,i7)
  25846. ! shift to left:
  25847. val = adjustl(val)
  25848. ! add to line:
  25849. line = trim(line)//' '//trim(val)
  25850. ! add type indicator if necessary:
  25851. if ( xtype == MDF_BYTE ) line = trim(line)//'b'
  25852. if ( xtype == MDF_SHORT ) line = trim(line)//'s'
  25853. ! line too long already ?
  25854. if ( len_trim(line) > 72 ) then
  25855. ! display:
  25856. write (gol,'(" ",a," ;")') trim(line); call goPr
  25857. ! empty:
  25858. line = ''
  25859. end if
  25860. end do ! i1
  25861. ! display:
  25862. if ( len_trim(line) > 0 ) then
  25863. write (gol,'(" ",a," ;")') trim(line); call goPr
  25864. end if
  25865. end do ! i2
  25866. end do ! i3
  25867. end do ! i4
  25868. end do ! i5
  25869. end do ! i6
  25870. end do ! i7
  25871. ! clear:
  25872. deallocate( values_i4, stat=status )
  25873. IF_NOT_OK_RETURN(status=1)
  25874. ! real values:
  25875. case ( MDF_FLOAT, MDF_DOUBLE )
  25876. ! storage:
  25877. allocate( values_r8(shp(1),shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status )
  25878. IF_NOT_OK_RETURN(status=1)
  25879. ! read:
  25880. select case ( rank )
  25881. case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,1,1,1,1,1,1), status )
  25882. case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,1,1,1,1,1), status )
  25883. case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,1,1,1,1), status )
  25884. case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,1,1,1), status )
  25885. case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,1,1), status )
  25886. case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,:,1), status )
  25887. case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,:,:), status )
  25888. case default
  25889. write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr
  25890. TRACEBACK; status=1; return
  25891. end select
  25892. IF_NOT_OK_RETURN(status=1)
  25893. ! loop over higher dimensions:
  25894. do i7 = 1, shp(7)
  25895. do i6 = 1, shp(6)
  25896. do i5 = 1, shp(5)
  25897. do i4 = 1, shp(4)
  25898. do i3 = 1, shp(3)
  25899. ! plot index of higer dimensions ?
  25900. if ( rank > 2 ) then
  25901. line = ' (:,:'
  25902. if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3
  25903. if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4
  25904. if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5
  25905. if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6
  25906. if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7
  25907. line = trim(line)//')'
  25908. write (gol,'(a)') trim(line); call goPr
  25909. end if
  25910. ! display matrix:
  25911. do i2 = 1, shp(2)
  25912. line = ''
  25913. do i1 = 1, shp(1)
  25914. !! not all ?
  25915. !if ( i1 > 10 ) then
  25916. ! line = trim(line)//' ...'
  25917. ! exit
  25918. !end if
  25919. ! add seperation if necessary:
  25920. if ( i1 > 1 ) line = trim(line)//','
  25921. ! dump value:
  25922. write (val,*) values_r8(i1,i2,i3,i4,i5,i6,i7)
  25923. ! remove tailing zeros:
  25924. do l = len_trim(val), 1, -1
  25925. if ( val(l:l) /= '0' ) exit
  25926. val(l:l) = ' '
  25927. end do
  25928. ! shift to left:
  25929. val = adjustl(val)
  25930. ! add to line:
  25931. line = trim(line)//' '//trim(val)
  25932. ! add type indicator if necessary:
  25933. if ( xtype == MDF_FLOAT ) line = trim(line)//'f'
  25934. ! line too long already ?
  25935. if ( len_trim(line) > 72 ) then
  25936. ! display:
  25937. write (gol,'(" ",a," ;")') trim(line); call goPr
  25938. ! empty:
  25939. line = ''
  25940. end if
  25941. end do ! i1
  25942. ! display:
  25943. if ( len_trim(line) > 0 ) then
  25944. write (gol,'(" ",a," ;")') trim(line); call goPr
  25945. end if
  25946. end do ! i2
  25947. end do ! i3
  25948. end do ! i4
  25949. end do ! i5
  25950. end do ! i6
  25951. end do ! i7
  25952. ! clear:
  25953. deallocate( values_r8, stat=status )
  25954. IF_NOT_OK_RETURN(status=1)
  25955. case default
  25956. write (gol,'("INTERNAL - unsupported data type : ",i6)') xtype; call goErr
  25957. TRACEBACK; status=1; return
  25958. end select
  25959. ! ok
  25960. status = 0
  25961. end subroutine MDF_Show_Data
  25962. end module MDF