GRIDMAN
grid managment library
index.f
Go to the documentation of this file.
1 C> @file index.f
2 C> Methods of the data-type GRIDMAN_INDEX, see gridman.f
3 C GRIDMAN, grid managment library. Author: Vladislav Kotov, v.kotov@fz-juelich.de
4 
5 ! Copyright (c) 2017 Forschungszentrum Juelich GmbH
6 ! Vladislav Kotov
7 !
8 ! This file is part of GRIDMAN.
9 !
10 ! GRIDMAN is free software: you can redistribute it and/or modify
11 ! it under the terms of the GNU General Public License as published by
12 ! the Free Software Foundation, either version 3 of the License, or
13 ! (at your option) any later version.
14 !
15 ! GRIDMAN is distributed in the hope that it will be useful,
16 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ! GNU General Public License for more details.
19 !
20 ! You should have received a copy of the GNU General Public License
21 ! along with GRIDMAN. If not, see <http://www.gnu.org/licenses/>.
22 
23 C *****************************************************************************************
24 C> Allocate index object
25 C *****************************************************************************************
26 C> WARNING: INDEX will be overwritten if alreay exists!
27  SUBROUTINE gridman_index_allocate(INDEX,NINDEX,NELEMENTS,IERR)
28  USE gridman,ONLY:gridman_index,gridman_sp,
29  u gridman_dbg,gridman_unit
30  USE gridman_lib,ONLY:gridman_index_deallocate
31  IMPLICIT NONE
33  TYPE(gridman_index) :: INDEX
35  INTEGER,INTENT(IN) :: NINDEX
37  INTEGER(GRIDMAN_SP),INTENT(IN) :: NELEMENTS
39  INTEGER,INTENT(OUT) :: IERR
40 
41  INTEGER :: ST
42 
43  IF(gridman_dbg)
44  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_ALLOCATE"
45 
46  ierr=0
47 
48  CALL gridman_index_deallocate(index,ierr)
49  IF(ierr.NE.0) THEN
50  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ALLOCATE: ",
51  w "could not perform deallocation"
52  ierr=200
53  RETURN
54  END IF
55 
56  IF(nindex.LT.1.OR.nelements.LT.1) THEN
57  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ALLOCATE: ",
58  w "incorrect dimension - array size"
59  WRITE(gridman_unit,*) " NINDEX, NELEMENTS ",nindex,nelements
60  ierr=100
61  RETURN
62  END IF
63 
64  index%NINDEX=nindex
65  index%NELEMENTS=nelements
66 
67  ALLOCATE(index%INDEXES(0:nindex,nelements),stat=st)
68  IF(st.NE.0) THEN
69  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ALLOCATE: ",
70  w "cannot allocate the table of indices"
71  WRITE(gridman_unit,*) " NINDEX, NELEMENTS ",nindex,nelements
72  ierr=200
73  RETURN
74  END IF
75 
76  ALLOCATE(index%COLUMNS(nindex),stat=st)
77  IF(st.NE.0) THEN
78  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ALLOCATE: ",
79  w "cannot allocate the names of columns"
80  WRITE(gridman_unit,*) " NINDEX",nindex
81  ierr=200
82  RETURN
83  END IF
84 
85 C DEFAULTS
86  index%DESCRIPTION='Created by GRIDMAN_INDEX_ALLOCATE'
87  index%COLUMNS='NOT_DEFINED'
88 
89  IF(gridman_dbg)
90  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_ALLOCATE finished"
91 
92  END SUBROUTINE gridman_index_allocate
93 
94 C *****************************************************************************************
95 C> Allocate index object
96 C *****************************************************************************************
97  SUBROUTINE gridman_index_deallocate(INDEX,IERR)
98  USE gridman,ONLY:gridman_index,gridman_dbg,gridman_unit
99  IMPLICIT NONE
101  TYPE(gridman_index) :: INDEX
103  INTEGER,INTENT(OUT) :: IERR
104 
105  INTEGER :: ST
106 
107  IF(gridman_dbg)
108  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_DEALLOCATE"
109 
110  ierr=0
111 
112  IF(ALLOCATED(index%INDEXES)) THEN
113  DEALLOCATE(index%INDEXES,stat=st)
114  IF(st.NE.0) THEN
115  ierr=-200
116  WRITE(gridman_unit,*)
117  w "WARNING from GRIDMAN_INDEX_DEALLOCATE: ",
118  w "can not deallocate INDEXES"
119  END IF
120  END IF
121 
122  IF(ALLOCATED(index%COLUMNS)) THEN
123  DEALLOCATE(index%COLUMNS,stat=st)
124  IF(st.NE.0) THEN
125  ierr=-200
126  WRITE(gridman_unit,*)
127  w "WARNING from GRIDMAN_INDEX_DEALLOCATE: ",
128  w "can not deallocate COLUMNS"
129  END IF
130  END IF
131 
132  IF(gridman_dbg)
133  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_DEALLOCATE finished"
134 
135  END SUBROUTINE gridman_index_deallocate
136 
137 C *****************************************************************************************
138 C> Check index object
139 C *****************************************************************************************
140 C>
141 C> - RES=0: the index is correct
142 C> - RES=1: index is not allocated
143 C> - RES=2: dimensions are incorrect
144 C> - RES=3: low array bounds are incorrect
145 C> - RES=4: upper array bounds are incorrect
146 C> - RES=5: allocation of COLUMNS is incorrect
147 C
148  SUBROUTINE gridman_index_check(INDEX,RES,IERR)
149  USE gridman,ONLY:gridman_index,gridman_sp,
150  u gridman_dbg,gridman_unit
151  IMPLICIT NONE
152  INTRINSIC ALLOCATED,lbound,ubound
154  TYPE(gridman_index) :: INDEX
156  INTEGER,INTENT(OUT) :: RES
158  INTEGER,INTENT(OUT) :: IERR
159 
160  INTEGER(GRIDMAN_SP) :: I1,I2
161 
162  IF(gridman_dbg)
163  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_CHECK"
164 
165  ierr=0
166 
167  IF(.NOT.ALLOCATED(index%INDEXES)) THEN
168  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
169  w "index is not allocated"
170  res=1
171  RETURN
172  END IF
173 
174  IF(index%NINDEX.LT.1.OR.index%NELEMENTS.LT.1) THEN
175  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
176  w "incorrect dimensions"
177  WRITE(gridman_unit,*) " NINDEX, NELEMENTS ",
178  w index%NINDEX, index%NELEMENTS
179  res=2
180  RETURN
181  END IF
182 
183  i1=lbound(index%INDEXES,1)
184  i2=lbound(index%INDEXES,2)
185  IF(i1.NE.0.OR.i2.NE.1) THEN
186  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
187  w "incorrect low index of array"
188  WRITE(gridman_unit,*) " Must be ",0,1
189  WRITE(gridman_unit,*) " LBOUND(INDEX%INDEXES) ",i1,i2
190  res=3
191  RETURN
192  END IF
193 
194  i1=ubound(index%INDEXES,1)
195  i2=ubound(index%INDEXES,2)
196  IF(i1.NE.index%NINDEX.OR.i2.NE.index%NELEMENTS) THEN
197  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
198  w "incorrect upper index of array"
199  WRITE(gridman_unit,*) " NINDEX, NELEMENTS ",
200  w index%NINDEX,index%NELEMENTS
201  WRITE(gridman_unit,*) " LBOUND(INDEX%INDEXES) ",i1,i2
202  res=4
203  RETURN
204  END IF
205 
206  IF(.NOT.ALLOCATED(index%COLUMNS)) THEN
207  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
208  w "COLUMNS is not allocated"
209  res=5
210  RETURN
211  END IF
212  i1=lbound(index%COLUMNS,1)
213  i2=ubound(index%COLUMNS,1)
214  IF(i1.NE.1.OR.i2.NE.index%NINDEX) THEN
215  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK: ",
216  w "incorrect allocation of COLUMNS"
217  WRITE(gridman_unit,*) " LBOUND, UBOUND, NINDEX ",
218  w i1,i2,index%NINDEX
219  res=5
220  RETURN
221  END IF
222 
223  res=0
224 
225  IF(gridman_dbg)
226  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_CHECK finished"
227 
228  END SUBROUTINE gridman_index_check
229 
230 C*****************************************************************************************
231 C> Save index object in a file
232 C*****************************************************************************************
233  SUBROUTINE gridman_index_write(INDEX,IOUT,IERR)
234  USE gridman,ONLY:gridman_index,gridman_sp,gridman_length,
235  u gridman_dbg,gridman_unit,gridman_check,
236  u gridman_ver,gridman_lword
237  USE gridman_lib,ONLY:gridman_index_check
238  IMPLICIT NONE
239  INTRINSIC len_trim
241  TYPE(gridman_index) :: INDEX
243  INTEGER,INTENT(IN) :: IOUT
245  INTEGER,INTENT(OUT) :: IERR
246 
247  CHARACTER*32 :: FRM !FORMAT STRING
248  INTEGER(GRIDMAN_SP) :: IEL
249  INTEGER :: I,IO,RES
250 
251  IF(gridman_dbg)
252  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_WRITE"
253 
254  ierr=0
255 
256  IF(gridman_check) THEN
257  CALL gridman_index_check(index,res,ierr)
258  IF(res.NE.0.OR.ierr.GT.0) THEN
259  ierr=100
260  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_WRITE: ",
261  w "incorrect index object"
262  WRITE(gridman_unit,*) " Writing is skipped"
263  RETURN
264  END IF
265  END IF
266 
267  WRITE(iout,'(A)',iostat=io) 'DATA-TYPE GRIDMAN_INDEX'
268  IF(io.NE.0) GOTO 100
269  WRITE(iout,'(A)',iostat=io) 'VERSION'
270  IF(io.NE.0) GOTO 100
271  WRITE(iout,'(I7)',iostat=io) gridman_ver
272  IF(io.NE.0) GOTO 100
273  WRITE(iout,'(A)',iostat=io) "DESCRIPTION_LENGTH, WORD_LENGTH"
274  IF(io.NE.0) GOTO 100
275  WRITE(iout,'(2I6)',iostat=io) gridman_length,gridman_lword
276  IF(io.NE.0) GOTO 100
277  WRITE(iout,'(A)',iostat=io) 'DESCRIPTION'
278  WRITE(frm,210) gridman_length
279  210 FORMAT('(A',i4,')')
280  WRITE(iout,frm,iostat=io) index%DESCRIPTION
281  IF(io.NE.0) GOTO 100
282 
283  WRITE(iout,'(A)',iostat=io) "NINDEX, NELEMENTS"
284  IF(io.NE.0) GOTO 100
285  WRITE(iout,'(2I7)',iostat=io) index%NINDEX,index%NELEMENTS
286  IF(io.NE.0) GOTO 100
287 
288  WRITE(iout,'(A)',iostat=io) "COLUMNS"
289  IF(io.NE.0) GOTO 100
290  WRITE(frm,215) gridman_lword
291  215 FORMAT('(A',i4,')')
292  DO i=1,index%NINDEX
293  WRITE(iout,frm,iostat=io) index%COLUMNS(i)
294  IF(io.NE.0) GOTO 100
295  END DO
296 
297  IF(gridman_dbg)
298  f WRITE(gridman_unit,*) " GRIDMAN_INDEX_WRITE. Header finished"
299 
300  WRITE(iout,'(A)',iostat=io) "INDEXES"
301  IF(io.NE.0) GOTO 100
302  WRITE(frm,220) index%NINDEX+1
303  220 FORMAT('(',i4,'I7)')
304  DO iel=1,index%NELEMENTS
305  WRITE(iout,frm,iostat=io) index%INDEXES(0:index%NINDEX,iel)
306  IF(io.NE.0) GOTO 100
307  END DO
308 
309  WRITE(iout,'(A)',iostat=io) "END OF DATA-TYPE GRIDMAN_INDEX"
310  IF(io.NE.0) GOTO 100
311 
312  IF(gridman_dbg)
313  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_WRITE finished"
314 
315  RETURN
316 
317  100 ierr=300
318  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_WRITE: ",
319  w "can not write to the file"
320  WRITE(gridman_unit,*) " Writing is skipped"
321  END SUBROUTINE gridman_index_write
322 
323 C*****************************************************************************************
324 C> Read index object from file
325 C*****************************************************************************************
326  SUBROUTINE gridman_index_read(INDEX,IIN,IERR)
327  USE gridman,ONLY:gridman_index,gridman_sp,gridman_length,
328  u gridman_unit,gridman_dbg
329  IMPLICIT NONE
330  INTRINSIC len_trim,min
332  TYPE(gridman_index) :: INDEX
334  INTEGER,INTENT(IN) :: IIN
336  INTEGER,INTENT(OUT) :: IERR
337 
338  CHARACTER*32 :: FRM !FORMAT STRING
339  CHARACTER*128 :: SBUFF
340  INTEGER(GRIDMAN_SP) :: IEL,NELEMENTS,VER
341  INTEGER :: I,IO,DESCRIPTION_LENGTH,NINDEX,WORD_LENGTH
342  CHARACTER(LEN=GRIDMAN_LENGTH) :: DESCRIPTION
343 
344  IF(gridman_dbg) WRITE(gridman_unit,*)
345  f "Starting GRIDMAN_INDEX_READ"
346  ierr=0
347 
348  READ(iin,*,iostat=io) sbuff !'DATA-TYPE GRIDMAN_INDEX'
349  IF(io.NE.0) GOTO 100
350  READ(iin,*,iostat=io) sbuff !'VERSION'
351  IF(io.NE.0) GOTO 100
352  READ(iin,'(I7)',iostat=io) ver
353  IF(io.NE.0) GOTO 100
354  READ(iin,*,iostat=io) sbuff !'DESCRIPTION_LENGTH, WORD_LENGTH'
355  IF(io.NE.0) GOTO 100
356  READ(iin,'(2I6)',iostat=io) description_length,word_length
357  IF(io.NE.0) GOTO 100
358  READ(iin,*,iostat=io) sbuff !'DESCRIPTION'
359  IF(io.NE.0) GOTO 100
360  WRITE(frm,210) description_length
361  210 FORMAT('(A',i4,')')
362  READ(iin,frm,iostat=io) description
363  IF(io.NE.0) GOTO 100
364  READ(iin,*,iostat=io) sbuff !'NINDEX, NELEMENTS'
365  IF(io.NE.0) GOTO 100
366  READ(iin,'(3I7)',iostat=io) nindex,nelements
367  IF(io.NE.0) GOTO 100
368 
369  CALL gridman_index_allocate(index,nindex,nelements,ierr)
370  IF(ierr.NE.0) GOTO 1000
371 
372  index%DESCRIPTION=description
373 
374  READ(iin,'(A)',iostat=io) sbuff !'COLUMNS'
375  IF(io.NE.0) GOTO 100
376  WRITE(frm,215) word_length
377  215 FORMAT('(A',i4,')')
378  DO i=1,nindex
379  READ(iin,frm,iostat=io) index%COLUMNS(i)
380  IF(io.NE.0) GOTO 100
381  END DO
382 
383  IF(gridman_dbg)
384  f WRITE(gridman_unit,*) " GRIDMAN_INDEX_READ. Header finished"
385 
386  READ(iin,*,iostat=io) sbuff !'INDEXES'
387  IF(io.NE.0) GOTO 100
388  WRITE(frm,220) index%NINDEX+1
389  220 FORMAT('(',i4,'I7)')
390  DO iel=1,nelements
391  READ(iin,frm,iostat=io) index%INDEXES(0:nindex,iel)
392  IF(io.NE.0) GOTO 100
393  END DO
394 
395  READ(iin,*,iostat=io) sbuff ! END OF DATA-TYPE GRIDMAN_INDEX
396  IF(io.NE.0) GOTO 100
397 
398  IF(gridman_dbg) WRITE(gridman_unit,*)
399  f "GRIDMAN_INDEX_READ finished"
400 
401  RETURN
402 
403  100 ierr=300
404  WRITE(gridman_unit,*) "ERROR in GRIDMAN_UNDEX_READ: ",
405  w "can not read data"
406  RETURN
407  1000 WRITE(gridman_unit,*) "GRIDMAN_INDEX_READ is terminated"
408 
409  END SUBROUTINE gridman_index_read
410 
411 C*****************************************************************************************
412 C> Compare two index objects
413 C*****************************************************************************************
414 C>
415 C> - RES=0: two objects are equivalent
416 C> - RES=1: different dimensions
417 C> - RES=2: different elements
418 C> - RES=3: different indices
419 C> - RES=4: different descriptions
420 C> - RES=5: different description of columns
421 C
422  SUBROUTINE gridman_index_compare(INDEX1,INDEX2,RES,IERR)
423  USE gridman,ONLY:gridman_index,gridman_sp,
424  u gridman_unit,gridman_dbg,gridman_check
425  USE gridman_lib,ONLY:gridman_index_check
426  IMPLICIT NONE
427  INTRINSIC any,llt,lgt,trim
429  TYPE(gridman_index) :: INDEX1
431  TYPE(gridman_index) :: INDEX2
433  INTEGER,INTENT(OUT) :: RES
435  INTEGER,INTENT(OUT) :: IERR
436 
437  INTEGER(GRIDMAN_SP) :: IEL
438  INTEGER :: N,RES0,I
439 
440  IF(gridman_dbg)
441  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_COMPARE"
442 
443  ierr=0
444 
445  IF(gridman_check) THEN
446  CALL gridman_index_check(index1,res0,ierr)
447  IF(res0.NE.0.OR.ierr.GT.0) THEN
448  ierr=100
449  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_COMPARE: ",
450  w "incorrect 1st index object"
451  WRITE(gridman_unit,*) " Comparing is skipped"
452  RETURN
453  END IF
454  CALL gridman_index_check(index2,res0,ierr)
455  IF(res0.NE.0.OR.ierr.GT.0) THEN
456  ierr=100
457  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_COMPARE: ",
458  w "incorrect 2nd index object"
459  WRITE(gridman_unit,*) " Comparing is skipped"
460  RETURN
461  END IF
462  END IF
463 
464  IF(index1%NINDEX.NE.index2%NINDEX.OR.
465  f index1%NELEMENTS.NE.index2%NELEMENTS) THEN
466  WRITE(gridman_unit,*)
467  w "GRIDMAN_INDEX_COMPARE: dimensions are different"
468  WRITE(gridman_unit,*) " INDEX1%NINDEX, INDEX2%NINDEX ",
469  w index1%NINDEX, index2%NINDEX
470  WRITE(gridman_unit,*) " INDEX1%NELEMENTS, INDEX2%NELEMENTS ",
471  w index1%NELEMENTS, index2%NELEMENTS
472  res=1
473  RETURN
474  END IF
475 
476  n=index2%NINDEX
477  DO iel=1,index1%NELEMENTS
478  IF(index1%INDEXES(0,iel).NE.index2%INDEXES(0,iel)) THEN
479  WRITE(gridman_unit,*)
480  w "GRIDMAN_INDEX_COMPARE: index of elements is different"
481  WRITE(gridman_unit,*) " IEL, INDEX1, INDEX2 ",
482  w iel,index1%INDEXES(0,iel),index2%INDEXES(0,iel)
483  res=2
484  RETURN
485  END IF
486  IF(any(index1%INDEXES(1:n,iel).NE.
487  f index2%INDEXES(1:n,iel))) THEN
488  WRITE(gridman_unit,*)
489  w "GRIDMAN_INDEX_COMPARE: indices are different"
490  WRITE(gridman_unit,*) " IEL ",iel
491  WRITE(gridman_unit,*) " INDEX1 ",index1%INDEXES(1:n,iel)
492  WRITE(gridman_unit,*) " INDEX2 ",index2%INDEXES(1:n,iel)
493  res=3
494  RETURN
495  END IF
496  END DO
497 
498  IF(llt(index1%DESCRIPTION,index2%DESCRIPTION).OR.
499  f lgt(index1%DESCRIPTION,index2%DESCRIPTION)) THEN
500  WRITE(gridman_unit,*)
501  w "GRIDMAN_INDEX_COMPARE: descriptions are different"
502  WRITE(gridman_unit,*) " INDEX1%DESCRIPTION ",
503  w trim(index1%DESCRIPTION)
504  WRITE(gridman_unit,*) " INDEX2%DESCRIPTION ",
505  w trim(index2%DESCRIPTION)
506  res=4
507  RETURN
508  END IF
509 
510  DO i=1,n
511  IF(llt(index1%COLUMNS(i),index2%COLUMNS(i)).OR.
512  f lgt(index1%COLUMNS(i),index2%COLUMNS(i))) THEN
513  WRITE(gridman_unit,*)
514  w "GRIDMAN_INDEX_COMPARE: description of columns is different"
515  WRITE(gridman_unit,*) " I ",i
516  WRITE(gridman_unit,*) " INDEX1%COLUMNS(I) ",
517  w trim(index1%COLUMNS(i))
518  WRITE(gridman_unit,*) " INDEX2%COLUMNS(I) ",
519  w trim(index2%COLUMNS(i))
520  res=5
521  RETURN
522  END IF
523  END DO
524 
525  res=0
526 
527  IF(gridman_dbg)
528  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_COMPARE finished"
529 
530  END SUBROUTINE gridman_index_compare
531 
532 C*****************************************************************************************
533 C> Create a copy of the index object
534 C*****************************************************************************************
535 C>
536 C> WARNING: INDEX2 will be overwritten if already exists!
537  SUBROUTINE gridman_index_copy(INDEX2,INDEX1,IERR)
538  USE gridman,ONLY:gridman_index,gridman_unit,
539  u gridman_check,gridman_dbg
540  USE gridman_lib,ONLY:gridman_index_check
541  IMPLICIT NONE
542 C> Original index
543  TYPE(gridman_index) :: INDEX1
544 C> Copy to be created
545  TYPE(gridman_index) :: INDEX2
546 C> Error code
547  INTEGER,INTENT(OUT) :: IERR
548 
549  INTEGER :: RES
550 
551  IF(gridman_dbg)
552  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_COPY"
553 
554 
555  IF(gridman_check) THEN
556  CALL gridman_index_check(index1,res,ierr)
557  IF(res.NE.0.OR.ierr.GT.0) THEN
558  ierr=100
559  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_COPY: ",
560  w "incorrect input index object"
561  RETURN
562  END IF
563  END IF
564 
565  CALL gridman_index_allocate(index2,index1%NINDEX,
566  c index1%NELEMENTS,ierr)
567  IF(ierr.NE.0)
568  f WRITE(gridman_unit,*) "GRIDMAN_INDEX_COPY terminated"
569 
570  index2%INDEXES=index1%INDEXES
571  index2%DESCRIPTION=index1%DESCRIPTION
572  index2%COLUMNS=index1%COLUMNS
573 
574  IF(gridman_dbg)
575  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_COPY finished"
576 
577  END SUBROUTINE gridman_index_copy
578 
579 C*****************************************************************************************
580 C> Check if the same element index appear more than once
581 C****************************************************************************************
582 C>
583 C> Return .TRUE. if same element index appears more than once,
584 C> and .FALSE. otherwise
585  FUNCTION gridman_index_repeated_elements(INDEX,IERR)
586  USE gridman,ONLY:gridman_index,gridman_sp,
587  u gridman_unit,gridman_dbg
588  IMPLICIT NONE
590  TYPE(gridman_index) :: INDEX
592  INTEGER,INTENT(OUT) :: IERR
593 
594  LOGICAL :: GRIDMAN_INDEX_REPEATED_ELEMENTS
595 
596  INTEGER(GRIDMAN_SP) :: I,IEL,NMIN,NMAX
597  LOGICAL,ALLOCATABLE :: LELEMENT(:)
598  INTEGER :: ST
599 
600  IF(gridman_dbg)
601  w WRITE(gridman_unit,*) "Staring GRIDMAN_INDEX_REPEATED_ELEMENTS"
602 
603  ierr=0
604 
605  nmin=minval(index%INDEXES(0,:))
606  nmax=maxval(index%INDEXES(0,:))
607 
608  ALLOCATE(lelement(nmin:nmax),stat=st)
609  IF(st.NE.0) THEN
610  ierr=200
611  WRITE(gridman_unit,*)
612  w "ERROR in GRIDMAN_INDEX_REPEATED_ELEMENTS: ",
613  w "cannot allocate temporary array"
614  WRITE(gridman_unit,*) " NMIN, NMAX ",nmin,nmax
615  gridman_index_repeated_elements=.true.
616  RETURN
617  END IF
618 
619  lelement=.true.
620  DO i=1,index%NELEMENTS
621  iel=index%INDEXES(0,i)
622  IF(lelement(iel)) THEN
623  lelement(iel)=.false.
624  ELSE
625  gridman_index_repeated_elements=.true.
626  RETURN
627  END IF
628  END DO
629  DEALLOCATE(lelement)
630 
631  gridman_index_repeated_elements=.false.
632 
633  IF(gridman_dbg)
634  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_REPEATED_ELEMENTS finished"
635 
636  END FUNCTION gridman_index_repeated_elements
637 
638 
639 C*****************************************************************************************
640 C> Create an aray which maps elements into the table of indices
641 C****************************************************************************************
642  SUBROUTINE gridman_index_elmap(ELMAP,NMIN,NMAX,INDEX,IERR)
643  USE gridman,ONLY:gridman_index,gridman_sp,
644  u gridman_unit,gridman_dbg,gridman_check
645  USE gridman_lib,ONLY:gridman_index_check,
646  u gridman_index_repeated_elements
647  IMPLICIT NONE
648  INTRINSIC ALLOCATED,minval,maxval
657  INTEGER(GRIDMAN_SP),ALLOCATABLE :: ELMAP(:)
659  INTEGER(GRIDMAN_SP),INTENT(OUT) :: NMIN
661  INTEGER(GRIDMAN_SP),INTENT(OUT) :: NMAX
663  TYPE(gridman_index) :: INDEX
665  INTEGER,INTENT(OUT) :: IERR
666 
667  INTEGER(GRIDMAN_SP) :: I,IEL
668  INTEGER :: RES,ST
669 
670  IF(gridman_dbg)
671  w WRITE(gridman_unit,*) "Staring GRIDMAN_INDEX_ELMAP"
672 
673  ierr=0
674 
675  IF(gridman_check) THEN
676  CALL gridman_index_check(index,res,ierr)
677  IF(res.NE.0.OR.ierr.GT.0) THEN
678  ierr=100
679  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ELMAP: ",
680  w "incorrect index object"
681  RETURN
682  END IF
683  END IF
684 
685  IF(gridman_index_repeated_elements(index,ierr)) THEN
686  ierr=150
687  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ELMAP: ",
688  w "index has repeated elements"
689  WRITE(gridman_unit,*)
690  w " Elements mapping can be generated only if"
691  WRITE(gridman_unit,*)
692  w " only one combination of indices is defined for each element"
693  RETURN
694  END IF
695 
696  nmin=minval(index%INDEXES(0,:))
697  nmax=maxval(index%INDEXES(0,:))
698 
699  IF(ALLOCATED(elmap)) THEN
700  DEALLOCATE(elmap,stat=st)
701  IF(st.NE.0) THEN
702  ierr=200
703  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ELMAP: ",
704  w "cannot re-allocate memory"
705  RETURN
706  END IF
707  END IF
708  ALLOCATE(elmap(nmin:nmax),stat=st)
709  IF(st.NE.0) THEN
710  ierr=200
711  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_ELMAP: ",
712  w "cannot allocate memory"
713  WRITE(gridman_unit,*) " MIN, MAX ",nmin,nmax
714  RETURN
715  END IF
716 
717  elmap=0
718  DO i=1,index%NELEMENTS
719  iel=index%INDEXES(0,i)
720  elmap(iel)=i
721  END DO
722 
723  IF(gridman_dbg)
724  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_ELMAP finished"
725  END SUBROUTINE gridman_index_elmap
726 
727 C*****************************************************************************************
728 C> Create index table for "one-to-one" mapping
729 C****************************************************************************************
730 C>
731 C> WARNING: INDEX is re-allocated if already exists
732  SUBROUTINE gridman_index_create121(INDEX,N,IERR)
733  USE gridman,ONLY:gridman_index,gridman_sp,gridman_unit,
734  u gridman_check,gridman_dbg
735  USE gridman_lib,ONLY:gridman_index_allocate,gridman_index_check
736  IMPLICIT NONE
738  TYPE(gridman_index) :: INDEX
740  INTEGER(GRIDMAN_SP) ,INTENT(IN) :: N
742  INTEGER,INTENT(OUT) :: IERR
743 
744  INTEGER :: RES
745  INTEGER(GRIDMAN_SP) :: IE
746 
747  IF(gridman_dbg)
748  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_CREATE121"
749 
750  ierr=0
751 
752  CALL gridman_index_allocate(index,1,n,ierr)
753  IF(ierr.NE.0) THEN
754  WRITE(gridman_unit,*) "GRIDMAN_INDEX_CREATE121 terminated"
755  RETURN
756  END IF
757 
758  DO ie=1,n
759  index%INDEXES(0,ie)=ie
760  index%INDEXES(1,ie)=ie
761  END DO
762 
763  index%DESCRIPTION="Created by GRIDMAN_INDEX_CREATE121"
764  index%COLUMNS(1)="ICELL"
765 
766  IF(gridman_check) THEN
767  CALL gridman_index_check(index,res,ierr)
768  IF(res.NE.0.OR.ierr.GT.0) THEN
769  ierr=400
770  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_CREATE121: ",
771  w "incorrect resulting index object"
772  RETURN
773  END IF
774  END IF
775 
776  IF(gridman_dbg)
777  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_CREATE121 finished"
778  END SUBROUTINE gridman_index_create121
779 
780 C*****************************************************************************************
781 C> Transform indices of elements - IND(0,:)
782 C>
783 C*****************************************************************************************
784 C> In IND(0,:) indices IMAP12(1,:) are converted into IMAP12(2,:).
785 C> If IND(0,:) is not found in IMAP12(1,:), then the line is not taken
786 C> into the transformed index.
787  SUBROUTINE gridman_index_transform(INDEX2,INDEX1,IMAP12,N12,IERR)
788  USE gridman,ONLY:gridman_index,gridman_unit,gridman_sp,
789  u gridman_check,gridman_dbg
790  USE gridman_lib,ONLY:gridman_index_check
791  IMPLICIT NONE
792 C> Transformed index
793  TYPE(gridman_index) :: INDEX2
794 C> Original index
795  TYPE(gridman_index) :: INDEX1
796 C> Transformation table: IMAP12(1,:) -> IMAP12(2,:)
797  INTEGER(GRIDMAN_SP),INTENT(IN) :: IMAP12(2,n12)
798 C> Length of the transformation table
799  INTEGER(GRIDMAN_SP),INTENT(IN) :: N12
800 C> Error code
801  INTEGER,INTENT(OUT) :: IERR
802 
803  INTEGER(GRIDMAN_SP) :: N,IE,I,IE0,IE1,IE2
804  INTEGER :: RES
805 
806  IF(gridman_dbg)
807  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_TRANSFORM"
808 
809  ierr=0
810 
811  IF(gridman_check) THEN
812  CALL gridman_index_check(index1,res,ierr)
813  IF(res.NE.0.OR.ierr.GT.0) THEN
814  ierr=100
815  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_TRANSFORM: ",
816  w "incorrect index object"
817  RETURN
818  END IF
819  END IF
820 
821  n=0
822  DO ie=1,index1%NELEMENTS
823  ie0=index1%INDEXES(0,ie)
824  DO i=1,n12
825  ie1=imap12(1,i)
826  IF(ie1.EQ.ie0) THEN
827  ie2=imap12(2,i)
828  n=n+1
829  END IF
830  END DO
831  END DO
832 
833  CALL gridman_index_allocate(index2,index1%NINDEX,n,ierr)
834  IF(ierr.NE.0) THEN
835  WRITE(gridman_unit,*) "GRIDMAN_INDEX_TRANSFORM terminated"
836  RETURN
837  END IF
838 
839  n=0
840  DO ie=1,index1%NELEMENTS
841  ie0=index1%INDEXES(0,ie)
842  DO i=1,n12
843  ie1=imap12(1,i)
844  IF(ie1.EQ.ie0) THEN
845  ie2=imap12(2,i)
846  n=n+1
847  index2%INDEXES(0,n)=ie2
848  index2%INDEXES(1:,n)=index1%INDEXES(1:,ie)
849  END IF
850  END DO
851  END DO
852 
853  index2%DESCRIPTION=index1%DESCRIPTION
854  index2%COLUMNS=index1%COLUMNS
855 
856  CALL gridman_index_check(index2,res,ierr)
857  IF(res.NE.0.OR.ierr.GT.0) THEN
858  ierr=400
859  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_TRANSFORM: ",
860  w "the resulting index object is incorrect "
861  RETURN
862  END IF
863 
864  IF(gridman_dbg)
865  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_TRANSFORM completed"
866 
867  END SUBROUTINE gridman_index_transform
868 
869 
870 C*****************************************************************************************
871 C> Merge INDEX2 into INDEX1
872 C*****************************************************************************************
873 C>
874 C> "Merging" means that elements of INDEX1 are taken without changes.
875 C> Elements of INDEX2 which do not yet appear in INDEX1 added.
876 C> Only indexes with equal number of columns (NINDEX) can be merged
877 C>
878 C> WARNING: INDEX will be overwritten if alreay exists!
879  SUBROUTINE gridman_index_merge(INDEX,INDEX1,INDEX2,IERR)
880  USE gridman,ONLY:gridman_index,gridman_unit,gridman_sp,
881  u gridman_check,gridman_dbg
882  USE gridman_lib,ONLY:gridman_index_check,
883  u gridman_index_allocate,
884  u gridman_index_deallocate
885  INTRINSIC minval,maxval,lgt,llt,trim
886 C> Resulting index object
887  TYPE(gridman_index) ::INDEX
888 C> Index object which stay conserved
889  TYPE(gridman_index) ::INDEX1
890 C> Index object which is merged into INDEX1
891  TYPE(gridman_index) ::INDEX2
892 C> Error code
893  INTEGER,INTENT(OUT) :: IERR
894 
895  LOGICAL,ALLOCATABLE :: LTAKE(:)
896  INTEGER(GRIDMAN_SP) :: IEMIN,IEMAX,I,IE,N,K
897  INTEGER :: J,ST,RES
898 
899  IF(gridman_dbg)
900  w WRITE(gridman_unit,*) "Starting GRIDMAN_INDEX_MERGE"
901 
902  ierr=0
903 
904  IF(gridman_check) THEN
905  CALL gridman_index_check(index1,res,ierr)
906  IF(res.NE.0.OR.ierr.GT.0) THEN
907  ierr=100
908  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_MERGE: ",
909  w "incorrect 1st object"
910  RETURN
911  END IF
912  CALL gridman_index_check(index2,res,ierr)
913  IF(res.NE.0.OR.ierr.GT.0) THEN
914  ierr=100
915  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_MERGE: ",
916  w "incorrect 2nd object"
917  RETURN
918  END IF
919  END IF
920 
921  IF(index1%NINDEX.NE.index2%NINDEX) THEN
922  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_MERGE: ",
923  w "indexes have different dimensions"
924  WRITE(gridman_unit,*) " NINDEX1, NINDEX2 ",
925  w index1%NINDEX,index2%NINDEX
926  ierr=100
927  RETURN
928  END IF
929 
930  iemin=minval(index2%INDEXES(0,:))
931  iemax=maxval(index2%INDEXES(0,:))
932 
933  ALLOCATE(ltake(iemin:iemax),stat=st)
934  IF(st.NE.0) THEN
935  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_MERGE: ",
936  w "cannot allocate temporary array"
937  WRITE(gridman_unit,*) " IEMIN, IEMAX ",iemin,iemax
938  ierr=200
939  RETURN
940  END IF
941 
942 C Elements which appear in INDEX1
943 C will not be replaced by elements from INDEX2
944  ltake=.true.
945  DO i=1,index1%NELEMENTS
946  ie=index1%INDEXES(0,i)
947  IF(ie.GE.iemin.AND.ie.LE.iemax) ltake(ie)=.false.
948  END DO
949 C Count the number of elements which will be taken from INDEX2
950  n=index1%NELEMENTS
951  DO i=1,index2%NELEMENTS
952  ie=index2%INDEXES(0,i)
953  IF(ltake(ie)) n=n+1
954  END DO
955 
956  CALL gridman_index_allocate(index,index1%NINDEX,n,ierr)
957  IF(ierr.NE.0) THEN
958  WRITE(gridman_unit,*) "GRIDMAN_INDEX_MERGE terminated"
959  DEALLOCATE(ltake)
960  RETURN
961  END IF
962 
963 C Take elements from INDEX1
964  index%INDEXES(:,1:index1%NELEMENTS)=index1%INDEXES
965 C Take elements from INDEX2
966  k=index1%NELEMENTS
967  DO i=1,index2%NELEMENTS
968  ie=index2%INDEXES(0,i)
969  IF(ltake(ie)) THEN
970  k=k+1
971  index%INDEXES(:,k)=index2%INDEXES(:,i)
972  END IF
973  END DO
974 
975  DEALLOCATE(ltake,stat=st)
976  IF(st.NE.0) THEN
977  WRITE(gridman_unit,*) "WARNING from GRIDMAN_INDEX_MERGE: ",
978  w "problems with memory deallocation"
979  ierr=-200
980  END IF
981 
982 C Description
983  IF(lgt(index1%DESCRIPTION,index2%DESCRIPTION).OR.
984  . llt(index1%DESCRIPTION,index2%DESCRIPTION)) THEN
985  index%DESCRIPTION=trim(index1%DESCRIPTION)//
986  / ' <- '//trim(index2%DESCRIPTION)
987  ELSE
988  index%DESCRIPTION=trim(index1%DESCRIPTION)
989  END IF
990 
991 C Names of columns
992  DO j=1,index%NINDEX
993  IF(lgt(index1%COLUMNS(j),index2%COLUMNS(j)).OR.
994  . llt(index1%COLUMNS(j),index2%COLUMNS(j))) THEN
995  index%COLUMNS(j)=trim(index1%COLUMNS(j))//
996  / '-'//trim(index2%COLUMNS(j))
997  ELSE
998  index%COLUMNS(j)=trim(index1%COLUMNS(j))
999  END IF
1000  END DO
1001 
1002  CALL gridman_index_check(index,res,ierr)
1003  IF(res.NE.0.OR.ierr.GT.0) THEN
1004  WRITE(gridman_unit,*) "ERROR in GRIDMAN_INDEX_MERGE: ",
1005  w "incorrect resulting index object"
1006  CALL gridman_index_deallocate(index,ierr)
1007  ierr=100
1008  RETURN
1009  END IF
1010 
1011  IF(gridman_dbg)
1012  w WRITE(gridman_unit,*) "GRIDMAN_INDEX_MERGE finished"
1013 
1014  END SUBROUTINE gridman_index_merge
gridman_index_create121
subroutine gridman_index_create121(INDEX, N, IERR)
Create index table for "one-to-one" mapping.
Definition: index.f:733
gridman_index_check
subroutine gridman_index_check(INDEX, RES, IERR)
Check index object.
Definition: index.f:149
gridman::gridman_length
integer, parameter, public gridman_length
Length of the description strings.
Definition: gridman.f:101
gridman::gridman_unit
integer, save, public gridman_unit
Index of the standard output unit.
Definition: gridman.f:116
gridman_lib
Explicit interfaces to GRIDMAN subroutines and functions.
Definition: gridman.f:251
gridman_index_compare
subroutine gridman_index_compare(INDEX1, INDEX2, RES, IERR)
Compare two index objects.
Definition: index.f:423
gridman_index_copy
subroutine gridman_index_copy(INDEX2, INDEX1, IERR)
Create a copy of the index object.
Definition: index.f:538
gridman_index_transform
subroutine gridman_index_transform(INDEX2, INDEX1, IMAP12, N12, IERR)
Transform indices of elements - IND(0,:)
Definition: index.f:788
gridman_index_allocate
subroutine gridman_index_allocate(INDEX, NINDEX, NELEMENTS, IERR)
Allocate index object.
Definition: index.f:28
gridman::gridman_dbg
logical, save, public gridman_dbg
Switch for debugging mode.
Definition: gridman.f:122
gridman_index_elmap
subroutine gridman_index_elmap(ELMAP, NMIN, NMAX, INDEX, IERR)
Create an aray which maps elements into the table of indices.
Definition: index.f:643
gridman::gridman_index
Data-type which stores indices defined on the grid cells or edges.
Definition: gridman.f:144
gridman_index_repeated_elements
logical function gridman_index_repeated_elements(INDEX, IERR)
Check if the same element index appear more than once.
Definition: index.f:586
gridman_index_merge
subroutine gridman_index_merge(INDEX, INDEX1, INDEX2, IERR)
Merge INDEX2 into INDEX1.
Definition: index.f:880
gridman_index_read
subroutine gridman_index_read(INDEX, IIN, IERR)
Read index object from file.
Definition: index.f:327
gridman_index_write
subroutine gridman_index_write(INDEX, IOUT, IERR)
Save index object in a file.
Definition: index.f:234
gridman
Definition of data types, global constants and variables.
Definition: gridman.f:83
gridman_index_deallocate
subroutine gridman_index_deallocate(INDEX, IERR)
Allocate index object.
Definition: index.f:98
gridman::gridman_sp
integer, parameter, public gridman_sp
Kind parameter for integer numbers.
Definition: gridman.f:95
Generated on Thu Oct 5 2017 09:49:57 for GRIDMAN by   doxygen 1.8.9.1