一个简单的动态数据容器 - 悲催的科学匠人 - 冷水's blog
一个简单的动态数据容器
冷水
posted @ 2012年4月08日 21:17
in fortran
, 1200 阅读
能够动态的添加成员数据，目前只支持integer(4)和real(8)
! dynamic data type
! Qu Kun, April 2012
! 一个简单的动态数据结构容器，能够容纳INTEGER(4)和REAL(8)数据，维数范围为0到5
! 多个容器可链接成为链表
! 在链表中创建插入容器 dyd_new，指定数据类型、维数、指标范围和名称
! 获取容器指针 dyd_findnode 在链表中搜索指定名称的容器
! 释放容器内的数据空间 dyd_empty
! 开辟容器数据空间 dyd_construct
! 获取数据指针 dyd_getdata， 通过名称得到数据指针
!
! 一般使用最常用的是 dyd_new和dyd_getdata
! dyd_new的使用方法，建议采用关键字方式指定参数
! 1 变量指定数组范围，range11,range12,range21,range22,...,range51,range52
! CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
! range11=0,range12=9)
! 2 字符串指定数组范围
! CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
! 3 数组方式指定数组范围
! CALL dyd_new(head=list, atype=int4, adim=1,arange=irange, aname='X')
! 比较方便的是前2种
!
! 获取数据指针的方法为
! INTEGER(4),DIMENSION(:),POINTER :: X
! ...
! CALL getdata(list,'X', X)
! DO i=0,9; X(i) = i; ENDDO
MODULE qkdynadata
IMPLICIT NONE
INTEGER,PARAMETER,PRIVATE :: dyd_maxdim=5,dyd_namelen=32
INTEGER,PARAMETER,PRIVATE :: int4=1,real8=2
TYPE dynadata
INTEGER :: mdim=-1
INTEGER :: mrange(2,dyd_maxdim)=-1
INTEGER :: metype=-1 ! data type of the element, integer(4), real(8),real(4)
CHARACTER(LEN=dyd_namelen) mname
INTEGER(4),POINTER :: mint4d0p=>NULL()
INTEGER(4),POINTER,DIMENSION(:) :: mint4d1p=>NULL()
INTEGER(4),POINTER,DIMENSION(:,:) :: mint4d2p=>NULL()
INTEGER(4),POINTER,DIMENSION(:,:,:) :: mint4d3p=>NULL()
INTEGER(4),POINTER,DIMENSION(:,:,:,:) :: mint4d4p=>NULL()
INTEGER(4),POINTER,DIMENSION(:,:,:,:,:) :: mint4d5p=>NULL()
REAL(8),POINTER :: mreal8d0p=>NULL()
REAL(8),POINTER,DIMENSION(:) :: mreal8d1p=>NULL()
REAL(8),POINTER,DIMENSION(:,:) :: mreal8d2p=>NULL()
REAL(8),POINTER,DIMENSION(:,:,:) :: mreal8d3p=>NULL()
REAL(8),POINTER,DIMENSION(:,:,:,:) :: mreal8d4p=>NULL()
REAL(8),POINTER,DIMENSION(:,:,:,:,:) :: mreal8d5p=>NULL()
!pointer for inner dynamic data member
TYPE(dynadata),POINTER :: mdynadata
! pointer for linklist
TYPE(dynadata),POINTER :: mprev,mnext,mhead
END TYPE
INTERFACE getdata
MODULE PROCEDURE getdata_int4p0
MODULE PROCEDURE getdata_int4p1
MODULE PROCEDURE getdata_int4p2
MODULE PROCEDURE getdata_int4p3
MODULE PROCEDURE getdata_int4p4
MODULE PROCEDURE getdata_int4p5
MODULE PROCEDURE getdata_real8p0
MODULE PROCEDURE getdata_real8p1
MODULE PROCEDURE getdata_real8p2
MODULE PROCEDURE getdata_real8p3
MODULE PROCEDURE getdata_real8p4
MODULE PROCEDURE getdata_real8p5
END INTERFACE
CONTAINS
SUBROUTINE getdata_int4p0(head,aname, dp)
INTEGER(4),POINTER :: dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
IF(ASSOCIATED(iter)) dp => iter%mint4d0p
END SUBROUTINE
SUBROUTINE getdata_int4p1(head,aname,dp)
INTEGER(4),DIMENSION(:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
! WRITE(*,*) iter%mname
dp => iter%mint4d1p
END SUBROUTINE
SUBROUTINE getdata_int4p2(head,aname,dp)
INTEGER(4),DIMENSION(:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mint4d2p
END SUBROUTINE
SUBROUTINE getdata_int4p3(head,aname,dp)
INTEGER(4),DIMENSION(:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mint4d3p
END SUBROUTINE
SUBROUTINE getdata_int4p4(head,aname,dp)
INTEGER(4),DIMENSION(:,:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mint4d4p
END SUBROUTINE
SUBROUTINE getdata_int4p5(head,aname,dp)
INTEGER(4),DIMENSION(:,:,:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mint4d5p
END SUBROUTINE
SUBROUTINE getdata_real8p0(head,aname, dp)
REAL(8),POINTER :: dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d0p
END SUBROUTINE
SUBROUTINE getdata_real8p1(head,aname,dp)
REAL(8),DIMENSION(:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d1p
END SUBROUTINE
SUBROUTINE getdata_real8p2(head,aname,dp)
REAL(8),DIMENSION(:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d2p
END SUBROUTINE
SUBROUTINE getdata_real8p3(head,aname,dp)
REAL(8),DIMENSION(:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d3p
END SUBROUTINE
SUBROUTINE getdata_real8p4(head,aname,dp)
REAL(8),DIMENSION(:,:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d4p
END SUBROUTINE
SUBROUTINE getdata_real8p5(head,aname,dp)
REAL(8),DIMENSION(:,:,:,:,:),POINTER ::dp
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dp)
iter => dyd_findnode(head,aname)
dp => iter%mreal8d5p
END SUBROUTINE
SUBROUTINE dyd_empty(this)
TYPE(dynadata),INTENT(INOUT) :: this
! local
LOGICAL fk
INTEGER ierr
this%mdim=-1; this%mrange=-1; this%metype=-1; this%mname=''
NULLIFY(this%mdynadata)
NULLIFY(this%mprev)
NULLIFY(this%mnext)
NULLIFY(this%mhead)
IF(ASSOCIATED(this%mint4d0p)) THEN
DEALLOCATE(this%mint4d0p,STAT=ierr); NULLIFY(this%mint4d0p)
ENDIF
IF(ASSOCIATED(this%mint4d1p)) THEN
DEALLOCATE(this%mint4d1p,STAT=ierr)
NULLIFY(this%mint4d1p)
ENDIF
IF(ASSOCIATED(this%mint4d2p)) THEN
DEALLOCATE(this%mint4d2p,STAT=ierr)
NULLIFY(this%mint4d2p)
ENDIF
IF(ASSOCIATED(this%mint4d3p)) THEN
DEALLOCATE(this%mint4d3p,STAT=ierr)
NULLIFY(this%mint4d3p)
ENDIF
IF(ASSOCIATED(this%mint4d4p)) THEN
DEALLOCATE(this%mint4d4p,STAT=ierr)
NULLIFY(this%mint4d4p)
ENDIF
IF(ASSOCIATED(this%mint4d5p)) THEN
DEALLOCATE(this%mint4d5p,STAT=ierr)
NULLIFY(this%mint4d5p)
ENDIF
IF(ASSOCIATED(this%mreal8d0p)) THEN
DEALLOCATE(this%mreal8d0p,STAT=ierr); NULLIFY(this%mreal8d0p)
ENDIF
IF(ASSOCIATED(this%mreal8d1p)) THEN
DEALLOCATE(this%mreal8d1p,STAT=ierr); NULLIFY(this%mreal8d1p)
ENDIF
IF(ASSOCIATED(this%mreal8d2p)) THEN
DEALLOCATE(this%mreal8d2p,STAT=ierr); NULLIFY(this%mreal8d2p)
ENDIF
IF(ASSOCIATED(this%mreal8d3p)) THEN
DEALLOCATE(this%mreal8d3p,STAT=ierr); NULLIFY(this%mreal8d3p)
ENDIF
IF(ASSOCIATED(this%mreal8d4p)) THEN
DEALLOCATE(this%mreal8d4p,STAT=ierr); NULLIFY(this%mreal8d4p)
ENDIF
IF(ASSOCIATED(this%mreal8d5p)) THEN
DEALLOCATE(this%mreal8d5p,STAT=ierr); NULLIFY(this%mreal8d5p)
ENDIF
END SUBROUTINE
SUBROUTINE dyd_new(head,elementtype, dataname, ierr, &
range11, range12,range21, range22,range31, range32, &
range41, range42,range51, range52)
TYPE(dynadata),POINTER,INTENT(INOUT) :: head
CHARACTER(LEN=*),INTENT(IN) :: elementtype, dataname
INTEGER,INTENT(IN),OPTIONAL :: range11, range12,range21, range22, &
range31, range32, range41, range42,range51, range52
INTEGER,INTENT(OUT) :: ierr
! local
INTEGER :: atype,adim
INTEGER :: arange(2,10)
TYPE(dynadata),POINTER :: pdyd
CHARACTER(LEN=32) :: tstr
ierr=0
IF(.NOT.dyd_isvalidname(head,dataname)) THEN
ierr=1
RETURN
ENDIF
! get type
tstr = TRIM(elementtype)
CALL upper_case(tstr)
IF(tstr=='INTEGER(4)') THEN; atype=int4
ELSEIF(tstr=='REAL(8)') THEN; atype=real8
ELSE
ierr=2
RETURN
ENDIF
! get
adim=0
IF( PRESENT(range11) .AND. PRESENT(range12) ) THEN
IF(range11>=range12) THEN
WRITE(*,*) 'Invalid range'; ierr=3
RETURN
ENDIF
adim=1; arange(1,1)=range11; arange(2,1)=range12
! DIM 2
IF( PRESENT(range21) .AND. PRESENT(range22) ) THEN
IF(range21>=range22) THEN
WRITE(*,*) 'Invalid range'; ierr=3
RETURN
ENDIF
adim=2; arange(1,2)=range21; arange(2,2)=range22
! DIM 3
IF( PRESENT(range31) .AND. PRESENT(range32) ) THEN
IF(range31>=range32) THEN
WRITE(*,*) 'Invalid range'; ierr=3
RETURN
ENDIF
adim=3; arange(1,3)=range31; arange(2,3)=range32
! DIM 4
IF( PRESENT(range41) .AND. PRESENT(range42) ) THEN
IF(range41>=range42) THEN
WRITE(*,*) 'Invalid range'; ierr=3
RETURN
ENDIF
adim=4; arange(1,4)=range41; arange(2,4)=range42
! DIM 5
IF( PRESENT(range51) .AND. PRESENT(range52) ) THEN
IF(range51>=range52) THEN
WRITE(*,*) 'Invalid range'; ierr=3
RETURN
ENDIF
adim=5; arange(1,5)=range51; arange(2,5)=range52
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
!WRITE(*,*) 'dyd_new ',atype,adim,arange(:,1:adim),dataname
CALL dyd_new_0(head,atype,adim,arange,dataname)
END SUBROUTINE
SUBROUTINE dyd_new_1(head,elementtype, arrayrange, dataname, ierr)
TYPE(dynadata),POINTER,INTENT(INOUT) :: head
CHARACTER(LEN=*),INTENT(IN) :: elementtype, arrayrange,dataname
INTEGER,INTENT(OUT) :: ierr
! local
INTEGER :: atype,offset,suboffset,i,adim
INTEGER :: arange(2,10), loc(20),com(10)
TYPE(dynadata),POINTER :: pdyd
CHARACTER(LEN=32) :: tstr
!WRITE(*,*) 'new1 ',dataname
ierr=0
IF(.NOT.dyd_isvalidname(head,dataname)) THEN
ierr=1
RETURN
ENDIF
! get type
tstr = TRIM(elementtype)
CALL upper_case(tstr)
IF(tstr=='INTEGER(4)') THEN; atype=int4
ELSEIF(tstr=='REAL(8)') THEN; atype=real8
ELSE
ierr=2
RETURN
ENDIF
! get
adim=0; offset=1
DO
suboffset = INDEX(arrayrange(offset:),':')
IF(suboffset==0) EXIT
adim = adim+1
IF(adim>5) STOP
offset = offset+suboffset
ENDDO
!WRITE(*,*) 'adim=',adim,' ',arrayrange
IF(adim>0) THEN
loc(1) = INDEX(arrayrange,'(')
loc(adim+1) = INDEX(arrayrange,')')
com(1) = INDEX(arrayrange,':')
IF(adim>1) THEN
DO i=2,adim
loc(i) = loc(i-1)+INDEX(arrayrange(loc(i-1)+1:),',')
!write(*,*) loc(i),' ',arrayrange(loc(i-1)+1:)
com(i) = loc(i)+INDEX(arrayrange(loc(i)+1:),':')
!write(*,*) com(i),' ',arrayrange(loc(i)+1:)
ENDDO
ENDIF
write(*,*) loc(1:adim+1)
write(*,*) com(1:adim)
DO i=1,adim
READ( arrayrange(loc(i)+1 : com(i)-1 ), *) arange(1,i)
READ( arrayrange(com(i)+1 : loc(i+1)-1), *) arange(2,i)
ENDDO
ENDIF
CALL dyd_new_0(head,atype,adim,arange,dataname)
!NULLIFY(pdyd)
!ALLOCATE(pdyd)
!CALL dyd_construct(pdyd, atype,adim,arange,dataname)
!CALL dyd_insert(pdyd,head)
END SUBROUTINE
SUBROUTINE dyd_new_0(head,atype,adim,arange,aname)
TYPE(dynadata),POINTER,INTENT(INOUT) :: head
INTEGER,INTENT(IN) :: atype,adim
INTEGER,INTENT(IN),OPTIONAL :: arange(2,adim)
CHARACTER(LEN=*),INTENT(IN) :: aname
! local
TYPE(dynadata),POINTER :: pdyd
NULLIFY(pdyd)
IF(dyd_isvalidname(head,aname)) THEN
ALLOCATE(pdyd)
CALL dyd_construct(pdyd, atype,adim,arange,aname)
CALL dyd_insert(pdyd,head)
ENDIF
END SUBROUTINE
SUBROUTINE dyd_construct(this,atype,adim,arange,aname)
TYPE(dynadata),INTENT(INOUT) :: this
INTEGER,INTENT(IN) :: atype,adim
INTEGER,INTENT(IN),OPTIONAL :: arange(2,adim)
CHARACTER(LEN=*),INTENT(IN) :: aname
!
INTEGER i
CALL dyd_empty(this)
IF(atype<=0 .OR. atype>2) THEN
WRITE(*,*) 'Invalid type: ',atype
STOP
ENDIF
IF(adim<0) THEN
WRITE(*,*) 'Invalid dim: ',adim
STOP
ENDIF
IF(adim>0) THEN; DO i=1,adim
IF(arange(1,i)>arange(2,i)) THEN
WRITE(*,*) 'Invalid range: ',arange(1:2,i), ' in DIM ',i
STOP
ENDIF
ENDDO; ENDIF
this%mname = aname
this%metype=atype
this%mdim=adim
IF(adim>0) this%mrange(1:2,1:adim) = arange(1:2,1:adim)
SELECT CASE(this%metype)
CASE (int4)
IF(this%mdim==0) THEN
ALLOCATE(this%mint4d0p)
ENDIF
IF(this%mdim==1) THEN
ALLOCATE(this%mint4d1p(this%mrange(1,1):this%mrange(2,1) ) )
ENDIF
IF(this%mdim==2) THEN
ALLOCATE(this%mint4d2p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2) ) )
ENDIF
IF(this%mdim==3) THEN
ALLOCATE(this%mint4d3p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3) ) )
ENDIF
IF(this%mdim==4) THEN
ALLOCATE(this%mint4d4p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3), &
this%mrange(1,4):this%mrange(2,4) ) )
ENDIF
IF(this%mdim==5) THEN
ALLOCATE(this%mint4d5p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3), &
this%mrange(1,4):this%mrange(2,4), &
this%mrange(1,5):this%mrange(2,5) ) )
ENDIF
CASE (real8)
IF(this%mdim==0) THEN
ALLOCATE(this%mreal8d0p)
ENDIF
IF(this%mdim==1) THEN
ALLOCATE(this%mreal8d1p(this%mrange(1,1):this%mrange(2,1) ) )
ENDIF
IF(this%mdim==2) THEN
ALLOCATE(this%mreal8d2p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2) ) )
ENDIF
IF(this%mdim==3) THEN
ALLOCATE(this%mreal8d3p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3) ) )
ENDIF
IF(this%mdim==4) THEN
ALLOCATE(this%mreal8d4p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3), &
this%mrange(1,4):this%mrange(2,4) ) )
ENDIF
IF(this%mdim==5) THEN
ALLOCATE(this%mreal8d5p(this%mrange(1,1):this%mrange(2,1), &
this%mrange(1,2):this%mrange(2,2), &
this%mrange(1,3):this%mrange(2,3), &
this%mrange(1,4):this%mrange(2,4), &
this%mrange(1,5):this%mrange(2,5) ) )
ENDIF
END SELECT
END SUBROUTINE
SUBROUTINE dyd_insert(this,head)
TYPE(dynadata),POINTER,INTENT(INOUT) :: this
TYPE(dynadata),POINTER,INTENT(INOUT) :: head
!
TYPE(dynadata),POINTER :: tail
IF( ASSOCIATED(head) ) THEN
CALL dyd_gettail(head,tail)
!WRITE(*,*) 'Tail name is ',TRIM(tail%mname)
this%mprev => tail
this%mhead => head
tail%mnext => this
NULLIFY(this%mnext)
ELSE
head => this
this%mprev => NULL()
this%mhead => this
this%mnext => NULL()
ENDIF
END SUBROUTINE
SUBROUTINE dyd_gettail(this,tail)
TYPE(dynadata),POINTER,INTENT(IN) :: this
TYPE(dynadata),POINTER,INTENT(OUT) :: tail
IF(ASSOCIATED(this)) THEN
tail => this
DO WHILE( ASSOCIATED(tail%mnext) )
tail => tail%mnext
END DO
ENDIF
END SUBROUTINE
FUNCTION dyd_isvalidname(head,aname)
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
LOGICAL dyd_isvalidname
!
TYPE(dynadata),POINTER :: iter
dyd_isvalidname = .TRUE.
IF( ASSOCIATED(head) ) THEN
iter=>head
DO WHILE( ASSOCIATED(iter%mnext) )
!WRITE(*,*) TRIM(aname), ' ',TRIM(iter%mname)
!READ(*,*)
IF(TRIM(aname)==TRIM(iter%mname)) THEN
dyd_isvalidname = .FALSE.
EXIT
ENDIF
iter => iter%mnext
END DO
ENDIF
END FUNCTIOn
FUNCTION dyd_findnode(head,aname)
TYPE(dynadata),POINTER,INTENT(IN) :: head
CHARACTER(LEN=*),INTENT(IN) :: aname
TYPE(dynadata),POINTER :: dyd_findnode
!
TYPE(dynadata),POINTER :: iter=>NULL()
NULLIFY(dyd_findnode)
IF(.NOT.ASSOCIATED(head)) RETURN
iter=>head
loop: DO
IF(TRIM(aname)==TRIM(iter%mname)) THEN
dyd_findnode => iter ! 找到
EXIT loop
ENDIF
IF(.NOT.ASSOCIATED(iter%mnext)) THEN
EXIT loop ! 队列结束，没找到
ELSE
iter=>iter%mnext
ENDIF
END DO loop
END FUNCTION
! other
elemental subroutine upper_case(word)
! convert a word to lower case
character (len=*) , intent(in out) :: word
integer :: i,ic,nlen
nlen = len(word)
do i=1,nlen
ic = ichar(word(i:i))
if (ic >= 97 .and. ic < 122) word(i:i) = char(ic-32)
end do
end subroutine upper_case
END MODULE
测试代码如下
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE TEST_int4d0
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),POINTER :: X
INTEGER ::ierr
!CALL dyd_new(head=list, atype=int4, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
WRITE(*,*) X
X = 5
WRITE(*,*)iter%mint4d0p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_int4d1
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),DIMENSION(:),POINTER :: X
INTEGER ::i, irange(2,2),ierr
irange(1,1) =0; irange(2,1) =9
!CALL dyd_new(head=list, atype=int4, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
range11=0,range12=9)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
WRITE(*,*) X
WRITE(*,*) SHAPE(X),LBOUND(X),UBOUND(X)
X = 5
DO i=0,9; X(i) = i; ENDDO
WRITE(*,*)iter%mint4d1p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_int4d2
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),DIMENSION(:,:),POINTER :: X
INTEGER ::i,j,k, irange(2,2),ierr
irange(1,1) =0; irange(2,1) =9
irange(1,2) =1; irange(2,2) =5
!CALL dyd_new(head=list, atype=int4, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
range11=0,range12=9,range21=1,range22=5)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO j=1,5;DO i=0,9; X(i,j) = k; k=k+1; ENDDO;ENDDO
WRITE(*,*)iter%mint4d2p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_int4d3
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),DIMENSION(:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,3),ierr
irange(1,1) =0; irange(2,1) =9
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
!CALL dyd_new(head=list, atype=int4, adim=3,arange=irange, aname='X')
CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9,1:5,1:3)', &
dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO l=1,3; DO j=1,5;DO i=0,9
X(i,j,l) = k; k=k+1
ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mint4d3p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_int4d4
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),DIMENSION(:,:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,4),ierr
irange(1,1) =0; irange(2,1) =2
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
irange(1,4) =-1; irange(2,4) =1
CALL dyd_new(head=list, atype=int4, adim=4,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:9,1:5,1:3)', &
! dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO m=irange(1,4), irange(2,4)
DO l=irange(1,3), irange(2,3)
DO j=irange(1,2), irange(2,2)
DO i=irange(1,1), irange(2,1)
X(i,j,l,m) = k; k=k+1
ENDDO;ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mint4d4p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_int4d5
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
INTEGER(4),DIMENSION(:,:,:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,5),ierr
irange(1,1) =0; irange(2,1) =2
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
irange(1,4) =-1; irange(2,4) =1
irange(1,5) =5; irange(2,5) =8
!CALL dyd_new(head=list, atype=int4, adim=5,arange=irange, aname='X')
CALL dyd_new(head=list, elementtype='integer(4)', arrayrange='(0:2,1:5,1:3,-1:1,5:8)', &
dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='integer(4)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mint4d1p
!WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO n=irange(1,5), irange(2,5)
DO m=irange(1,4), irange(2,4)
DO l=irange(1,3), irange(2,3)
DO j=irange(1,2), irange(2,2)
DO i=irange(1,1), irange(2,1)
X(i,j,l,m,n) = k; k=k+1
ENDDO;ENDDO;ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mint4d5p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d0
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),POINTER :: X
INTEGER ::ierr
!CALL dyd_new(head=list, atype=real8, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
X = 5
WRITE(*,*)iter%mreal8d0p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d1
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),DIMENSION(:),POINTER :: X
INTEGER ::i, irange(2,2),ierr
irange(1,1) =0; irange(2,1) =9
!CALL dyd_new(head=list, atype=real8, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr, &
range11=0,range12=9)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
WRITE(*,*) SHAPE(X),LBOUND(X),UBOUND(X)
X = 5
DO i=0,9; X(i) = i; ENDDO
WRITE(*,*)iter%mreal8d1p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d2
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),DIMENSION(:,:),POINTER :: X
INTEGER ::i,j,k, irange(2,2),ierr
irange(1,1) =0; irange(2,1) =9
irange(1,2) =1; irange(2,2) =5
!CALL dyd_new(head=list, atype=real8, adim=1,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:9)', &
! dataname='X', ierr=ierr)
CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr, &
range11=0,range12=9,range21=1,range22=5)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO j=1,5;DO i=0,9; X(i,j) = k; k=k+1; ENDDO;ENDDO
WRITE(*,*)iter%mreal8d2p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d3
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),DIMENSION(:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,3),ierr
irange(1,1) =0; irange(2,1) =9
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
!CALL dyd_new(head=list, atype=real8, adim=3,arange=irange, aname='X')
CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:9,1:5,1:3)', &
dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO l=1,3; DO j=1,5;DO i=0,9
X(i,j,l) = k; k=k+1
ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mreal8d3p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d4
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),DIMENSION(:,:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,4),ierr
irange(1,1) =0; irange(2,1) =2
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
irange(1,4) =-1; irange(2,4) =1
CALL dyd_new(head=list, atype=real8, adim=4,arange=irange, aname='X')
!CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:9,1:5,1:3)', &
! dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO m=irange(1,4), irange(2,4)
DO l=irange(1,3), irange(2,3)
DO j=irange(1,2), irange(2,2)
DO i=irange(1,1), irange(2,1)
X(i,j,l,m) = k; k=k+1
ENDDO;ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mreal8d4p
CALL dyd_empty(iter)
END SUBROUTINE
SUBROUTINE TEST_real8d5
USE xx
IMPLICIT NONE
TYPE(dynadata),POINTER :: list=>NULL(),iter=>NULL()
REAL(8),DIMENSION(:,:,:,:,:),POINTER :: X
INTEGER ::i,j,k,l,m,n, irange(2,5),ierr
irange(1,1) =0; irange(2,1) =2
irange(1,2) =1; irange(2,2) =5
irange(1,3) =1; irange(2,3) =3
irange(1,4) =-1; irange(2,4) =1
irange(1,5) =5; irange(2,5) =8
!CALL dyd_new(head=list, atype=real8, adim=5,arange=irange, aname='X')
CALL dyd_new(head=list, elementtype='REAL(8)', arrayrange='(0:2,1:5,1:3,-1:1,5:8)', &
dataname='X', ierr=ierr)
!CALL dyd_new(head=list, elementtype='REAL(8)', dataname='X', ierr=ierr, &
! range11=0,range12=9,range21=1,range22=5,range31=1,range32=3)
CALL getdata(list,'X', X)
iter => dyd_findnode(head=list,aname='X'); !X => iter%mreal8d1p
!WRITE(*,*) X
WRITE(*,*) 'SHAPE(X)=',SHAPE(X),'LBOUND(X)=',LBOUND(X),'UBOUND(X)=',UBOUND(X)
k=1
DO n=irange(1,5), irange(2,5)
DO m=irange(1,4), irange(2,4)
DO l=irange(1,3), irange(2,3)
DO j=irange(1,2), irange(2,2)
DO i=irange(1,1), irange(2,1)
X(i,j,l,m,n) = k; k=k+1
ENDDO;ENDDO;ENDDO;ENDDO;ENDDO
WRITE(*,*)iter%mreal8d5p
CALL dyd_empty(iter)
END SUBROUTINE
PROGRAM TEST
IMPLICIT NONE
! CALL TEST_int4d0
! CALL TEST_int4d1
! CALL TEST_int4d2
! CALL TEST_int4d3
! CALL TEST_int4d4
! CALL TEST_int4d5
CALL TEST_real8d0
CALL TEST_real8d1
CALL TEST_real8d2
CALL TEST_real8d3
CALL TEST_real8d4
CALL TEST_real8d5
END
评论 (0)