1 subroutine genblk (IBKSZ) 2c 3c---------------------------------------------------------------------- 4c 5c This routine reads the interior elements and generates the 6c appropriate blocks. 7c 8c Zdenek Johan, Fall 1991. 9c---------------------------------------------------------------------- 10c 11 use pointer_data 12c 13 include "common.h" 14 include "mpif.h" !Required to determine the max for itpblk 15c 16 integer, allocatable :: ientp(:,:) 17 integer mater(ibksz) 18 integer intfromfile(50) ! integers read from headers 19 character*255 fname1 20 21cccccccccccccc New Phasta IO starts here ccccccccccccccccccccccccc 22 23 integer :: descriptor, descriptorG, GPID, color, nfiles 24 integer :: numparts, writeLock 25 integer :: ierr_io, numprocs, itmp, itmp2 26 integer :: itpblktot,ierr,iseven 27 character*255 fnamer, fname2, temp2 28 character*64 temp1, temp3 29 nfiles = nsynciofiles 30 numparts = numpe !This is the common settings. Beware if you try to compute several parts per process 31 32 color = int(myrank/(numparts/nfiles)) !Should call the SyncIO routine here 33 itmp2 = int(log10(float(color+1)))+1 34 write (temp2,"('(''geombc-dat.'',i',i1,')')") itmp2 35 temp2=trim(temp2) 36 write (fnamer,temp2) (color+1) 37 fnamer=trim(fnamer) 38 39 ione=1 40 itwo=2 41 iseven=7 42 ieleven=11 43 itmp = int(log10(float(myrank+1)))+1 44 45cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 46 47c 48 iel=1 49 itpblk=nelblk 50!MR CHANGE 51 52 ! Get the total number of different interior topologies in the whole domain. 53 ! Try to read from a field. If the field does not exist, scan the geombc file. 54 itpblktot=-1 55 write(temp1, 56 & "('(''total number of interior tpblocks@'',i',i1,',A1)')") itmp 57 58 write (fname2,temp1) (myrank+1),'?' 59 call readheader(igeom,fname2 // char(0) ,itpblktot,ione, 60 & 'integer' // char(0),iotype) 61 62! write (*,*) 'Rank: ',myrank,' interior itpblktot intermediate:', 63! & itpblktot 64 65 if (itpblktot == -1) then 66 ! The field 'total number of different interior tpblocks' was not found in the geombc file. 67 ! Scan all the geombc file for the 'connectivity interior' fields to get this information. 68 iblk=0 69 neltp=0 70 do while(neltp .ne. -1) 71 72 ! intfromfile is reinitialized to -1 every time. 73 ! If connectivity interior@xxx is not found, then 74 ! readheader will return intfromfile unchanged 75 76 intfromfile(:)=-1 77 iblk = iblk+1 78 write (temp1,"('connectivity interior',i1)") iblk 79 temp1 = trim(temp1) 80 write (temp3,"('(''@'',i',i1,',A1)')") itmp 81 write (fname2, temp3) (myrank+1), '?' 82 fname2 = trim(temp1)//trim(fname2) 83 84 !write(*,*) 'rank, fname2',myrank, trim(adjustl(fname2)) 85 call readheader(igeom,fname2 // char(0),intfromfile, 86 & iseven,'integer' // char(0),iotype) 87 neltp = intfromfile(1) ! -1 if fname2 was not found, >=0 otherwise 88 end do 89 itpblktot = iblk-1 90 end if 91 92 if (myrank == 0) then 93 write(*,*) 'Number of interior topologies: ',itpblktot 94 endif 95! write (*,*) 'Rank: ',myrank,' interior itpblktot final:', 96! & itpblktot 97 98 99 nelblk=0 100 mattyp = 0 101 ndofl = ndof 102 nsymdl = nsymdf 103 104 do iblk = 1, itpblktot 105 writeLock=0; 106 107ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 108 109 write (temp1,"('connectivity interior',i1)") iblk 110 temp1=trim(temp1) 111 write (temp3,"('(''@'',i',i1,',A1)')") itmp 112 write (fname2, temp3) (myrank+1), '?' 113 fname2 = trim(temp1)//trim(fname2) 114 115ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 116 117 call MPI_Barrier(MPI_COMM_WORLD,ierr) 118 call readheader(igeom,fname2 // char(0) ,intfromfile, 119 & iseven,"integer" // char(0), iotype) 120 neltp =intfromfile(1) 121 nenl =intfromfile(2) 122 ipordl =intfromfile(3) 123 nshl =intfromfile(4) 124 ijunk =intfromfile(5) 125 ijunk =intfromfile(6) 126 lcsyst =intfromfile(7) 127 allocate (ientp(neltp,nshl)) 128 iientpsiz=neltp*nshl 129 130 if (neltp==0) then 131 writeLock=1; 132 endif 133 134 call readdatablock(igeom,fname2 // char(0),ientp,iientpsiz, 135 & "integer" // char(0), iotype) 136 137 if(writeLock==0) then 138 139 do n=1,neltp,ibksz 140 nelblk=nelblk+1 141 npro= min(IBKSZ, neltp - n + 1) 142c 143 lcblk(1,nelblk) = iel 144 lcblk(3,nelblk) = lcsyst 145 lcblk(4,nelblk) = ipordl 146 lcblk(5,nelblk) = nenl 147 lcblk(6,nelblk) = nfacel 148 lcblk(7,nelblk) = mattyp 149 lcblk(8,nelblk) = ndofl 150 lcblk(9,nelblk) = nsymdl 151 lcblk(10,nelblk) = nshl ! # of shape functions per elt 152c 153c.... allocate memory for stack arrays 154c 155 allocate (mmat(nelblk)%p(npro)) 156c 157 allocate (mien(nelblk)%p(npro,nshl)) 158 allocate (mxmudmi(nelblk)%p(npro,maxsh)) 159c 160c.... save the element block 161c 162 n1=n 163 n2=n+npro-1 164 mater=1 ! all one material for now 165 call gensav (ientp(n1:n2,1:nshl), 166 & mater, mien(nelblk)%p, 167 & mmat(nelblk)%p) 168 iel=iel+npro 169c 170 enddo 171 endif 172 deallocate(ientp) 173 enddo 174 175 176 lcblk(1,nelblk+1) = iel 177c 178c.... return 179c 180c 181 return 182c 1831000 format(a80,//, 184 & ' N o d a l C o n n e c t i v i t y',//, 185 & ' Elem ',/, 186 & ' Number ',7x,27('Node',i2,:,2x)) 1871100 format(2x,i5,6x,27i8) 188 end 189