fathom/moab-docs/ScdMeshF77_8F_source.html

00001 ! MOAB structured mesh extension test
00002 !
00003 ! This test also tests fortran free-source format
00004 !
00005
00006 #define ERROR(rval) if (0 .ne. rval) call exit(1)
00007
00008       real function reinterpret_ptr(xm, ni, nj, nk)
00009       integer ni, nj, nk
00010       real xm(ni, nj, nk)
00011
00012       reinterpret_ptr = 0.0
00013       do 10 k = 1, nk
00014          do 10 j = 1, nj
00015             do 10 i = 1, ni
00016                reinterpret_ptr = reinterpret_ptr + xm(i, j, k)
00017  10         continue
00018       return
00019       end
00020
00021       program ScdMesh
00022       implicit none
00023       integer comm1, mysize,myproc,ier
00024 #include "iMesh_f.h"
00025       iMesh_Instance mesh
00026       iBase_EntitySetHandle handle
00027       iBase_EntityHandle root_set
00028       iBase_TagHandle tagh
00029       iBase_EntityArrIterator iter
00030       integer local_dims(6),global_dims(6)
00031       integer geom_dim,num_regions, num_verts, num_quads, count
00032       integer*8 rpxm1
00033       integer i
00034       real rsum
00035       !real, dimension(:) :: xm
00036       real xm
00037       pointer (rpxm1, xm(*))
00038       real reinterpret_ptr
00039
00040       ! declarations
00041
00042       ! create the Mesh instance
00043
00044       local_dims(1)=0
00045       local_dims(2)=0
00046       local_dims(3)=-1
00047       local_dims(4)=64
00048       local_dims(5)=64
00049       local_dims(6)=-1
00050
00051       global_dims(1)=0
00052       global_dims(2)=0
00053       global_dims(3)=-1
00054       global_dims(4)=64
00055       global_dims(5)=64
00056       global_dims(6)=-1
00057
00058       call iMesh_newMesh('MOAB', mesh, ier)
00059       ERROR(ier)
00060
00061       handle = 0
00062       call iMesh_createStructuredMesh(%VAL(mesh), local_dims,
00063      1  global_dims, %VAL(0),%VAL(0),%VAL(0), %VAL(1), %VAL(-1),
00064      1  %VAL(-1), %VAL(-1), %VAL(0), %VAL(1), %VAL(1), handle, ier)
00065       ERROR(ier)
00066
00067       call iMesh_getRootSet(%VAL(mesh), root_set, ier)
00068       ERROR(ier)
00069
00070       call iMesh_getGeometricDimension(%VAL(mesh), geom_dim, ier)
00071       ERROR(ier)
00072
00073       call iMesh_getNumOfType(%VAL(mesh), %VAL(root_set),
00074      1  %VAL(iBase_FACE), num_quads, ier)
00075       ERROR(ier)
00076
00077       call iMesh_getNumOfType(%VAL(mesh), %VAL(root_set),
00078      1  %VAL(iBase_VERTEX), num_verts, ier)
00079       ERROR(ier)
00080
00081
00082       call iMesh_initEntArrIter(%VAL(mesh), %VAL(root_set),
00083      1  %VAL(iBase_FACE), %VAL(iMesh_QUADRILATERAL),%VAL(num_quads),
00084      1  %VAL(0), iter, ier)
00085
00086       call iMesh_createTagWithOptions(%VAL(mesh), "XM1",
00087      1  "moab:TAG_STORAGE_TYPE=DENSE; moab:TAG_DEFAULT_VALUE=0.0",
00088      1  %VAL(5), %VAL(iBase_DOUBLE), tagh, ier)
00089
00090       call iMesh_tagIterate(%VAL(mesh),%VAL(tagh),%VAL(iter),rpxm1,
00091      1  count,ier)
00092
00093       call iMesh_endEntArrIter(%VAL(mesh), %VAL(iter), ier)
00094       ERROR(ier)
00095
00096       do 20 i = 1, 5*64*64
00097         xm(i) = 1.0
00098  20     continue
00099
00100       rsum = reinterpret_ptr(xm, 5, 64, 64)
00101
00102       call iMesh_dtor(%VAL(mesh), ier)
00103       ERROR(ier)
00104
00105       if (rsum .ne. 5*64*64) call exit(1)
00106
00107       call exit(0)
00108       end