New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
pseudo.f90 in vendors/XMLF90/current/doc/Examples/xpath – NEMO

source: vendors/XMLF90/current/doc/Examples/xpath/pseudo.f90 @ 1967

Last change on this file since 1967 was 1967, checked in by flavoni, 14 years ago

importing XMLF90 vendor

File size: 8.4 KB
Line 
1program pseudo_read
2!
3! Example of XPATH-lite  processing for pseudo xml file
4! Shows the use of constrained searches, context delegation, etc.
5!
6use flib_xpath
7use m_pseudo_types
8
9type(dictionary_t) :: attributes
10type(xml_t) :: fxml
11
12type(pseudo_t), target, save :: pseudo
13type(grid_t),  save          :: global_grid
14!
15! Pointers to make it easier to manage the data
16!
17type(header_t),  pointer   :: hp
18type(vps_t),  pointer      :: pp
19
20integer               :: status, ndata
21character(len=200)    :: value
22
23!-----------------------------------------------------------------
24call open_xmlfile("pseudo.xml",fxml,status)
25if (status /=0) call die("Cannot open file.")
26
27!call enable_debug(sax=.false.)
28
29!
30!------------------------------------------------------------
31! Root element with version information
32!
33call get_node(fxml,path="/pseudo",attributes=attributes,status=status)
34if (status /= 0)  call die("Cannot find pseudo element")
35
36         call get_value(attributes,"version",value,status)
37         if (value == "0.5") then
38            print *, "Processing a PSEUDO version 0.5 XML file"
39         else
40            call die("Can only work with PSEUDO version 0.5 XML files")
41         endif
42
43!------------------------------------------------------------
44! Header
45!
46call get_node(fxml,path="/pseudo/header", &
47              attributes=attributes,status=status)
48if (status /= 0)  call die("Cannot find /pseudo/header")
49
50         hp => pseudo%header
51         
52         call get_value(attributes,"symbol",hp%symbol,status)
53         if (status /= 0 ) call die("Cannot determine atomic symbol")
54
55         call get_value(attributes,"zval",value,status)
56         if (status /= 0 ) call die("Cannot determine zval")
57         read(unit=value,fmt=*) hp%zval
58!
59         call get_value(attributes,"creator",hp%creator,status)
60         if (status /= 0 ) hp%creator="unknown"
61
62         call get_value(attributes,"flavor",hp%flavor,status)
63         if (status /= 0 ) hp%flavor="unknown"
64
65         call get_value(attributes,"relativistic",value,status)
66         if (status /= 0 ) value = "no"
67         hp%relativistic = (value == "yes")
68
69         call get_value(attributes,"polarized",value,status)
70         if (status /= 0 ) value = "no"
71         hp%polarized = (value == "yes")
72
73         call get_value(attributes,"core-corrections", &
74                                    hp%core_corrections,status)
75         if (status /= 0 ) hp%core_corrections = "nc"
76
77
78!------------------------------------------------------------
79! Global grid information
80!
81call rewind_xmlfile(fxml)
82call get_node(fxml,path="/pseudo/grid", &
83              attributes=attributes,status=status)
84
85if (status == 0)  then
86   print *, "This file has a global grid... "
87   call get_grid_data(attributes,global_grid)
88else
89   global_grid%npts = 0          ! To flag absence of global grid info
90endif
91!
92!------------------------------------------------------------
93! Valence charge
94!
95call rewind_xmlfile(fxml)
96!
97call mark_node(fxml,path="/pseudo/valence-charge", &
98              attributes=attributes,status=status)
99if (status == 0)  then
100   !
101   !  Get the data (and possible private grid)
102   !
103   call get_radfunc_data(fxml,global_grid,pseudo%valence_charge)
104endif
105!
106!------------------------------------------------------------
107! Core charge
108!
109call rewind_xmlfile(fxml)
110!
111call mark_node(fxml,path="/pseudo/pseudocore-charge", &
112              attributes=attributes,status=status)
113if (status == 0)  then
114   !
115   !  Get the data (and possible private grid)
116   !
117   call get_radfunc_data(fxml,global_grid,pseudo%core_charge)
118endif
119!
120!------------------------------------------------------------
121! Semilocal pseudopotentials
122!
123call rewind_xmlfile(fxml)
124!
125call get_node(fxml,path="//semilocal", &
126              attributes=attributes,status=status)
127if (status /= 0)  call die("Cannot find semilocal element")
128
129         call get_value(attributes,"npots-down",value,status)
130         if (status /= 0 ) call die("Cannot determine npots-down")
131         read(unit=value,fmt=*) pseudo%npots_down
132
133         call get_value(attributes,"npots-up",value,status)
134         if (status /= 0 ) call die("Cannot determine npots-up")
135         read(unit=value,fmt=*) pseudo%npots_up
136
137!
138! Loop over pseudopotentials
139!
140pseudo%npots = 0
141do
142   !
143   ! This will search for all the 'vps' elements, marking the context
144   ! in turn
145   !
146      call mark_node(fxml,path="//vps",attributes=attributes,status=status)
147      if (status /= 0) exit          ! exit loop
148
149         pseudo%npots = pseudo%npots + 1
150         pp => pseudo%pot(pseudo%npots)
151
152         call get_value(attributes,"l",value,status)
153         if (status /= 0 ) call die("Cannot determine l for Vps")
154         read(unit=value,fmt=*) pp%l
155
156         call get_value(attributes,"principal-n",value,status)
157         if (status /= 0 ) call die("Cannot determine n for Vps")
158         read(unit=value,fmt=*) pp%n
159
160         call get_value(attributes,"cutoff",value,status)
161         if (status /= 0 ) call die("Cannot determine cutoff for Vps")
162         read(unit=value,fmt=*) pp%cutoff
163
164         call get_value(attributes,"occupation",value,status)
165         if (status /= 0 ) call die("Cannot determine occupation for Vps")
166         read(unit=value,fmt=*) pp%occupation
167
168         call get_value(attributes,"spin",value,status)
169         if (status /= 0 ) call die("Cannot determine spin for Vps")
170         read(unit=value,fmt=*) pp%spin
171
172         !
173         !  Get the data (and possible private grid)
174         !
175         call get_radfunc_data(fxml,global_grid,pp%V)
176         !
177         ! After context delegation it is essential to sync the handle
178         ! (or to rewind it)
179         !
180         call sync_xmlfile(fxml,status)
181enddo
182
183!
184!  Show some of the information
185!
186call dump_pseudo(pseudo)
187
188!=======================================================================
189CONTAINS
190
191!-----------------------------------------------------------------------
192subroutine get_radfunc_data(context,global_grid,rp)
193!
194! Example of routine which packages parsing functionality for a
195! common element. The <radfunc> element can appear under <vps>,
196! <valence-charge>, and <pseudocore-charge> elements.
197! In all cases the parsing steps are exactly  the same.
198! This routine accepts the appropriate context handle and returns
199! the data structure.
200!
201type(xml_t), intent(in)      :: context
202type(grid_t), intent(in)     :: global_grid
203type(radfunc_t), intent(out) :: rp
204
205type(xml_t)           :: ff
206character(len=2000)   :: pcdata
207
208ff = context           ! It inherits the "ancestor element" markings, etc
209
210      call get_node(ff,path="./radfunc/grid", &
211              attributes=attributes,status=status)
212      if (status == 0)  then
213         print *, " >> local grid found"
214         call get_grid_data(attributes,rp%grid)
215      else
216         rp%grid = global_grid
217      endif
218
219      ff = context
220      call sync_xmlfile(ff,status)  ! Go back to beginning of context
221
222      call get_node(ff,path="./radfunc/data", &
223              pcdata=pcdata,status=status)
224      if (status < 0) call die("Cannot find data element")
225      if (status > 0) call die("Not enough space for pcdata")
226      if (rp%grid%npts == 0) call die("Need grid information!")
227      allocate(rp%data(rp%grid%npts))
228      ndata = 0             ! To start the build up
229      call build_data_array(pcdata,rp%data,ndata)
230      if (ndata /= size(rp%data)) STOP "npts mismatch"
231end subroutine get_radfunc_data
232!-----------------------------------------------------------------------
233subroutine get_grid_data(attributes,grid)
234type(dictionary_t), intent(in)  :: attributes
235type(grid_t), intent(out)       :: grid
236
237         call get_value(attributes,"type",grid%type,status)
238         if (status /= 0 ) call die("Cannot determine grid type")
239
240         call get_value(attributes,"npts",value,status)
241         if (status /= 0 ) call die("Cannot determine grid npts")
242         read(unit=value,fmt=*) grid%npts
243
244         call get_value(attributes,"scale",value,status)
245         if (status /= 0 ) call die("Cannot determine grid scale")
246         read(unit=value,fmt=*) grid%scale
247
248         call get_value(attributes,"step",value,status)
249         if (status /= 0 ) call die("Cannot determine grid step")
250         read(unit=value,fmt=*) grid%step
251
252end subroutine get_grid_data
253
254!-----------------------------------------------------------------------
255      subroutine die(str)
256      character(len=*), intent(in), optional   :: str
257      if (present(str)) then
258         write(unit=0,fmt="(a)") trim(str)
259      endif
260      write(unit=0,fmt="(a)") "Stopping Program"
261      stop
262      end subroutine die
263
264end program pseudo_read
265
266
267
268
269
270
271
272
273
274
275
276
277
Note: See TracBrowser for help on using the repository browser.