# to unbundle, sh this file (in an empty directory) mkdir src echo src/mgghat.f 1>&2 sed >src/mgghat.f <<'//GO.SYSIN DD src/mgghat.f' 's/^-//' - subroutine mgghat - include 'commons' - real nwctrg,mgf0,tguess - external clock -c -c perform initializations -c - mgf0 = mgfreq - call init -c -c do refine/solve loop until relative error estimate is small enough -c - 1 if (rerest .lt. tol .or. ierr.ne.0) go to 2 -c -c timing of this step -c - timetl = clock(0) -c -c refinement/solution/error estimation step -c - call refine - call solve - call esterr -c -c finish timing of this step -c - timetl = clock(0) - timetl - if (outlev.ge.2) write(ioutpt,100) timetl,clock(0)-timett -c -c estimate the amount of time needed for another refine/solve step, -c and if there isn't enough time left, modify mgfreq or quit -c - tguess = timetl * mgfreq - if (tguess + clock(0)-timett .gt. mxtime) then - if (timetl .gt. 10.*r1mach(4)) then - nwctrg = (mxtime - (clock(0)-timett))/timetl - else - nwctrg = mgfreq - endif - if (nwctrg.le.1.) then - ierr=5 - else - if (nwctrg.lt.mgfreq) mgfreq=nwctrg - endif - endif - go to 1 -c -c end of main loop -c - 2 continue - mgfreq = mgf0 -c -c ending output -c - call outend -c - 100 format(/' time for this refinement/solution step',f10.2/ - 1 ' total time so far ',f10.2) -c -c continue to view the plots until the menu quit button is pressed -c - if (grafic) then - if (menuon) then - write(6,1100) - grpaws = .false. - 11 if (.not.menuon) go to 12 - call mn2mg - go to 11 - 12 continue - else - write(6,1200) - read * - endif -c -c clear all the graphics in case the program is called again -c - menuon = .false. - grafic = .false. - do 21 i=1,100 - if (pltsel(i)) then - pltsel(i)=.false. - if (gunit(i).ne.-1) then - call gpclos(gunit(i)) - gunit(i)=-1 - endif - endif - 21 continue - endif - 1100 format(/'The Graphics Selections Menu is still active, and can'/ - . 'be used to add, delete or rotate gnuplot displays.'// - . 'To terminate the program, press Quit on the graphics menu.') - 1200 format(/' The Graphics will remain on screen until you', - . ' press return.') -c - return - end -c -c block data to initialize parameters to default values. The -c user can override the defaults with assignment statements in -c the main program. -c - block data - include 'commons' -c -c Stopping critera related to space allocation. Default is the -c parameters used to dimension arrays -c - data mxvert,mxtri,mxlev,mxnode / ndvert,ndtri,ndlev,ndnode / -c -c Maximum allowed cpu time in seconds, as a stopping criteria. -c Default is 12 hours -c - data mxtime / 43200. / -c -c Error tolerance, as a stopping criteria. Returns if the relative -c energy norm error estimate drops below tol. Default is 0., i.e., -c use some other stopping criteria. -c - data tol / 0. / -c -c I/O unit to which to write printed output. Default is 6. -c - data ioutpt / 6 / -c -c I/O unit for gnuplot file output. Default is 4. -c - data gpfile / 4 / -c -c Amount of printed output. Usable values are: -c <= 0 No output, except error messages -c 1 Header plus summary at end of execution -c 2 Information after each phase of execution -c 3 Low level of debug information -c 4 Medium level of debug information -c >= 5 High level of debug information -c Values of 3, 4 and 5 are probably not useful to normal users. -c Default is 2. -c - data outlev / 2 / -c -c Order of the polynomial approximation (degree+1). -c 2 is linear, 3 is quadratic and 4 is cubic. Higher orders are -c possible, but require code modification for more accurate -c quadrature rules. Default is 4. -c - data iorder / 4 / -c -c parameters to pin down a nonunique solution -c nuniq = .true. if the user supplies the value of the solution at some -c vertex -c nuniqx, nuniqy = the x,y coordinates where the solution is given -c nuniqv = the value of the solution at that vertex -c If the user says it's not unique, but doesn't give the point and/or -c value, the default is to use the value 0. at the point (0.,0.) -c - data nuniq / .false. / - data nuniqx, nuniqy, nuniqv / 0.,0.,0. / -c -c Uniform (.true.) or adaptive (.false.) refinement. Default is .false. -c - data unifrm / .false. / -c -c Flags for which gnuplot files to write. Default is none. -c gptri = 0 no triangulation file -c 1 write triangulation file -c gpsol = 0 no solution file -c = n write file with solution on n X n grid -c gpconv= 0 no convergence file -c 1 write convergence file -c - data gptri, gpsol, gpconv / 0, 0, 0 / -c -c do/do_not prompt the user during initialization for selection -c of graphics or startup of graphics menu. Default is to prompt. -c - data gquiet / .false. / -c -c Use a widget based menu for graphics selection. Default is false. -c - data menuon / .false. / -c -c pltsel is a logical array of plot selections. The i'th entry is true -c if graphical displays are to be made for the corresponding entry -c in the following table. Default is all false. -c 1 Computed Solution; Surface 31 Error; Surface -c 2 Computed Solution; Contour 32 Error; Contour -c 3 Computed Solution; Facets 33 Error; Facets -c 4 Computed Solution; Surf & Tri 34 Error; Surf & Tri -c 6 Computed Solution; Facet & Tri 36 Error; Facet & Tri -c 11 True Solution; Surface 41 Triangulation -c 12 True Solution; Contour 51 Nodes vs. energy err -c 13 True Solution; Facets 52 Nodes vs. max error -c 14 True Solution; Surf & Tri 53 Nodes vs. err est -c 16 True Solution; Facet & Tri 54 Nodes vs. err & est -c 21 Comp & True Solutions; Surface 61 Time vs. energy err -c 22 Comp & True Solutions; Contour 62 Time vs. max error -c 23 Comp & True Solutions; Facets 63 Time vs. err est -c 24 Comp & True Solutions; Surf & Tri 64 Time vs. err & est -c 26 Comp & True Solutions; Facet & Tri -c - data pltsel / 100*.false. / -c -c The remaining parameters determine details of the numerical -c method used. Modifying these would only be of interest to -c a numerical analyst experimenting with adaptive multilevel -c methods. -c -c How much to multiply the number of nodes by in each refinement phase, -c i.e., amount of refinement between multigrid phases. -c - data mgfreq / 2. / -c -c Number of relaxation iterations before and after coarse grid correction -c - data nu1, nu2 / 1, 2 / -c -c number of multigrid cycles in each solution phase -c - data ncyc / 1 / -c - end -c -c -------- init -c - subroutine init - include 'commons' - integer i,holdol - logical holdgr - external clock -c -c header output -c - if (outlev.ge.1) call outhed -c -c set up graphics -c - if (.not. gquiet) call setupg -c -c initial triangulation -c - call inittr -c -c check validity of input -c - call valinp -c -c initializations -c - if (outlev.ge.2) write(ioutpt,100) - 100 format(/' begin initialization') -c -c start clock for total time -c - timett = clock(0) - timert = 0. - timest = 0. - timeet = 0. -c -c set the list of vertices of each level to be empty -c and the number of vertices of each level to 0 -c - do 10 i=2,mxlev - frstvt(i) = -1 - lvert (i) = 0 - lbvert(i) = 0 - 10 continue -c -c initially 1 level and no error -c - nvert0=nvert - nlev=1 - ierr=0 - gplev=1 -c -c initialize basis values and quadrature formula -c - call initbs -c -c set node renumbering tables -c - call initrn -c -c initialize triangulation data structures -c - call initds -c -c initialize nodes -c - call initnd -c -c set up equations for coarsest grid -c - call initeq -c -c initialize for exact coarse grid solution -c - call initxs -c -c solve coarse grid problem -c - call exsolv - if (outlev.ge.4) then - write(ioutpt,300) - call prvec(u,1,1) - endif - 300 format(/' initial solution'/) -c -c compute initial errors -c - call unorm(un,trun) - unrm = un - trunrm = trun - call errors(emaxv,emaxn,emaxq,eenrg) - gerr = eenrg - if (trunrm.ge.1e-10) then - rgerr = gerr/trunrm - else - rgerr = gerr - endif - emax = emaxq - if (emaxn.gt.emax) emax=emaxn -c -c save information for gnuplot convergence file -c - gpmxer(gplev)=emax - gpener(gplev)=rgerr - gpnode(gplev)=nnode -c -c compute first error indicators -c - holdol = outlev - if (outlev.le.2) outlev = 0 - holdgr = grafic - grafic = .false. - call esterr - outlev = holdol - grafic = holdgr -c -c initialize graphics -c - call initgr -c -c compute time used for initialization -c - timei = clock(0) - timett - if (outlev.ge.2) write(ioutpt,200) timei - 200 format(/' initializations complete'// - 1 ' time for initialization ',f10.2) -c - return - end -c -c -------- initbs -c - subroutine initbs - include 'commons' - integer i,j,sumord,sub,inc,nod,deg,nodebc(3),qp,zeta,rnod - real rdeg,nf,factor -c -c initializations associated with basis functions -c - if (outlev.ge.3) write(ioutpt,400) - 400 format(' initializations associated with bases') -c -c number of new nodes associated with a vertex (interior and boundary) -c and number of nodes in a triangle -c - nnodev=(iorder-1)**2 - nnodvb=(iorder*(iorder-1))/2 - nnodtr=(iorder*(iorder+1))/2 -c -c quadrature rule -c - if (iorder.eq.2) then - nqpt=1 - quadpt(1,1)=1./3. - quadpt(2,1)=1./3. - quadpt(3,1)=1./3. - quadw(1)=1. - nqptb=1 - qptb(1)=.5 - qwtb(1)=1. - elseif (iorder.eq.3) then - nqpt=3 - quadpt(1,1)=2./3. - quadpt(2,1)=1./6. - quadpt(3,1)=quadpt(2,1) - quadw(1)=1./3. - quadpt(1,2)=quadpt(2,1) - quadpt(2,2)=quadpt(1,1) - quadpt(3,2)=quadpt(2,1) - quadw(2)=quadw(1) - quadpt(1,3)=quadpt(2,1) - quadpt(2,3)=quadpt(2,1) - quadpt(3,3)=quadpt(1,1) - quadw(3)=quadw(1) - nqptb=2 - qptb(1)=.5+1./(2.*sqrt(3.)) - qptb(2)=1.-qptb(1) - qwtb(1)=.5 - qwtb(2)=.5 - elseif (iorder.eq.4) then - nqpt=6 - quadpt(1,1)=.8168475729 - quadpt(2,1)=.0915762135 - quadpt(3,1)=quadpt(2,1) - quadw(1)=.1099517436 - quadpt(1,2)=quadpt(2,1) - quadpt(2,2)=quadpt(1,1) - quadpt(3,2)=quadpt(2,1) - quadw(2)=quadw(1) - quadpt(1,3)=quadpt(2,1) - quadpt(2,3)=quadpt(2,1) - quadpt(3,3)=quadpt(1,1) - quadw(3)=quadw(1) - quadpt(1,4)=.1081030181 - quadpt(2,4)=.4459484909 - quadpt(3,4)=quadpt(2,4) - quadw(4)=.2233815896 - quadpt(1,5)=quadpt(2,4) - quadpt(2,5)=quadpt(1,4) - quadpt(3,5)=quadpt(2,4) - quadw(5)=quadw(4) - quadpt(1,6)=quadpt(2,4) - quadpt(2,6)=quadpt(2,4) - quadpt(3,6)=quadpt(1,4) - quadw(6)=quadw(4) - nqptb=3 - qptb(1)=(1.+sqrt(.6))/2. - qptb(2)=.5 - qptb(3)=1.-qptb(1) - qwtb(1)=5./18. - qwtb(2)=4./9. - qwtb(3)=qwtb(1) - elseif (nqpt.le.0) then - write(ioutpt,100) iorder - stop - 100 format(/' ********FATAL ERROR********'// - 1 ' need a quadrature rule which is compatable with order ',i2) - endif -c -c number of basis changes associated with a node -c - sumord=(iorder*(iorder+1))/2 - do 10 i=1,nnodev - nbasch(i)=sumord - 10 continue - sub=1 - inc=iorder-1 - 1 nbasch(sub)=iorder - sub=sub+inc - inc=inc-2 - if (inc.gt.0) go to 1 - inc=iorder-2 - if (iorder.eq.2) go to 3 - 2 nbasch(sub)=iorder - sub=sub+inc - inc=inc-2 - if (inc.gt.0) go to 2 - 3 continue -c -c set index of old nodes for new nodes for basis change -c - do 20 i=1,nnodvb - do 20 j=1,nbasch(i) - ibasch(j,i)=j - 20 continue - if (iorder.eq.2) go to 51 - do 50 i=nnodvb+1,nnodev - do 30 j=1,iorder - ibasch(j,i)=j - 30 continue - do 40 j=iorder+1,sumord - ibasch(j,i)=sumord-iorder+j - 40 continue - 50 continue - 51 continue -c -c set barycentric coordinates of red nodes in old triangles (scaled -c by 2*degree) -c note this is only used here and olndvt is used as a temporary for this -c - deg=iorder-1 - rdeg=float(deg) - nod=1 - do 60 i=1,iorder/2 - do 60 j=2*deg+1-2*i,2*i-1,-2 - olndvt(nod,1)=j - olndvt(nod,2)=2*i-1 - olndvt(nod,3)=2*deg-olndvt(nod,1)-olndvt(nod,2) - nod=nod+1 - 60 continue - if (iorder.eq.2) go to 71 - do 70 i=1,deg/2 - do 70 j=2*deg+1-2*i,2*i+1,-2 - olndvt(nod,1)=2*i-1 - olndvt(nod,2)=j - olndvt(nod,3)=2*deg-olndvt(nod,1)-olndvt(nod,2) - nod=nod+1 - 70 continue - 71 continue -c -c evaluate basis function -c -c need value and derivatives at the quadrature points for quadratures -c and the values at red nodes for basis changes -c - nodebc(1)=iorder - nodebc(2)=-1 - nodebc(3)=0 -c -c for each node of a triangle -c - do 240 nod=1,nnodtr -c -c find barycentric coordinates of node (scaled by degree) -c - nodebc(1)=nodebc(1)-1 - nodebc(2)=nodebc(2)+1 - if (nodebc(1).lt.0) then - nodebc(3)=nodebc(3)+1 - nodebc(2)=0 - nodebc(1)=deg-nodebc(3) - endif -c -c initialize basis values at 1. and derivatives at 0. -c -c normalization factor - nf=1. -c quadrature points - do 120 qp=1,nqpt - qpbas(nod,qp)=1. - do 110 zeta=1,3 - qpdbdz(zeta,nod,qp)=0. - 110 continue - 120 continue -c red nodes - do 130 rnod=1,nnodvb - cbasch(nod,rnod)=1. - 130 continue -c -c evaluate basis -c - do 180 i=1,3 - do 170 j=0,deg-1 - if (nodebc(i).gt.j) then -c adjust normalization factor - nf=nf*float(nodebc(i)-j)/rdeg -c values and derivatives at quadrature points - do 150 qp=1,nqpt -c new factor in basis value - factor=quadpt(i,qp)-float(j)/rdeg -c derivatives with respect to barycentric coordinates - do 140 zeta=1,3 - qpdbdz(zeta,nod,qp)=qpdbdz(zeta,nod,qp)*factor - 140 continue - qpdbdz(i,nod,qp)=qpdbdz(i,nod,qp)+qpbas(nod,qp) -c basis value - qpbas(nod,qp)=qpbas(nod,qp)*factor - 150 continue -c value at red nodes - do 160 rnod=1,nnodvb - cbasch(nod,rnod)=cbasch(nod,rnod)* - 1 float(olndvt(rnod,i)-2*j)/(2.*rdeg) - 160 continue - endif - 170 continue - 180 continue -c -c boundary quadrature points -c - if (nod.le.iorder) then - do 181 qp=1,nqptb - qpbasb(nod,qp)=1. - qpbbdz(nod,qp)=0. -c basis value - do 171 j=0,deg - if (j.ne.nod-1) then - qpbasb(nod,qp)=qpbasb(nod,qp)* - & (1.-qptb(qp)-float(j)/rdeg)/(float(nod-1-j)/rdeg) - endif - 171 continue -c derivative - do 161 j=0,deg - if (j.ne.nod-1) then - qpbbdz(nod,qp)=qpbbdz(nod,qp)+qpbasb(nod,qp) - & /(1.-qptb(qp)-float(j)/rdeg) - endif - 161 continue - 181 continue - endif -c -c normalize values -c - do 210 qp=1,nqpt - qpbas(nod,qp)=qpbas(nod,qp)/nf - do 190 zeta=1,3 - qpdbdz(zeta,nod,qp)=qpdbdz(zeta,nod,qp)/nf - 190 continue - 210 continue - do 220 rnod=1,nnodvb - cbasch(nod,rnod)=cbasch(nod,rnod)/nf - 220 continue -c -c copy values at red nodes for matching triangle -c - if (iorder.eq.2) go to 231 - sub=1 - do 230 rnod=nnodvb+1,nnodev - 229 sub=sub+1 - if (nbasch(sub).eq.iorder) go to 229 - cbasch(nod,rnod)=cbasch(nod,sub) - 230 continue - 231 continue - 240 continue -c -c compress 0's out of basis change values -c @future do this more carefully. I have checked that for -c iorder=2,3 and 4 all the 0's are at the end, so this works. -c don't know if it works for higher order -c may also want to try to not put the 0's there in the first place -c - do 310 i=1,nnodev - j=nbasch(i) - 311 if (cbasch(j,i).ne.0.) go to 312 - j=j-1 - go to 311 - 312 continue - nbasch(i)=j - 310 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,500) - 500 format(/' basis initialization complete') - write(ioutpt,501) nnodev,nnodvb,nnodtr - 501 format(' number of new nodes associated with a vertex'/ - 1 ' interior ',i3,' boundary ',i3/ - 2 ' number of nodes in a triange ',i3) - write(ioutpt,502) - 502 format(' number of basis changes for each red node') - write(ioutpt,503) (nbasch(i),i=1,nnodev) - 503 format(1x,19i4) - write(ioutpt,504) - 504 format(' barycentric coordinates of red nodes') - write(ioutpt,505) ((olndvt(i,j),j=1,3),i=1,nnodvb) - 505 format(1x,3i5) - write(ioutpt,506) - 506 format(' index and constant for basis changes') - do 510 i=1,nnodev - write(ioutpt,511) i - 511 format(' red node ',i3) - write(ioutpt,512) (ibasch(j,i),cbasch(j,i),j=1,nbasch(i)) - 512 format(1x,4(i4,1pe15.8)) - 510 continue - write(ioutpt,513) - 513 format(' quadrature points and weights') - write(ioutpt,514) ((quadpt(j,i),j=1,3),quadw(i),i=1,nqpt) - 514 format(1x,4(1pe15.8)) - write(ioutpt,533) - 533 format(' boundary quadrature points and weights') - write(ioutpt,534) (qptb(i),qwtb(i),i=1,nqptb) - 534 format(1x,2(1pe15.8)) - write(ioutpt,515) - 515 format(' values and derivatives of bases at quadrature points') - do 520 i=1,nnodtr - write(ioutpt,521) i - 521 format(' basis at node ',i3) - do 520 j=1,nqpt - write(ioutpt,522) qpbas(i,j),qpdbdz(1,i,j),qpdbdz(2,i,j), - 1 qpdbdz(3,i,j) - 522 format (1x,4(1pe15.8)) - 520 continue - write(ioutpt,535) - 535 format(' values of bases at boundary quadrature points') - do 540 i=1,iorder - write(ioutpt,536) i,(qpbasb(i,j),j=1,nqptb) - 536 format(' node ',i3,2x,4(1pe15.8)) - 540 continue - write(ioutpt,635) - 635 format(' values of derivatives at boundary quadrature points') - do 640 i=1,iorder - write(ioutpt,536) i,(qpbbdz(i,j),j=1,nqptb) - 640 continue - endif - if(outlev.ge.3) write(ioutpt,650) - 650 format(' basis initializations complete') - return - end -c -c -------- initds -c - subroutine initds - include 'commons' - integer i,j,k,vert -c -c initialize triangulation data structures -c - if (outlev.ge.3) write(ioutpt,100) - 100 format(' initialize triangulation data structures') -c -c neighbors of each triangle -c - do 110 i=1,ntri - k=1 - 111 if (k.gt.ntri) go to 112 - if(vertex(2,k).eq.vertex(2,i) .and. - 1 vertex(3,k).eq.vertex(3,i) .and. i.ne.k) go to 112 - k=k+1 - go to 111 - 112 continue - if (k.le.ntri) then - neigh(1,i)=k - else - if (neigh(1,i).ge.0) then - write(ioutpt,200) 1,i - stop - endif - endif - k=1 - 113 if (k.gt.ntri) go to 114 - if(vertex(1,k).eq.vertex(1,i) .and. - 1 vertex(3,k).eq.vertex(3,i) .and. i.ne.k) go to 114 - k=k+1 - go to 113 - 114 continue - if (k.le.ntri) then - neigh(2,i)=k - else - if (neigh(2,i).ge.0) then - write(ioutpt,200) 2,i - stop - endif - endif - k=1 - 115 if (k.gt.ntri) go to 116 - if(vertex(1,k).eq.vertex(1,i) .and. - 1 vertex(2,k).eq.vertex(2,i) .and. i.ne.k) go to 116 - k=k+1 - go to 115 - 116 continue - if (k.le.ntri) then - neigh(3,i)=k - else - if (neigh(3,i).ge.0) then - write(ioutpt,200) 3,i - stop - endif - endif - 110 continue - 200 format(' ********FATAL ERROR********'/ - . ' side opposite vertex ',i1,' of triangle ',i6/ - . ' is on the boundary but does not have neigh assigned', - . ' the boundary piece.') -c -c triangles around each vertex -c - do 10 i=1,nvert - do 10 j=1,8 - tringl(j,i)=0 - 10 continue - do 20 i=1,ntri - do 20 j=1,3 - vert=vertex(j,i) - k=1 - 1 if (tringl(k,vert).eq.0) go to 2 - k=k+1 - if (k.gt.8) then - write(ioutpt,101) vert - stop - 101 format(/' ********FATAL ERROR********'// - 1 ' too many triangles around vertex ',i6) - endif - go to 1 - 2 continue - tringl(k,vert)=i - 20 continue -c -c determine which vertices are boundary -c boundary vertices occur in triangles with a nonpositive neighbor -c - do 30 i=1,nvert - vrtlev(i)=1 - 30 continue - do 40 i=1,ntri - if (neigh(1,i).le.0) then - vrtlev(vertex(2,i))=-1 - vrtlev(vertex(3,i))=-1 - endif - if (neigh(2,i).le.0) then - vrtlev(vertex(1,i))=-1 - vrtlev(vertex(3,i))=-1 - endif - if (neigh(3,i).le.0) then - vrtlev(vertex(1,i))=-1 - vrtlev(vertex(2,i))=-1 - endif - 40 continue -c -c set up linked lists of vertices -c and count number of vertices -c - lvert(1)=0 - lbvert(1)=0 - frstvt(1)=-1 - do 50 i=1,nvert - nextvt(i)=frstvt(1) - frstvt(1)=i - if (vrtlev(i).gt.0) then - lvert(1)=lvert(1)+1 - else - lbvert(1)=lbvert(1)+1 - endif - 50 continue -c -c debug output -c - if (outlev.ge.4) then - call plttri(1,1) - endif - if (outlev.ge.3) write(ioutpt,201) - 201 format(' triangulation data structures initialization complete') -c - return - end -c -c -------- initeq -c - subroutine initeq - include 'commons' - integer i,j,t,c,r -c -c initialize equations, i.e., matrix and right side -c and set up initial error indicator problems -c - if (outlev.ge.3) write(ioutpt,100) - 100 format(' initialize equations') -c -c set maximum number of nonzeroes in lower and upper -c triangular parts of a row. mxidup is sum of lower and upper -c - mxidlo = 2*iorder*(iorder-1) - mxidup = 3*mxidlo -c -c set coef and rs by doing integrals over each -c triangle and assembling -c -c initialize to 0 -c - do 120 i=1,nnode - rs(i)=0. - do 110 j=1,mxidlo - coef(j,i)=0. - idcoef(j,i)=0 - 110 continue - coef(mxidlo+1,i)=0. - do 115 j=mxidlo+1,mxidup - idcoef(j,i)=0 - 115 continue - 120 continue -c - do 140 t=1,ntri -c quadratures for this triangle - call quad(t,1) -c make sure column pointers are all there - do 125 i=1,nadd - if (row(i).eq.col(i)) go to 125 - c=1 - 121 if (c.gt.mxidlo .or. idcoef(c,row(i)).eq.col(i) - 1 .or. idcoef(c,row(i)).eq.0) go to 122 - c=c+1 - go to 121 - 122 continue - if (c.gt.mxidlo) then - write(ioutpt,500) - stop - 500 format(' ********FATAL ERROR********'// - 1 ' ran out of room in lower idcoef in initeq') - else - idcoef(c,row(i))=col(i) - endif - 125 continue -c add values to matrix - call addmat -c add values to right side - do 130 i=1,naddrs - rs(rowrs(i))=rs(rowrs(i))+addrs(i) - 130 continue - 140 continue -c -c set upper triangular column pointers -c - do 150 i=1,nnode - do 150 j=1,mxidlo - if (idcoef(j,i).ne.0) then - r=idcoef(j,i) - c=mxidlo+1 - 141 if (c.gt.mxidup .or. idcoef(c,r).eq.i .or. - 1 idcoef(c,r).eq.0) go to 142 - c=c+1 - go to 141 - 142 continue - if (c.gt.mxidup) then - write(ioutpt,501) - stop - 501 format(' ********FATAL ERROR********'// - 1 ' ran out of room in upper idcoef in initeq') - else - idcoef(c,r)=i - endif - endif - 150 continue -c -c set up initial error indicator problems -c -c set lists of triangles to be empty -c - do 209 i=1,4 - eihead(i)=-1 - eitail(i)=-1 - 209 continue -c -c set up equations -c - do 210 i=1,ntri - if (neigh(3,i).le.0 .or. neigh(3,i).gt.i) then - call setei(i) - else - call setei2(neigh(3,i),i) - endif - 210 continue -c -c debug output -c - if (outlev.ge.4) call outmat - if (outlev.ge.3) write(ioutpt,511) - 511 format(' matrix initialization complete') -c - return - end -c -c -------- initgr -c - subroutine initgr - include 'commons' -c -c initializations for graphics -c -c set all gnuplot units to -1 -c - do 15 i=1,100 - gunit(i)=-1 - 15 continue -c -c set grafic to true iff one of pltsel is true, or menuon is true -c - grafic = .false. - if (menuon) grafic = .true. - do 20 i=1,100 - if (pltsel(i)) grafic = .true. - 20 continue -c -c set graphics pause (grpaws) true, to allow time for -c reshaping windows -c - grpaws = .true. -c -c if runtime graphics are on, and the number of isolines for -c surface plots was not specified by the user, set it to 20 -c -c set number of isolines for surface plots to default 20X20 -c - gpsolx = 20 - gpsoly = 20 -c -c create data files for starting plots, check for new message from -c the menu, and draw the plots -c - if (grafic) then - call filtri - call filsol - call filcon - if (menuon) call mn2mg - call grftri - call grfsol - call grfcon - endif -c - return - end -c -c ---- setupg -c - subroutine setupg - include 'commons' -c -c set up the run time graphics -c - logical there - character*1 inchar - character*200 inline - character*10 digits - integer ipoint, select, inval, inlen - data digits / '0123456789' / -c - write(ioutpt,100) - 100 format(' ') - write(ioutpt,210) - 210 format(/' NOTE -- you must have gnuplot installed and in'/ - . ' your execution path for graphics to work'/) - write(ioutpt,110) - 110 format('Do you want any runtime graphics (y/n)?') - read(5,'(a1)') inchar - if (inchar .eq. 'y') then - grafic = .true. - write(ioutpt,220) - 220 format(/' NOTE -- you must have tcl/tk installed and wish'/ - . ' in your execution path for the menu to ', - . 'work'/) - write(ioutpt,120) - 120 format('Do you want menu-widget driven selection (y/n)?') - read(5,'(a1)') inchar - if (inchar .eq. 'y') then - inquire(file=tmpdir//'men2mgg',exist=there) - if (there) call system('rm '//tmpdir//'men2mgg') - call system('wish < grmenu &') - menuon = .true. - write(ioutpt,130) - 130 format(/ - . ' A process has been spawned to run the widget based' - . ,' menu.'/' From the menu you can add and delete displays,'/ - . ' rotate the view of 3D plots, and change the number of'/ - . ' isolines used for surface plots. You can continue to '/ - . ' use the menu as the program executes, and after the '/ - . ' completion of the solution process. The initial '/ - . ' selections made now will not appear until the program '/ - . ' continues, and the displays may be slow to update.'// - . ' >>> Make initial selections from the menu and press ', - . 'return.'/) - read * - else - write(ioutpt,140) -c -c initialize for read -c - read(5,'(a200)') inline - inlen = len(inline) - ipoint=0 - select = 0 -c -c loop while in an integer -c - 1 continue - ipoint = ipoint + 1 - if (ipoint.gt.inlen) go to 4 - read(inline(ipoint:ipoint),'(a1)',end=4) inchar - inval = index(digits,inchar)-1 - if (inval .lt. 0 .or. inval .gt. 9) go to 2 - select = 10*select+inval - go to 1 -c -c end of integer; set pltsel -c - 2 continue - if (select .gt. 0 .and. select .lt. 100) - . pltsel(select) = .true. -c -c loop while not in integer -c - 3 continue - ipoint = ipoint + 1 - if (ipoint.gt.inlen) go to 4 - read(inline(ipoint:ipoint),'(a1)',end=4) inchar - select = index(digits,inchar)-1 - if (select .ge. 0 .and. select .le. 9) go to 1 - go to 3 -c -c end of input string -c - 4 continue - endif - endif - 140 format(/' Enter a list of integers to select any number of '/ - . ' displays from the following list:'// - . ' 1 Computed Solution; Surface 31 Error; Surface'/ - . ' 2 Computed Solution; Contour 32 Error; Contour'/ - . ' 3 Computed Solution; Facets 33 Error; Facets'/ - . ' 4 Computed Solution; Surf & Tri 34 Error; Surf & Tri'/ - . ' 6 Computed Solution; Facet & Tri 36 Error; Facet & Tri'/ - . '11 True Solution; Surface 41 Triangulation'/ - . '12 True Solution; Contour 51 Nodes vs. energy err'/ - . '13 True Solution; Facets 52 Nodes vs. max error'/ - . '14 True Solution; Surf & Tri 53 Nodes vs. err est'/ - . '16 True Solution; Facet & Tri 54 Nodes vs. err & est'/ - . '21 Comp & True Solutions; Surface 61 Time vs. energy err'/ - . '22 Comp & True Solutions; Contour 62 Time vs. max error'/ - . '23 Comp & True Solutions; Facets 63 Time vs. err est'/ - . '24 Comp & True Solutions; Surf & Tri 64 Time vs. err & est'/ - . '26 Comp & True Solutions; Facet & Tri'/) -c - return - end -c -c -------- initnd -c - subroutine initnd - include 'commons' - integer t,nay,i,j,sub,inc,k,deg,lnod,v1,v2,nod,bctype - real x,y - real bcrhs,cu -c -c define nodes for the initial triangulation -c - if (outlev.ge.3) write(ioutpt,100) - 100 format(' initialize nodes') -c - nnode = nvert - do 60 t=1,ntri -c -c nodes which are vertices -c - node(1,t) = vertex(1,t) - node(iorder,t) = vertex(2,t) - node(nnodtr,t) = vertex(3,t) - if (iorder.gt.2) then -c -c nodes along base -c - nay = neigh(3,t) - if (nay.gt.t .or. nay.le.0) then - do 10 i=2,iorder-1 - nnode = nnode+1 - node(i,t) = nnode - if (nay.gt.0) node(i,nay) = nnode - 10 continue - endif -c -c nodes along older side -c - nay = neigh(2,t) - if (nay.gt.t .or. nay.le.0) then - sub = iorder+1 - inc = iorder-1 - do 20 i=1,iorder-2 - nnode = nnode + 1 - node(sub,t) = nnode - if (nay.gt.0) node(sub,nay) = nnode - sub = sub + inc - inc = inc - 1 - 20 continue - endif -c -c nodes along newer side -c - nay = neigh(1,t) - if (nay.gt.t .or. nay.le.0) then - sub = 2*iorder-1 - inc = iorder-2 - do 30 i=1,iorder-2 - nnode = nnode + 1 - node(sub,t) = nnode - if (nay.gt.0) node(sub,nay) = nnode - sub = sub + inc - inc = inc - 1 - 30 continue - endif -c -c nodes interior to triangle -c - if (iorder.gt.3) then - sub = iorder + 2 - do 50 i=1,iorder-3 - do 40 j=1,iorder-2-i - nnode = nnode + 1 - node(sub,t) = nnode - sub = sub + 1 - 40 continue - sub = sub + 2 - 50 continue - endif - endif - 60 continue -c -c set number of initial nodes -c - nnode0 = nnode -c -c set boundary node flags and boundary condition -c - do 110 i=1,nnode - bndnod(i) = .false. - u(i) = 0. - 110 continue -c -c if the solution is not unique (due to pure Neumann or periodic -c conditions), then set the single equation at a vertex whose -c coordinates were given by the user to tie down the solution -c - if (nuniq) then -c -c find the vertex -c - eps = 4.*r1mach(4) - do 115 i=1,nvert - if (abs(xvert(i)-nuniqx).lt.eps .and. - . abs(yvert(i)-nuniqy).lt.eps) then - ii = i - go to 116 - endif - 115 continue -c -c didn't find a vertex with the right coordinates -c - write(ioutpt,200) nuniqx,nuniqy - 200 format(/' ********FATAL ERROR********'// - . 'Non-unique solution must be specified at a vertex.'/ - . 'There is no vertex with coordinates',2(1pe15.8)) - if (outlev.le.2) then - write(ioutpt,201) - else - write(ioutpt,202) - write(ioutpt,203) (xvert(i),yvert(i),i=1,nvert) - endif - stop - 201 format(/'To see a list of vertex coordinates, rerun with ', - . 'outlev=3') - 202 format(/'The vertices are:'/) - 203 format(2(1pe15.8)) -c -c found the vertex, call it a Dirichlet point -c - 116 continue - bndnod(ii) = .true. - u(ii) = nuniqv - endif -c - deg = iorder-1 -c -c for each neighbor of each triangle, if the neighbor is nonpositive then -c that side of the triangle is on the boundary. mark those nodes -c - do 140 i=1,ntri -c - do 130 j=1,3 - if (neigh(j,i).le.0) then - if (j.eq.1) then - lnod= iorder - inc = deg - v1 = vertex(2,i) - v2 = vertex(3,i) - elseif (j.eq.2) then - lnod= 1 - inc = iorder - v1 = vertex(1,i) - v2 = vertex(3,i) - else - lnod= 1 - inc = 1 - v1 = vertex(1,i) - v2 = vertex(2,i) - endif -c - do 120 k=0,deg - nod = node(lnod,i) - if (.not. bndnod(nod)) then - x=((deg-k)*xvert(v1)+k*xvert(v2))/float(deg) - y=((deg-k)*yvert(v1)+k*yvert(v2))/float(deg) - call bcond(x,y,-neigh(j,i),cu,bcrhs,bctype) - if (bctype.eq.1) then - bndnod(nod)=.true. - u(nod)=bcrhs - endif - endif - lnod=lnod+inc - inc=inc-1 - if (inc.lt.1) inc=1 - 120 continue - endif - 130 continue - 140 continue -c - if (outlev.ge.4) call plttri(3,0) - if (outlev.ge.4) call outtri - if (outlev.ge.3) write(ioutpt,102) - 102 format(' node initialization complete') -c - return - end -c -c -------- initrn -c - subroutine initrn - include 'commons' - integer newnn,ordd2,i,j,sub,inc,inc2,disp,disp2,inode -c -c initialize data structures used for renumbering nodes -c -c renum contains the renumbering of the nodes ina a local numbering -c when a pair of triangles is divided. for the figures the example -c of a cubic basis is used. before division the local numbering is -c -c peak 10 -c older triangle 8 9 -c 5 6 7 -c oldest vertex 1 2 3 4 -c -c oldest vertex 1 2 3 4 -c 5 6 7 -c younger triangle 8 9 -c peak 10 -c -c when the triangles are divided, new nodes are added in the -c order (* are old nodes) -c -c peak * -c older triangle * 3 * -c * 2 * 6 * -c oldest vertex * 1 * 4 * 5 * -c * 7 * 9 * -c younger triangle * 8 * -c peak * -c -c after dividing the local numbering of the nodes is -c -c 4 4 -c 3 7 7 3 -c 2 6 9 9 6 2 -c 1 5 8 10 10 8 5 1 -c -c 1 5 8 10 10 8 5 1 -c 2 6 9 9 6 2 -c 3 7 7 3 -c 4 4 -c -c renum gives the correspondence between the new local number and -c the old local number -c -c renum(i,.) is the correspondence for the ith new triangle -c 1) the half of the older triangle with the oldest vertex (upper left) -c 2) the other half of the older triangle (upper right) -c 3) the half of the younger triangle with the oldest vertex (lower left) -c 4) the other half of the younger triangle (lower right) -c -c renum(i,j) tells how to find the jth node in the new local numbering -c for the ith triangle -c if positive, it contains the local number of the node in the -c appropriate old triangle -c if negative, it contains the negative of which new node is in -c that position -c -c with the subscripts given by the third figure above, we have for cubics -c -c 10 10 -c 8 -3 -3 8 -c 5 -2 6 6 -6 7 -c 1 -1 2 -4 -4 3 -5 4 -c -c 1 -1 2 -4 -4 3 -5 4 -c 5 -7 6 6 -9 7 -c 8 -8 -8 9 -c 10 10 -c -c - if (outlev.ge.3) write(ioutpt,100) - 100 format(' initialize node renumbering table') -c - newnn = 0 - ordd2=int(float(iorder)/2.+.6) -c -c half of the oldest triangle with the oldest node -c - inode = 1 - do 40 j=1,ordd2 - sub = j - inc = iorder - do 20 i=1,iorder-2*(j-1) - renum(1,inode) = sub - inode = inode + 1 - sub = sub + inc - inc = inc - 1 - 20 continue - if (2*j .le. iorder) then - do 30 i=1,iorder-2*j+1 - newnn = newnn - 1 - renum(1,inode) = newnn - inode = inode + 1 - 30 continue - endif - 40 continue -c -c other half of older triangle -c - disp = iorder - 1 - inc2 = iorder - 3 - inode = 1 - do 130 j=1,ordd2 - sub = iorder + 1 - j - inc = iorder - 1 - do 110 i = 1,iorder-2*(j-1) - renum(2,inode) = sub - inode = inode + 1 - sub = sub + inc - inc = inc - 1 - 110 continue - if (2*j .le. iorder) then - if (2*j .le. iorder-1) then - do 120 i=1,iorder-2*j - newnn = newnn - 1 - renum(2,inode) = newnn - inode = inode + 1 - 120 continue - endif - renum(2,inode) = - disp - inode = inode + 1 - disp = disp + inc2 - inc2 = inc2 - 2 - endif - 130 continue -c -c half of the younger triangle with the oldest node -c - disp = 1 - inc2 = iorder - 1 - inode = 1 - do 240 j=1,ordd2 - sub = j - inc = iorder - do 220 i=1,iorder-2*(j-1) - renum(3,inode) = sub - inode = inode + 1 - sub = sub + inc - inc = inc - 1 - 220 continue - if (2*j .le. iorder) then - renum(3,inode) = -disp - inode = inode + 1 - disp = disp + inc2 - inc2 = inc2 - 2 - if (2*j .le. iorder-1) then - do 230 i=1,iorder-2*j - newnn = newnn - 1 - renum(3,inode) = newnn - inode = inode + 1 - 230 continue - endif - endif - 240 continue -c -c other half of younger triangle -c - if (iorder .eq. 2*int(iorder/2)) then - disp = 1 + (iorder*iorder)/4 - else - disp = 1 + (iorder*iorder-1)/4 - endif - inc2 = iorder - 2 - disp2 = (iorder*iorder + iorder - 4)/2 - inode = 1 - do 330 j=1,ordd2 - sub = iorder + 1 - j - inc = iorder - 1 - do 310 i = 1,iorder-2*(j-1) - renum(4,inode) = sub - inode = inode + 1 - sub = sub + inc - inc = inc - 1 - 310 continue - if (2*j .lt. iorder) then - renum(4,inode) = -disp - inode = inode + 1 - disp = disp + inc2 - inc2 = inc2 - 2 - if (2*j .le. iorder-2) then - do 320 i=1,iorder-2*j-1 - newnn = newnn - 1 - renum(4,inode) = newnn - inode = inode + 1 - 320 continue - endif - renum(4,inode) = -disp2 - inode = inode + 1 - disp2 = disp2 + inc2 - endif - 330 continue - if (iorder .eq. 2*int(iorder/2)) then - renum(4,inode) = -(iorder*iorder)/4 - endif -c - if (outlev.ge.3) write(ioutpt,101) - 101 format(' renumbering table complete') -c - return - end -c -c ------- valinp -c - subroutine valinp - include 'commons' - integer t,t2,v,iv,icount -c -c check the validity of user input -c - 99 format(' ********FATAL ERROR********'/) -c -c check the order of the method -c - if (iorder.lt.2) then - write(ioutpt,99) - write(ioutpt,100) iorder - 100 format(' order of the method=',i6,' must be at least 2') - stop - endif - if (iorder.gt.4) then - write(ioutpt,200) iorder,nqpt - 200 format(' ********WARNING********'/ - 1 ' iorder=',i6,' is greater than 4.'/ - 2 ' using user provided quadrature rule with',i6,' points') - endif - if (iorder.gt.ndord) then - write(ioutpt,99) - write(ioutpt,201) iorder,ndord - 201 format(' iorder=',i6,' is .gt. ndord=',i4) - stop - endif -c -c make sure maximum allowed values do not exceed dimensions -c - if (mxvert.gt.ndvert) then - write(ioutpt,251) mxvert,ndvert - 251 format(' ********WARNING********'/ - . ' mxvert=',i10,' is greater than ndvert=',i10/ - . ' resetting mxvert equal to ndvert') - mxvert=ndvert - endif - if (mxtri.gt.ndtri) then - write(ioutpt,252) mxtri,ndtri - 252 format(' ********WARNING********'/ - . ' mxtri=',i10,' is greater than ndtri=',i10/ - . ' resetting mxtri equal to ndtri') - mxtri=ndtri - endif - if (mxnode.gt.ndnode) then - write(ioutpt,253) mxnode,ndnode - 253 format(' ********WARNING********'/ - . ' mxnode=',i10,' is greater than ndnode=',i10/ - . ' resetting mxnode equal to ndnode') - mxnode=ndnode - endif - if (mxlev.gt.ndlev) then - write(ioutpt,254) mxlev,ndlev - 254 format(' ********WARNING********'/ - . ' mxlev=',i6,' is greater than ndlev=',i6/ - . ' resetting mxlev equal to ndlev') - mxlev=ndlev - endif -c -c check that number of vertices increases during refinement -c - if (mgfreq.le.1.) then - write(ioutpt,99) - write(ioutpt,300) mgfreq - 300 format(' mgfreq=',1pe15.8,' is .le. 1.') - stop - endif -c -c check that the initial triangulation doesn't exceed dimensions -c - if (nvert.gt.ndvert .or. nvert.le.0) then - write(ioutpt,99) - write(ioutpt,351) nvert,ndvert - 351 format(' initial nvert=',i6,' is .gt. ndvert=',i6,' or .le. 0') - stop - endif - if (ntri.gt.ndtri .or. ntri.le.0) then - write(ioutpt,99) - write(ioutpt,352) ntri,ndtri - 352 format(' initial ntri=',i6,' is .gt. ndtri=',i6,' or .le. 0') - stop - endif - if ((iorder-1)*(iorder-1)*nvert.gt.ndnode) then - write(ioutpt,99) - write(ioutpt,353) (iorder-1)*(iorder-1)*nvert,ndnode - 353 format(' estimated initial nnode=',i6,' is .gt. ndnode=',i6) - stop - endif -c -c check vertex alignment and count -c - do 20 t=1,ntri - do 20 v=1,3 - iv=vertex(v,t) - if (iv.le.0 .or. iv.gt.nvert) then - write(ioutpt,99) - write(ioutpt,400) v,t,iv,nvert - 400 format(' vertex(',i6,',',i6,')=',i6, - 1 ' is .le.0 or .gt. nvert=',i6) - stop - endif - icount=0 - do 10 t2=t,ntri - if (v.eq.1) then - if (vertex(2,t2).eq.iv .or. vertex(3,t2).eq.iv) then - write(ioutpt,99) - write(ioutpt,500) iv - stop - endif - endif - if (v.eq.2) then - if (vertex(1,t2).eq.iv .or. vertex(3,t2).eq.iv) then - write(ioutpt,99) - write(ioutpt,500) iv - stop - endif - endif - if (v.eq.3) then - if (vertex(1,t2).eq.iv .or. vertex(2,t2).eq.iv) then - write(ioutpt,99) - write(ioutpt,500) iv - stop - endif - endif - 500 format(' vertex',i6,' occurs in 2 columns of vertex') - if (vertex(v,t2).eq.iv) icount=icount+1 - 10 continue - if ((v.eq.3.and.icount.gt.4).or.(v.ne.3.and.icount.gt.8)) then - write(ioutpt,99) - write(ioutpt,600) iv - 600 format(' vertex',i6,' occurs in too many triangles') - stop - endif - 20 continue -c - return - end -c -c -------- refine -c - subroutine refine - include 'commons' - integer t,limit - external clock -c -c refine triangulation -c - if (outlev.ge.2) write(ioutpt,100) - 100 format(/' begin refinement') -c -c begin timing -c - timerl = clock(0) -c -c --- uniform refinement --- -c - if (unifrm) then -c - nlev=nlev+1 - if (nlev.gt.mxlev) then - ierr=3 - nlev=nlev-1 - return - endif - limit = ntri - do 20 t=1,limit - if (iabs(vrtlev(vertex(3,t))).ne.nlev) call divtri(t) - 20 continue -c -c --- adaptive refinement --- -c - else -c -c refine until number of vertices is doubled -c - ntarg = int(mgfreq*nvert) - if (ntarg.le.nvert) ntarg=nvert+1 -c -c get triangle to divide -c - 1 call divnxt(t) -c -c divide triangle -c - call divtri(t) -c -c repeat if necessary -c - if (nvert .lt. ntarg .and. ierr .eq. 0) go to 1 -c - endif -c -c finish timing -c - timerl = clock(0) - timerl - timert = timert + timerl -c -c write data file for run time graphics, check the menu, and -c update the plots -c - if (outlev.ge.2 .and. grafic) write(ioutpt,200) - 200 format(' begin update to triangulation graphics') - if (grafic) then - call filtri - if (menuon) call mn2mg - call grftri - endif - if (outlev.ge.2 .and. grafic) write(ioutpt,300) - 300 format(' graphics complete') -c -c debug output -c - if(outlev.ge.2) call outref - if(outlev.ge.4) then - call outtri - call outmat - endif -c - return - end -c -c -------- divnxt -c - subroutine divnxt(t) - include 'commons' - integer t -c -c determine next triangle to divide -c -c if top error indicator list is empty, shift lists -c - 1 if (eihead(1) .ne. -1) go to 2 - eihead(1) = eihead(2) - eihead(2) = eihead(3) - eihead(3) = eihead(4) - eihead(4) = -1 - eitail(1) = eitail(2) - eitail(2) = eitail(3) - eitail(3) = eitail(4) - eitail(4) = -1 - if (outlev.ge.4) write(ioutpt,100) - eimax=eimax*mgfreq**(-iorder/2.) - 100 format(' shift error indicator lists for smaller eimax') - go to 1 - 2 continue -c -c return first triangle on top list -c - t = eihead(1) -c -c verify that the triangle isn't too small -c - xdiff = abs(xvert(vertex(1,t))-xvert(vertex(2,t))) - temp = abs(xvert(vertex(1,t))-xvert(vertex(3,t))) - if (temp.gt.xdiff) xdiff=temp - temp = abs(xvert(vertex(3,t))-xvert(vertex(2,t))) - if (temp.gt.xdiff) xdiff=temp - ydiff = abs(yvert(vertex(1,t))-yvert(vertex(2,t))) - temp = abs(yvert(vertex(1,t))-yvert(vertex(3,t))) - if (temp.gt.ydiff) ydiff=temp - temp = abs(yvert(vertex(3,t))-yvert(vertex(2,t))) - if (temp.gt.ydiff) ydiff=temp - xmax = abs(xvert(vertex(1,t))) - temp = abs(xvert(vertex(2,t))) - if (temp.gt.xmax) xmax=temp - temp = abs(xvert(vertex(3,t))) - if (temp.gt.xmax) xmax=temp - ymax = abs(yvert(vertex(1,t))) - temp = abs(yvert(vertex(2,t))) - if (temp.gt.ymax) ymax=temp - temp = abs(yvert(vertex(3,t))) - if (temp.gt.ymax) ymax=temp - if (xdiff/xmax.lt.10.*r1mach(4) .or. - . ydiff/ymax.lt.10.*r1mach(4)) then - call elstrm(t) - temp=errind(t) - errind(t)=0. - call elstad(t) - errind(t)=temp - go to 1 - endif -c - return - end -c -c -------- dtpair -c - subroutine dtpair(t1,t2) - include 'commons' - integer t1,t2,t(4),i,limit -c -c divide the compatably divisible pair of triangles t1,t2 -c t2<=0 if base of t1 is on boundary -c -c check for too many vertices, triangles or levels -c - if (nvert.ge.mxvert-2) then - ierr = 1 - elseif ((t2.gt.0 .and. ntri.ge.mxtri-2) - 1 .or. (t2.le.0 .and. ntri.ge.mxtri-1) ) then - ierr = 2 - elseif (iabs(vrtlev(vertex(3,t1))).ge.mxlev) then - ierr = 3 - elseif ((t2.gt.0 .and. nnode+nnodev.gt.mxnode) - 1 .or. (t2.le.0 .and. nnode+nnodvb.gt.mxnode)) then - ierr = 4 - endif - if (ierr.ne.0) return -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) t1,t2 - 101 format(' divide triangle pair ',2i6) -c -c -c begin correction of existing matrix and right side values by -c subtracting off the old inner products over the triangles divided -c - call oldip(t1,t2) -c -c adjust the data structures for vertices and triangles to divide -c - if (t2.gt.0) then - call adjds(t1,t2) - else - call adjdsb(t1) - endif -c -c finish correction fo existing matrix and right side values by -c adding in the new inner products over the new triangles -c - call newip(t1,t2) -c -c set new equation in the matrix and right side and set first -c approximate solution at the new vertex -c - call neweq(t1,t2) -c -c set up the error indicator problem for the four new triangles -c Three cases -- boundary, -c old (problem already defined in neighbor triangle) and normal. -c - if (t2.gt.0) then - t(1) = t1 - t(2) = t2 - t(3) = ntri-1 - t(4) = ntri - limit= 4 - else - t(1) = t1 - t(2) = ntri - limit= 2 - endif - do 10 i=1,limit - if (neigh(3,t(i)).le.0) then - call setei(t(i)) - elseif (neigh(3,neigh(3,t(i))).eq.t(i)) then - call setei2(neigh(3,t(i)),t(i)) - else - call setei(t(i)) - endif - 10 continue -c -c perform local relaxations -c - call locrlx(t1) -c - return - end -c -c -------- divtri -c - subroutine divtri(t) - include 'commons' - integer t,t1,t2,stkpnt -c -c divide the triangle t by bisection -c -c construct the chain of triangles to be divided for compatability -c - stkpnt = 1 - stack(1) = t - t1 = t - 1 if (neigh(3,t1).le.0) go to 2 - if (neigh(3,neigh(3,t1)).eq.t1) go to 2 - stkpnt=stkpnt+1 - t1 = neigh(3,t1) - stack(stkpnt) = t1 - go to 1 - 2 continue -c -c debug output -c - if (outlev.ge.4) then - write(ioutpt,100) - write(ioutpt,101) (stack(i),i=1,stkpnt) - 100 format(' stack of triangles to divide is') - 101 format(13i6) - endif -c -c divide triangles in the chain -c - 3 if (stkpnt .eq. 0 .or. ierr .ne. 0 .or. - 1 (nvert .ge. ntarg .and. .not. unifrm)) go to 4 - t1 = stack(stkpnt) -c -c get the neighbor across from the peak of t1 -c - t2 = neigh(3,t1) -c -c divide t1 and t2 -c make sure the one with the error indicator comes first -c - if (coefei(iorder*iorder+1,1,t1).ne.0.) then - call dtpair(t1,t2) - else - call dtpair(t2,t1) - endif -c - stkpnt = stkpnt - 1 - go to 3 - 4 continue -c - return - end -c -c -------- adjds -c - subroutine adjds(t1,t2) - include 'commons' - integer t1,t2,level,i,nbr,v1,v2,v3,v4,i3,i4 -c -c adjust the data structures for vertices and triangles to -c divide the pair of triangles t1 and t2 -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) - 101 format(' adjust data structures for', - 1 ' vertices and triangles') -c -c set vertex numbers -c - v1 = vertex(1,t1) - v2 = vertex(2,t1) - v3 = vertex(3,t1) - v4 = vertex(3,t2) -c -c vertex data structures -c - nvert = nvert+1 - level = iabs(vrtlev(v3)) + 1 - if (level .gt. nlev) nlev = level - lvert(level) = lvert(level)+1 - vrtlev(nvert) = level - nextvt(nvert) = frstvt(level) - frstvt(level) = nvert - xvert(nvert) = (xvert(v1)+xvert(v2))/2. - yvert(nvert) = (yvert(v1)+yvert(v2))/2. -c -c define new nodes -c - call defnod(t1,t2) - do 9 i=nwndvt(nvert),nnode - inuse(i)=.false. - 9 continue -c -c triangle data structures -c - ntri = ntri + 2 -c - vertex(1,ntri-1) = v2 - vertex(2,ntri-1) = v3 - vertex(3,ntri-1) = nvert - vertex(1,ntri ) = v2 - vertex(2,ntri ) = v4 - vertex(3,ntri ) = nvert - vertex(2,t1 ) = v3 - vertex(3,t1 ) = nvert - vertex(2,t2 ) = v4 - vertex(3,t2 ) = nvert -c - neigh(1,ntri-1) = t1 - neigh(2,ntri-1) = ntri - neigh(3,ntri-1) = neigh(1,t1) - neigh(1,ntri ) = t2 - neigh(2,ntri ) = ntri-1 - neigh(3,ntri ) = neigh(1,t2) - neigh(3,t1 ) = neigh(2,t1) - neigh(2,t1 ) = t2 - neigh(1,t1 ) = ntri-1 - neigh(3,t2 ) = neigh(2,t2) - neigh(2,t2 ) = t1 - neigh(1,t2 ) = ntri -c -c correct neighbor of neighbors -c - nbr = neigh(3,ntri-1) - if (nbr .gt. 0) then - do 10 i=1,3 - if (neigh(i,nbr) .eq. t1) neigh(i,nbr) = ntri-1 - 10 continue - endif -c - nbr = neigh(3,ntri) - if (nbr .gt. 0) then - do 20 i=1,3 - if (neigh(i,nbr) .eq. t2) neigh(i,nbr) = ntri - 20 continue - endif -c -c set triangles next to vertices -c - do 30 i=8,1,-1 - if (tringl(i,v2).eq.t1) tringl(i,v2)=ntri-1 - if (tringl(i,v2).eq.t2) tringl(i,v2)=ntri - if (tringl(i,v3).eq.0) i3=i - if (tringl(i,v4).eq.0) i4=i - tringl(i,nvert)=0 - 30 continue - tringl(i3,v3) = ntri-1 - tringl(i4,v4) = ntri - tringl(1,nvert) = t1 - tringl(2,nvert) = t2 - tringl(3,nvert) = ntri-1 - tringl(4,nvert) = ntri -c -c remove t1 from error indicator lists -c - call elstrm(t1) -c -c debug output -c - if(outlev.ge.5) then - write(ioutpt,201) - write(ioutpt,300) t1,(vertex(i,t1),i=1,3), - 1 (neigh(i,t1),i=1,3) - write(ioutpt,300) t2,(vertex(i,t2),i=1,3), - 1 (neigh(i,t2),i=1,3) - write(ioutpt,300) ntri-1,(vertex(i,ntri-1),i=1,3), - 1 (neigh(i,ntri-1),i=1,3) - write(ioutpt,300) ntri,(vertex(i,ntri),i=1,3), - 1 (neigh(i,ntri),i=1,3) - write(ioutpt,301) nvert,vrtlev(nvert),xvert(nvert), - 1 yvert(nvert) - write(ioutpt,302) t1,(node(i,t1),i=1,nnodtr) - write(ioutpt,302) t2,(node(i,t2),i=1,nnodtr) - write(ioutpt,302) ntri-1,(node(i,ntri-1),i=1,nnodtr) - write(ioutpt,302) ntri,(node(i,ntri),i=1,nnodtr) - endif - 201 format(' new triangles, vertices, and neighbors are:') - 300 format(1x,i5,5x,3i5,5x,3i5) - 301 format(' new vertex ',i5,' has level',i4/ - 1 ' coordinates',2(2x,1pe15.8)) - 302 format(' nodes for triangle ',i5/10(10i6/)) -c - return - end -c -c -------- adjdsb -c - subroutine adjdsb(t) - include 'commons' - integer t,i,level,nbr,v1,v2,v3,i3 -c -c adjust the data structures for vertices and triangles to -c divide boundary triangle t -c - if (outlev .ge. 4) write(ioutpt,101) - 101 format(' adjust data structures for', - 1 ' vertices and triangles') -c -c set vertex numbers -c - v1 = vertex(1,t) - v2 = vertex(2,t) - v3 = vertex(3,t) -c -c vertex data structures -c - nvert = nvert + 1 - level = iabs(vrtlev(v3)) + 1 - if (level .gt. nlev) nlev=level - lbvert(level) = lbvert(level)+1 -c negate level to indicate dirichlet b.c. - vrtlev(nvert) = -level - nextvt(nvert) = frstvt(level) - frstvt(level) = nvert - xvert(nvert) = (xvert(v1) + xvert(v2))/2. - yvert(nvert) = (yvert(v1) + yvert(v2))/2. -c -c define new nodes -c - call defnod(t,0) - do 9 i=nwndvt(nvert),nnode - inuse(i)=.false. - 9 continue -c -c triangle data structures -c - ntri = ntri + 1 -c - vertex(1,ntri) = v2 - vertex(2,ntri) = v3 - vertex(3,ntri) = nvert - vertex(2,t ) = v3 - vertex(3,t ) = nvert -c - neigh(1,ntri) = t - neigh(2,ntri) = neigh(3,t) - neigh(3,ntri) = neigh(1,t) - neigh(3,t ) = neigh(2,t) - neigh(2,t ) = neigh(2,ntri) - neigh(1,t ) = ntri -c -c correct neighbor of neighbor -c - nbr = neigh(3,ntri) - if (nbr .gt. 0) then - do 10 i=1,3 - if (neigh(i,nbr) .eq. t) neigh(i,nbr) = ntri - 10 continue - endif -c -c set triangles next to vertices -c - do 30 i=8,1,-1 - if (tringl(i,v2).eq.t) tringl(i,v2)=ntri - if (tringl(i,v3).eq.0) i3=i - tringl(i,nvert)=0 - 30 continue - tringl(i3,v3) = ntri - tringl(1,nvert) = t - tringl(2,nvert) = ntri -c -c remove t from error indicator lists -c - call elstrm(t) -c -c debug output -c - if (outlev .ge. 5) then - write(ioutpt,201) - write(ioutpt,300) t,(vertex(i,t),i=1,3),(neigh(i,t),i=1,3) - write(ioutpt,300) ntri,(vertex(i,ntri),i=1,3), - 1 (neigh(i,ntri),i=1,3) - write(ioutpt,301) nvert,vrtlev(nvert),xvert(nvert), - 1 yvert(nvert) - write(ioutpt,302) t,(node(i,t),i=1,nnodtr) - write(ioutpt,302) ntri,(node(i,ntri),i=1,nnodtr) - endif - 201 format(' new triangles, vertices, and neighbors are:') - 300 format(1x,i5,5x,3i5,5x,3i5) - 301 format(' new vertex ',i5,' has level',i4/' coordinates', - 1 2(2x,1pe15.8)) - 302 format(' nodes and bndnod for triangle ',i5/10(10i6/)) -c - return - end -c -c -------- defnod -c - subroutine defnod(t1,t2) - include 'commons' - integer i,j,t1,t2,limit,bctype - real bcrhs,cu -c -c define the nodes for the descendents of the triangle pair t1,t2 -c -c set first new node associated with the new vertex -c - nwndvt(nvert)=nnode+1 -c -c set old nodes associated with the new vertex -c - do 10 i=1,nnodtr - olndvt(i,nvert)=node(i,t1) - 10 continue - if (t2.ne.0) then - do 20 i=iorder+1,nnodtr - olndvt(nnodtr-iorder+i,nvert)=node(i,t2) - 20 continue - endif -c -c default new nodes as interior, fix boundary later -c - if (t2.ne.0) then - limit=nnodev - else - limit=nnodvb - endif - do 30 i=1,limit - bndnod(nnode+i)=.false. - 30 continue -c -c descendents of t1 -c - do 40 i=1,nnodtr - hldnod(i) = node(i,t1) - 40 continue -c -c nodes for the new t1 -c - do 50 i=1,nnodtr - j=renum(1,i) - if (j.gt.0) then - node(i,t1)=hldnod(j) - else - node(i,t1)=nnode-j - endif - 50 continue -c -c nodes for the other part of t1 -c - do 60 i=1,nnodtr - j=renum(2,i) - if (j.gt.0) then - node(i,ntri+1)=hldnod(j) - else - node(i,ntri+1)=nnode-j - endif - 60 continue -c -c descendents of t2. If t2=0 then t1 is boundary -c - if (t2 .ne. 0) then -c - do 70 i=1,nnodtr - hldnod(i) = node(i,t2) - 70 continue -c -c nodes for the new t2 -c - do 80 i=1,nnodtr - j=renum(3,i) - if (j.gt.0) then - node(i,t2)=hldnod(j) - else - node(i,t2)=nnode-j - endif - 80 continue -c -c nodes for the other part of t2 -c - do 90 i=1,nnodtr - j=renum(4,i) - if (j.gt.0) then - node(i,ntri+2)=hldnod(j) - else - node(i,ntri+2)=nnode-j - endif - 90 continue - nnode=nnode+nnodev -c - else -c -c if t2 is 0, mark boundary nodes and copy boundary condition -c from error indicator problem -c -c@@@ call is just to get bctype - call bcond(xvert(vertex(1,t1)),yvert(vertex(1,t1)), - . -neigh(3,t1),cu,bcrhs,bctype) - if (bctype.eq.1) then - do 110 i=1,nnodvb - if (nbasch(i).eq.iorder) then - bndnod(nnode+i)=.true. - u(nnode+i)=bcei(i,t1) - endif - 110 continue - endif - nnode=nnode+nnodvb -c - endif -c - return - end -c -c -------- oldip -c - subroutine oldip(t1,t2) - include 'commons' - integer t1,t2,limit,i,j,t -c -c compute the inner products of the old nodes over the 2 -c old triangles t1 and t2 and subtract from the matrix and rs. -c if t2<=0 (boundary) 1 triangle -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) - 101 format(' subtract old inner products') -c - if (t2.le.0) then - limit=1 - else - limit=2 - endif -c -c for each of the triangles -c - do 20 i=1,limit -c -c pick triangle -c - if (i.eq.1) then - t=t1 - else - t=t2 - endif -c -c do quadratures -c - call quad(t,1) -c -c update right side -c - do 10 j=1,naddrs - rs(rowrs(j))=rs(rowrs(j))-addrs(j) - if (outlev.ge.5) write(ioutpt,102) rowrs(j),rs(rowrs(j)) - 10 continue -c -c negate add to subtract -c - do 15 j=1,nadd - add(j)=-add(j) - 15 continue -c -c update matrix -c - call addmat -c - 20 continue - 102 format(' rowrs(',i6,') <-- ',1pe15.8) -c - return - end -c -c -------- newip -c - subroutine newip(t1,t2) - include 'commons' - integer t1,t2,limit,i,j,t -c -c compute the new inner products of the old nodes over the 4 -c new triangles (t1,t2,ntri-1 and ntri) and add to matrix and rs -c if t2<=0 (boundary) 2 triangles (t1,ntri) -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) - 101 format(' add new inner products') -c - if (t2.le.0) then - limit=2 - else - limit=4 - endif -c -c for each of the triangles -c - do 20 i=1,limit -c -c pick triangle -c - if (i.eq.1) then - t=t1 - elseif (i.eq.2) then - t=ntri - elseif (i.eq.3) then - t=t2 - else - t=ntri-1 - endif -c -c do quadratures -c - call quad(t,2) -c -c update right side -c - do 10 j=1,naddrs - rs(rowrs(j))=rs(rowrs(j))+addrs(j) - if (outlev.ge.5) write(ioutpt,102) rowrs(j),rs(rowrs(j)) - 10 continue -c -c update matrix -c - call addmat -c - 20 continue - 102 format(' rowrs(',i6,') <-- ',1pe15.8) -c - return - end - -c -c -------- neweq -c - subroutine neweq(t1,t2) - include 'commons' - integer t1,t2,i,j,node1 -c -c set new rows of matrix (from dividing triangle pair t1,t2) -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) t1 - 101 format(' set new equations from dividing triangle ',i6) -c -c set idcoef for new rows -c - call setidn(t1) -c -c change idcoef for effected old rows -c - call convid(nvert,1) -c -c copy rs and coef from error indicator problem -c - node1=nwndvt(nvert) - do 30 i=node1,nnode - rs(i)=rsei(i-node1+1,t1) - do 10 j=1,iorder*iorder - coef(j,i)=coefei(j,i-node1+1,t1) - 10 continue - do 20 j=iorder*iorder+1,mxidlo - coef(j,i)=0. - 20 continue - coef(mxidlo+1,i)=coefei(iorder*iorder+1,i-node1+1,t1) - 30 continue -c -c get values for coef for new node - new node inner products -c from bloke2 -c - do 50 i=node1,nnode - do 50 j=1,mxidlo - if (idcoef(j,i).ge.node1) then - coef(j,i)=bloke2(idcoef(j,i)-node1+1,i-node1+1,t1) - endif - 50 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,102) - do 110 i=nwndvt(nvert),nnode - write(ioutpt,103) (idcoef(j,i),coef(j,i),j=1,mxidlo), - 1 i,coef(mxidlo+1,i) - write(ioutpt,104) rs(i) - write(ioutpt,105) (idcoef(j,i),j=mxidlo+1,mxidup) - 110 continue - endif - 102 format(' new equations are ') - 103 format(3(i6,1pe15.8)) - 104 format(' rs ',1pe15.8) - 105 format(11i6) -c -c local relaxation at new nodes -c - call rlxred(nvert) -c -c debug output -c - if (outlev.ge.5) write(ioutpt,100) (i,u(i),i=nwndvt(nvert),nnode) - 100 format(' initial guess for node ',i6,2x,1pe15.8) -c - return - end -c -c -------- setidn -c - subroutine setidn(t1) - include 'commons' - integer node1,i,j,limit,t,tri,nod1,nod2,c,t1 -c -c set idcoef for new rows -c -c copy idcoef for old node - new node inner products from -c error indicator problem -c - node1=nwndvt(nvert)-1 - if (vrtlev(nvert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 30 i=1,limit - do 10 j=1,iorder*iorder - idcoef(j,node1+i)=idcoei(j,i,t1) - 10 continue - do 20 j=iorder*iorder+1,mxidup - idcoef(j,node1+i)=0 - 20 continue - 30 continue -c -c set idcoef for new node -- new node inner products -c - if (iorder.gt.2) then - if (vrtlev(nvert).gt.0) then - limit=4 - else - limit=2 - endif -c - do 130 t=1,limit - tri=tringl(t,nvert) - do 120 i=1,nnodtr - nod1=node(i,tri) - if (nod1.gt.node1) then - do 110 j=1,nnodtr - nod2=node(j,tri) - if (nod2.gt.node1 .and. nod2.ne.nod1) then - if(nod2.lt.nod1) then - c=1 - 1 if (idcoef(c,nod1).eq.0 .or. - 1 idcoef(c,nod1).eq.nod2) go to 2 - if (c.ge.mxidlo) then - write(ioutpt,101) - stop - 101 format(' ********FATAL ERROR********'// - 1 ' ran out of room in idcoef', - 1 ' lower part in setidn') - endif - c=c+1 - go to 1 - 2 continue - idcoef(c,nod1)=nod2 - else - c=mxidlo+1 - 3 if (idcoef(c,nod1).eq.0 .or. - 1 idcoef(c,nod1).eq.nod2) go to 4 - if (c.ge.mxidup) then - write(ioutpt,102) - stop - 102 format(' ********FATAL ERROR********'// - 1 ' ran out of room in idcoef', - 1 ' upper part in setidn') - endif - c=c+1 - go to 3 - 4 continue - idcoef(c,nod1)=nod2 - endif - endif - 110 continue - endif - 120 continue - 130 continue - endif -c - return - end -c -c -------- addmat -c - subroutine addmat - include 'commons' - integer i,j,c,r -c -c add nadd values in add to the matrix in -c positions given by (row,col) -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) nadd - endif -c -c for each change, find the idcoef with col(i) in row(i) -c and add add(i) -c -c begin the search for the column of coef with the position -c that the previous value was in, and wrap around -c - lastc=1 - do 20 i=1,nadd - r=row(i) - if (row(i).eq.col(i)) then -c special case for diagonal entry - c=mxidlo+1 - lastc=1 - else - c=0 -c search for column - j=lastc - jfirst=j-1 - if (jfirst.le.0) jfirst=mxidlo - 1 if (j.eq.jfirst .or. idcoef(j,r).eq.col(i)) go to 2 - if (j.ge.mxidlo .or. idcoef(j,r).eq.0) j=0 - j=j+1 - go to 1 - 2 continue -c verify that the column was found - if (idcoef(j,r).eq.col(i)) c=j - lastc=c - endif - if(c.eq.0) go to 999 -c add - coef(c,r) = coef(c,r) + add(i) -c - 20 continue - return -c -c error that should not occur - couldnt find location -c - 999 write(ioutpt,100) col(i),row(i) - stop -c - 100 format(' ********FATAL ERROR********'// - 1 ' couldnt find column ',i10,' in row ',i10, - 2 ' while adding a value to the matrix') - 200 format(' add ',i3,' values to matrix') -c - end -c -c -------- quad -c - subroutine quad(t,itype) - include 'commons' - integer t,itype,i,j,k,sub,qp,node1,node2,bctype,nlist(ndord) - real x1,x2,x3,y1,y2,y3,det,area,dz1dx, - 1 dz2dx,dz3dx,dz1dy,dz2dy,dz3dy,qpx,qpy, - 2 db1dx,db2dx,db1dy,db2dy - real bcrhs,cu - real qpf,qpp,qpq,qpr - logical bndsid(3) -c -c compute integrals over triangle t -c -c itype determines which integrals to compute -c = 1 all -c = 2 old node - right side and old node - old node -c = 3 new node - right side, new node - new node and -c new node - old node -c -c the nadd values for the matrix in add go in positions (row,col) -c the naddrs values for the right side in addrs go rows rowrs -c -c compute linear transformation from reference triangle -c - x1=xvert(vertex(1,t)) - x2=xvert(vertex(2,t)) - x3=xvert(vertex(3,t)) - y1=yvert(vertex(1,t)) - y2=yvert(vertex(2,t)) - y3=yvert(vertex(3,t)) -c - det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) - area = abs(det/2.) -c - dz1dx = (y2-y3)/det - dz2dx = (y3-y1)/det - dz3dx = (y1-y2)/det - dz1dy = (x3-x2)/det - dz2dy = (x1-x3)/det - dz3dy = (x2-x1)/det -c -c determine which sides of the triangle are boundary with -c non-Dirichlet boundary conditions -c - do 5 i=1,3 - bndsid(i) = .false. - if (neigh(i,t).le.0) then -c@@@ call is just to get bctype - call bcond(x1,y1,-neigh(i,t),cu,bcrhs,bctype) - if (bctype.ne.1) bndsid(i) = .true. - endif - 5 continue -c -c in local numbering, determine which bases to use and -c initialize right side at 0 -c - if (itype.eq.1) then -c compute all inner products - do 10 i=1,nnodtr - rowrs(i)=i - addrs(i)=0. - 10 continue - naddrs=nnodtr -c - elseif (itype.eq.2) then -c -c only inner products of old nodes with old nodes - naddrs=0 - sub=0 - do 30 i=1,(iorder+1)/2 - do 20 j=1,iorder-2*i+2 - sub=sub+1 - naddrs=naddrs+1 - rowrs(naddrs)=sub - addrs(naddrs)=0. - 20 continue - sub=sub+iorder-2*i+1 - 30 continue -c - else -c -c only new nodes with new nodes and old nodes - naddrs=0 - sub=iorder - do 50 i=1,iorder/2 - do 40 j=1,iorder-2*i+1 - sub=sub+1 - naddrs=naddrs+1 - rowrs(naddrs)=sub - addrs(naddrs)=0. - 40 continue - sub=sub+iorder-2*i - 50 continue -c - endif -c -c set row and col for all combinations of nodes used and -c initalize inner products at 0 -c - nadd=0 - do 60 i=1,naddrs - do 60 j=i,naddrs - nadd=nadd+1 - row(nadd)=rowrs(j) - col(nadd)=rowrs(i) - add(nadd)=0. - 60 continue -c -c for itype=3, extend row and col to include old node-new node -c - if (itype.eq.3) then - sub=0 - do 90 i=1,(iorder+1)/2 - do 80 j=1,iorder-2*i+2 - sub=sub+1 - do 70 k=1,naddrs - nadd=nadd+1 - row(nadd)=rowrs(k) - col(nadd)=sub - add(nadd)=0. - 70 continue - 80 continue - sub=sub+iorder-2*i+1 - 90 continue - endif -c -c -c compute integrals -c -c -c for each quadrature point . . . -c - do 130 qp=1,nqpt -c -c compute x-y coordinate of quadrature point -c - qpx = x1*quadpt(1,qp) + x2*quadpt(2,qp) + x3*quadpt(3,qp) - qpy = y1*quadpt(1,qp) + y2*quadpt(2,qp) + y3*quadpt(3,qp) -c -c evaluate pde coefficents and right side at quadrature point -c - call pde(qpx,qpy,qpp,qpq,qpr,qpf) -c -c for each basis pair . . . -c - do 110 i=1,nadd -c -c compute derivatives of bases wrt x and y at quadrature point -c - db1dx = qpdbdz(1,row(i),qp)*dz1dx - 1 + qpdbdz(2,row(i),qp)*dz2dx - 2 + qpdbdz(3,row(i),qp)*dz3dx - db1dy = qpdbdz(1,row(i),qp)*dz1dy - 1 + qpdbdz(2,row(i),qp)*dz2dy - 2 + qpdbdz(3,row(i),qp)*dz3dy - db2dx = qpdbdz(1,col(i),qp)*dz1dx - 1 + qpdbdz(2,col(i),qp)*dz2dx - 2 + qpdbdz(3,col(i),qp)*dz3dx - db2dy = qpdbdz(1,col(i),qp)*dz1dy - 1 + qpdbdz(2,col(i),qp)*dz2dy - 2 + qpdbdz(3,col(i),qp)*dz3dy -c -c contribution of this quadrature point to this integral -c - add(i) = add(i) + - 1 quadw(qp) * ( qpp*db1dx*db2dx + qpq*db1dy*db2dy - 2 + qpr*qpbas(row(i),qp)*qpbas(col(i),qp) ) -c - 110 continue -c -c right side integral -c - do 120 i=1,naddrs - addrs(i) = addrs(i) + - 1 quadw(qp) * qpf * qpbas(rowrs(i),qp) - 120 continue - 130 continue -c -c finish integrals by multiplying by the area of the triangle -c - do 140 i=1,naddrs - addrs(i) = addrs(i)*area - 140 continue - do 150 i=1,nadd - add(i) = add(i)*area - 150 continue -c -c compute boundary integrals -c - do 155 i=1,3 - if (bndsid(i)) then -c make list of nodes on this boundary side - if (i.eq.1) then - do 151 j=1,iorder - nlist(j) = renum(2,j) - 151 continue - xx1 = x2 - yy1 = y2 - xx2 = x3 - yy2 = y3 - elseif (i.eq.2) then - do 152 j=1,iorder - nlist(j) = renum(1,j) - 152 continue - xx1 = x1 - yy1 = y1 - xx2 = x3 - yy2 = y3 - else - do 153 j=1,iorder - nlist(j) = j - 153 continue - xx1 = x1 - yy1 = y1 - xx2 = x2 - yy2 = y2 - endif -c - call quadb(nlist,xx1,yy1,xx2,yy2,t,i) - endif - 155 continue -c -c change local numbering of nodes to global numbering -c - if (itype.ne.3) then -c - do 160 i=1,naddrs - rowrs(i)=node(rowrs(i),t) - 160 continue -c - do 170 i=1,nadd - node1=node(row(i),t) - node2=node(col(i),t) - if (node1.gt.node2) then - row(i)=node1 - col(i)=node2 - else - row(i)=node2 - col(i)=node1 - endif - 170 continue -c - endif -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) t - 200 format(' integrals over triangle ',i6/' row,col,matrix') - write(ioutpt,300) (row(i),col(i),add(i),i=1,nadd) - 300 format(1x,2i6,1pe15.8) - write(ioutpt,400) - 400 format(' row,right side') - write(ioutpt,500) (rowrs(i),addrs(i),i=1,naddrs) - 500 format(1x,i6,1pe15.8) - endif -c - return - end -c -c -------- quadb -c - subroutine quadb(nlist,x1,y1,x2,y2,t,iside) - include 'commons' - integer nlist(*),t - real x1,y1,x2,y2 - integer incl1(ndord6),incl2(ndord6),inclrs(ndord3) - integer i,j,qp,bctype - real qpx,qpy,slen - real cu,bcrhs -c -c compute boundary integrals -c -c x1,y1,x2,y2 are the vertices of the triangle on the boundary side -c t is the triangle -c nlist is the local numbering of the nodes on the boundary side -c - slen = sqrt((x2-x1)*(x2-x1) + (y2-y1)*(y2-y1)) -c -c determine which of the nadd matrix changes involve the boundary integral -c - do 30 j=1,nadd - incl1(j) = 0 - do 10 i=1,iorder - if (row(j).eq.nlist(i)) incl1(j) = i - 10 continue - incl2(j) = 0 - do 20 i=1,iorder - if (col(j).eq.nlist(i)) incl2(j) = i - 20 continue - 30 continue -c -c same for right side -c - do 50 j=1,naddrs - inclrs(j) = 0 - do 40 i=1,iorder - if (rowrs(j).eq.nlist(i)) inclrs(j) = i - 40 continue - 50 continue -c -c for each quadrature point -c - do 80 qp=1,nqptb -c -c set x,y coordinate of quadrature point -c - qpx = x1*qptb(qp) + x2*(1.-qptb(qp)) - qpy = y1*qptb(qp) + y2*(1.-qptb(qp)) -c -c evaluate boundary condition -c - call bcond(qpx,qpy,-neigh(iside,t),cu,bcrhs,bctype) -c -c contributions from this quadrature point -c - do 60 i=1,nadd - if (incl1(i).ne.0 .and. incl2(i).ne.0) then - add(i) = add(i) + qwtb(qp)* - 1 (cu*qpbasb(incl1(i),qp)*qpbasb(incl2(i),qp))*slen - endif - 60 continue -c - do 70 i=1,naddrs - if (inclrs(i).ne.0) then - addrs(i) = addrs(i) - 1 + qwtb(qp)*bcrhs*qpbasb(inclrs(i),qp)*slen - endif - 70 continue - 80 continue - return - end -c -c -------- solve -c - subroutine solve - include 'commons' - real oemaxv,oemaxn,oemaxq,oeenrg - external clock -c -c solve the system of equations coef * u = rs by ncyc multigrid V-cycles -c u is the coefficient vector for the nodal basis -c u is used as initial guess -c -c debug output -c - if (outlev.ge.2) write(ioutpt,100) - 100 format(/' begin solution ') -c -c start timing -c - timesl = clock(0) -c -c initial errors -c - if (outlev.ge.3) then - call errors(oemaxv,oemaxn,oemaxq,oeenrg) - write(ioutpt,101) oemaxv,oemaxn,oemaxq,oeenrg - endif - 101 format(/' errors in initial guess'/ - 1 ' max norm at vertices ',1pe15.8/ - 2 ' max norm at nodes ',1pe15.8/ - 3 ' max norm at quad pts ',1pe15.8/ - 4 ' continuous energy norm ',1pe15.8/) -c -c solve approximatly using ncyc cycles -c - do 902 loop=1,ncyc -c - if (outlev.ge.3) write(ioutpt,201) - 201 format(' begin multigrid cycle') -c -c v-cycle -c - if (nlev.ne.1) then - if (outlev.ge.3) write(ioutpt,301) - 301 format(' restrictions') - do 10 l=nlev,2,-1 - call relax(l,nu1) - call restrc(l) - 10 continue - endif -c - call exsolv -c - if (nlev.ne.1) then - if (outlev.ge.3) write(ioutpt,303) - 303 format(' prolongations') - do 20 l=2,nlev - call prolon(l) - call relax(l,nu2) - 20 continue - endif -c - if (outlev.ge.3) write(ioutpt,202) - 202 format(' multigrid cycle complete') - if (outlev.ge.3) call errred(loop,oemaxv,oemaxn, - 1 oemaxq,oeenrg) - 902 continue -c -c finish timing -c - timesl = clock(0) - timesl - timest = timest + timesl -c -c write data files for run time graphics, check the menu, and -c update the plots -c - if (outlev.ge.2 .and. grafic) write(ioutpt,200) - 200 format(' begin update to solution graphics') -c - if (grafic) then - call filtri - call filsol - if (menuon) call mn2mg - call grfsol - endif - if (outlev.ge.2 .and. grafic) write(ioutpt,300) - 300 format(' graphics complete') -c - call outsol -c - return - end -c -c -------- restrc -c - subroutine restrc(lev) - include 'commons' - integer lev,vert,limit,node1,i,nod,k -c -c compute residual on grid lev and restrict to grid lev-1 -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) lev,lev-1 - 100 format(' restrict from level',i4,' to level',i4) -c -c convert system from nodal basis to 2-level hierarchical -c - call stmats(lev,-1) - call svec(u,lev,-1) - call stvec(rs,lev,-1) -c -c compute part of residual due to level lev -c -c debug output -c - if (outlev .ge. 4) write(ioutpt,200) lev - 200 format(' compute residual due to level',i4) -c - vert=frstvt(lev) - 1 if (vert .eq. -1) go to 2 - node1=nwndvt(vert) - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 10 i=1,limit - nod=node1-1+i - k=1 - 11 if (idcoef(k,nod).eq.0 .or. idcoef(k,nod).ge.node1) - 1 go to 12 - rs(idcoef(k,nod)) = rs(idcoef(k,nod)) - 1 - coef(k,nod)*u(nod) - k=k+1 - go to 11 - 12 continue - 10 continue - vert = nextvt(vert) - go to 1 - 2 continue -c - return - end -c -c -------- prolon -c - subroutine prolon(lev) - include 'commons' - integer lev,vert,limit,node1,nod,k,i -c -c prolongate from grid lev-1 to grid lev -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) lev-1,lev - 100 format(' prolongate from level',i4,' to level',i4) - if (outlev.ge.4) write(ioutpt,101) lev - 101 format(' compute residual due to level ',i6) -c -c compute part of residual due to level lev -c and subtract it off -c - vert=frstvt(lev) - 1 if (vert .eq. -1) go to 2 - node1=nwndvt(vert) - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 10 i=1,limit - nod=node1-1+i - k=1 - 11 if (idcoef(k,nod).eq.0 .or. idcoef(k,nod).ge.node1) - 1 go to 12 - rs(idcoef(k,nod)) = rs(idcoef(k,nod)) - 1 + coef(k,nod)*u(nod) - k=k+1 - go to 11 - 12 continue - 10 continue - vert = nextvt(vert) - go to 1 - 2 continue -c -c -c convert system from 2-level hierarchical basis to nodal basis -c - call stmats(lev,1) - call svec(u,lev,1) - call stvec(rs,lev,1) -c - return - end -c -c -------- svec -c - subroutine svec(vec,lev,dir) - include 'commons' - real vec(*) - integer lev,vert,node1,nodei,i,j,oldnod,dir,limit -c -c convert vector vec from a 2-level coefficent vector to a -c nodal coefficient vector on level lev (dir=1) -c or nodal to 2-level (dir=-1) -c i.e. multiply vec by s (or s inverse) where s is the matrix that -c converts a 2-level basis to a nodal basis on level lev -c - if (lev.le.1) return -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) dir,lev - 100 format(' change basis of solution vector in direction',i3, - 1 ' on level',i4) -c - vert=frstvt(lev) - 1 if (vert.eq.-1) go to 2 - node1=nwndvt(vert)-1 - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 20 i=1,limit - nodei=node1+i - do 10 j=1,nbasch(i) - oldnod=olndvt(ibasch(j,i),vert) - vec(nodei)=vec(nodei)+dir*cbasch(j,i)*vec(oldnod) - 10 continue - 20 continue - vert = nextvt(vert) - go to 1 - 2 continue - 30 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) - call prvec(vec,1,lev) - 200 format(' converted vector') - endif -c - return - end -c -c -------- stvec -c - subroutine stvec(vec,lev,dir) - include 'commons' - real vec(*) - integer vert,lev,node1,nodei,i,j,oldnod,dir,limit -c -c change a right side vector, vec, for converting a nodal basis -c on level lev to a 2-level hierarchical basis (dir=-1) -c or 2-level to nodal (dir=1) -c i.e. multiply the vector vec by s transpose (or s inverse transpose) -c where s is the matrix that converts a 2-level basis -c to a nodal basis on level lev -c - if (lev.le.1) return -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) dir,lev - 100 format(' change basis of right side vector in direction',i3, - 1 ' on level ',i4) -c - vert=frstvt(lev) - 1 if (vert .eq. -1) go to 2 -c - node1=nwndvt(vert)-1 - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 20 i=1,limit - nodei=node1+i - do 10 j=1,nbasch(i) - oldnod=olndvt(ibasch(j,i),vert) - vec(oldnod)=vec(oldnod)-dir*cbasch(j,i)*vec(nodei) - 10 continue - 20 continue - vert = nextvt(vert) - go to 1 - 2 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) - call prvec(vec,1,lev) - 200 format(' converted vector') - endif -c - return - end -c -c -------- stmats -c - subroutine stmats(lev,dir) - include 'commons' - integer lev,dir,i,j,k,vert,limit,node1,nodei, - 1 oldnod,sub,nodek - real c -c -c change the matrix from nodal basis to 2-level hierarchical -c basis (dir=-1) on level lev, or 2-level to nodal (dir=1) -c i.e. compute s transpose * matrix * s where s is the matrix -c that converts a 2-level hierarchical basis to a nodal basis -c on level lev (or s inverse transpose * matrix * s inverse) -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) lev,dir - 100 format(' change basis of matrix on level',i4, - 1 ' in direction ',i2) -c - vert=frstvt(lev) -c - 1 if (vert.eq.-1) go to 2 -c - node1=nwndvt(vert)-1 - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - do 20 i=1,limit - nodei=node1+i - do 10 j=1,nbasch(i) - oldnod=olndvt(ibasch(j,i),vert) - c=-dir*cbasch(j,i) - sub=1 -c - 3 if (idcoef(sub,nodei).eq.oldnod) go to 4 - sub=sub+1 - if (sub.gt.mxidlo) then - write(ioutpt,101) oldnod,nodei - stop - endif - go to 3 - 4 continue -c - add(1)=2.*c*coef(sub,nodei) - 1 +c*c*coef(mxidlo+1,nodei) - row(1)=oldnod - col(1)=oldnod - nadd=1 -c - k=1 - 5 if (k.gt.mxidlo.or.idcoef(k,nodei).eq.0) go to 6 - nodek=idcoef(k,nodei) - nadd=nadd+1 - add(nadd)=c*coef(k,nodei) - if (nodek.gt.oldnod) then - row(nadd)=nodek - col(nadd)=oldnod - elseif (nodek.lt.oldnod) then - row(nadd)=oldnod - col(nadd)=nodek - else - nadd=nadd-1 - endif - k=k+1 - go to 5 - 6 continue -c - nadd=nadd+1 - add(nadd)=c*coef(mxidlo+1,nodei) - row(nadd)=nodei - col(nadd)=oldnod -c - k=mxidlo+1 - 7 if (k.gt.mxidup.or.idcoef(k,nodei).eq.0) go to 8 - nodek=idcoef(k,nodei) - if (nodek .le. node1+limit) then - sub=1 - 11 if (idcoef(sub,nodek).eq.nodei) go to 12 - sub=sub+1 - if (sub.gt.mxidlo) then - write(ioutpt,101) nodei,nodek - stop - endif - go to 11 - 12 continue - nadd=nadd+1 - add(nadd)=c*coef(sub,nodek) - row(nadd)=nodek - col(nadd)=oldnod - endif - k=k+1 - go to 7 - 8 continue -c - call addmat - 10 continue - 20 continue - call convid(vert,dir) -c - vert=nextvt(vert) - go to 1 - 2 continue -c - 101 format(/' ********FATAL ERROR********'// - 1 ' couldnt find column ',i10,' in row ',i10, - 2 ' in subroutine stmats ') -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) - call outmat - 200 format(' matrix after basis change') - endif -c - return - end -c -c -------- convid -c - subroutine convid(vert,dir) - include 'commons' - integer limit,i,j,count,vert,dir,inc -c -c convert upper triangular part of idcoef form 2-level to nodal -c (dir=1) or nodal to 2-level (dir=-1) at vertex vert -c - if (vrtlev(vert).gt.0) then - limit=3 - else - limit=1 - endif -c -c for each of the two macrotriangles (1 if boundary) -c - do 99 i=1,limit,2 -c -c make a list of the old vertices in the half with the oldest -c vertex which are not in both halves -c - count=0 - do 10 j=1,nnodtr - if (renum(i,j).gt.0) then - count=count+1 - if (i.eq.1 .or. renum(i,j).le.iorder) then - lolnd1(count)=olndvt(renum(i,j),vert) - else - lolnd1(count)=olndvt(renum(i,j)+nnodtr-iorder,vert) - endif - elseif (renum(i,j-1).gt.0) then - count=count-1 - endif - 10 continue - if (renum(i,nnodtr).gt.0) count=count-1 -c -c make a list of the old vertices in the other half which are -c not in both halves -c - count=0 - do 20 j=1,nnodtr - if (renum(i+1,j).gt.0) then - count=count+1 - lolnd2(count)=olndvt(renum(i+1,j),vert) - if (i.eq.1 .or. renum(i+1,j).le.iorder) then - lolnd2(count)=olndvt(renum(i+1,j),vert) - else - lolnd2(count)=olndvt(renum(i+1,j)+nnodtr-iorder,vert) - endif - elseif (renum(i+1,j-1).gt.0) then - count=count-1 - endif - 20 continue - if (renum(i+1,nnodtr).gt.0) count=count-1 -c -c make a list of the new nodes in the half with the oldest vertex -c - count=0 - do 30 j=1,nnodtr - if (renum(i,j).lt.0) then - count=count+1 - lnewnd(count)=nwndvt(vert)-1-renum(i,j) - endif - 30 continue -c -c for each node in old node list 1, replace old node list 2 by -c new node list in idcoef (or other way depending on direction) -c - do 40 j=1,count - if (dir.eq.1) then - call replac(lolnd2,lnewnd,count,lolnd1(j)) - else - call replac(lnewnd,lolnd2,count,lolnd1(j)) - endif - 40 continue -c -c make a list of the new nodes in the half without the oldest vertex -c - count=0 - do 50 j=1,nnodtr - if (renum(i+1,j).lt.0) then - count=count+1 - lnewnd(count)=nwndvt(vert)-1-renum(i+1,j) - endif - 50 continue -c -c for each node in old node list 2, replace old node list 1 by -c new node list in idcoef (or other way depending on direction) -c - do 60 j=1,count - if (dir.eq.1) then - call replac(lolnd1,lnewnd,count,lolnd2(j)) - else - call replac(lnewnd,lolnd1,count,lolnd2(j)) - endif - 60 continue -c -c make a list of new nodes in both halves of the triangle -c - count=0 - do 70 j=1,nnodtr - if (renum(i,j).lt.0) then - count=count+1 - lnewnd(count)=nwndvt(vert)-1-renum(i,j) - endif - 70 continue - do 80 j=1,nnodtr - if(renum(i+1,j).lt.0) then - count=count+1 - lnewnd(count)=nwndvt(vert)-1-renum(i+1,j) - elseif (j.ne.1) then - if (renum(i+1,j-1).lt.0) count=count-1 - endif - 80 continue - if (renum(i+1,nnodtr).lt.0) count=count-1 -c -c make a list of 0's of the same length -c - do 90 j=1,count - lolnd1(j)=0 - 90 continue -c -c for each node on boundary between the 2 halves, replace 0's -c by new nodes (or other way depending on direction) -c - j=iorder - inc=1 - 91 if (i.eq.1 .or. renum(i,j).le.iorder) then - nod=olndvt(renum(i,j),vert) - else - nod=olndvt(renum(i,j)+nnodtr-iorder,vert) - endif - if (dir.eq.1) then - call replac(lolnd1,lnewnd,count,nod) - else - call replac(lnewnd,lolnd1,count,nod) - endif - if (j.eq.nnodtr .or. j.eq.nnodtr-1) go to 92 - j=j+2*(iorder-inc)-1 - inc=inc+2 - go to 91 - 92 continue -c - 99 continue -c - return - end -c -c -------- replac -c - subroutine replac(nodout,nodin,nrepl,irow) - include 'commons' - integer nodout(*),nodin(*),irow,nrepl,i,no,ni, - 1 icol,col2 -c -c replace the nrepl nodes in nodout in the upper triangular -c part of idcoef in row row by the nodes in nodin -c 0's are kept at the end of a row of idcoef -c nodes less than row are replaced by 0 -c - if (outlev.ge.5) then - write(ioutpt,200) irow - write(ioutpt,300) (nodout(i),i=1,nrepl) - write(ioutpt,400) (nodin(i),i=1,nrepl) - 200 format(' replace upper idcoef for row ',i6) - 300 format(' remove ',14i6) - 400 format(' add ',14i6) - endif -c - do 99 i=1,nrepl - no=nodout(i) - if (no.le.irow) no=0 - ni=nodin(i) - if (ni.le.irow) ni=0 -c -c if nodout=0, make sure nodin is not already there -c - if (no.eq.0) then - do 9 icol=mxidlo+1,mxidup - if (idcoef(icol,irow).eq.ni) ni=0 - 9 continue - endif - if(no.eq.0 .and. ni.eq.0) go to 99 -c -c find nodout -c - icol=mxidlo+1 - 1 if (idcoef(icol,irow).eq.no) go to 2 - icol=icol+1 -c if nodout is not found, the replacement was already done - if (icol.gt.mxidup) go to 99 - go to 1 - 2 continue -c -c replace with nodin -c - if (ni.ne.0) then - idcoef(icol,irow)=ni - else -c -c put 0 nodin at end -c - col2=icol - 3 if (idcoef(col2,irow).eq.0) go to 4 - col2=col2+1 - if (col2.le.mxidup) go to 3 - 4 continue - idcoef(icol,irow)=idcoef(col2-1,irow) - idcoef(col2-1,irow)=0 - endif -c - 99 continue -c - return - end -c -c -------- initxs -c - subroutine initxs - include 'commons' - integer i,j,id - real xnode(ndrow0),ynode(ndrow0) -c -c initialization for exact solve on coarsest grid by linpack band -c - if (outlev.ge.3) write(ioutpt,104) - 104 format(' begin initializations for coarse grid exact solve') -c -c verify enough space is allocated for coarse grid matrix rows -c - if (nnode0 .gt. ndrow0) then - write(ioutpt,101) ndrow0,nnode0 - 101 format(/'FATAL ERROR -- not enough room for coarsest grid', - 1 ' factors for exact solve'/ - 2 'Current allocation is ndrow0 = ',i6/ - 3 'Requires ndrow0 >= ',i6/ - 4 'Change parameter statement in commons') - stop - endif -c - if (outlev.ge.4) write(ioutpt,105) - 105 format(' determine reordering of coarse grid nodes') -c -c determine reordering of coarse grid nodes to reduce bandwidth -c -c initially the order is the order in the grid; also set flag in xnode -c - do 10 i=1,nnode0 - ipvt1(i)=i - xnode(i)=-999. - 10 continue -c -c compute node coordinates -c - delta = 1./float(iorder-1) - do 40 itri=1,ntri - x1 = xvert(vertex(1,itri)) - x2 = xvert(vertex(2,itri)) - x3 = xvert(vertex(3,itri)) - y1 = yvert(vertex(1,itri)) - y2 = yvert(vertex(2,itri)) - y3 = yvert(vertex(3,itri)) - lnod=0 - f3=-delta - do 30 i=1,iorder - f3 = f3+delta - f2 = -delta - f1 = 1.-f3+delta - do 20 j=i,iorder - lnod = lnod+1 - nod = node(lnod,itri) - f1 = f1-delta - f2 = f2+delta - if (xnode(nod).eq.-999.) then - xnode(nod) = f1*x1 + f2*x2 + f3*x3 - ynode(nod) = f1*y1 + f2*y2 + f3*y3 - endif - 20 continue - 30 continue - 40 continue -c -c sort to go first vertically then horizontally. use ipvt1 (not needed -c until factoring is done) to hold the inverse of the ordering vector -c simple bubble sort, @future use a better sort -c - eps = 4.*r1mach(4) - 1 continue - change = 0 - do 50 i=1,nnode0-1 - if (abs(xnode(ipvt1(i))-xnode(ipvt1(i+1))).lt.eps) then - if (ynode(ipvt1(i)).gt.ynode(ipvt1(i+1))) then - itemp = ipvt1(i) - ipvt1(i)=ipvt1(i+1) - ipvt1(i+1) = itemp - change=1 - endif - elseif (xnode(ipvt1(i)).gt.xnode(ipvt1(i+1))) then - itemp = ipvt1(i) - ipvt1(i)=ipvt1(i+1) - ipvt1(i+1) = itemp - change=1 - endif - 50 continue - if (change.eq.1) go to 1 -c -c set the ordering vector l1ord from its inverse in ipvt1 -c - do 60 i=1,nnode0 - l1ord(ipvt1(i))=i - 60 continue -c - if (outlev.ge.4) write(ioutpt,106) - 106 format(' determine bandwidth') -c -c determine bandwidth -c - do 70 i=1,nnode0 - do 70 j=1,mxidlo - id = idcoef(j,i) - if (id.ne.0) then - l1id=l1ord(id) - l1i =l1ord(i) - if (iabs(l1id-l1i) .gt. nband) nband=iabs(l1id-l1i) - endif - 70 continue -c -c verify enough space is allocated for coarse grid matrix bandwidth -c - if (nband .gt. ndband) then - write(ioutpt,100) ndband,nband - 100 format(/'FATAL ERROR -- not enough room for coarsest grid', - 1 ' factors for exact solve'/ - 2 'Current allocation is ndband = ',i6/ - 3 'Requires ndband >= ',i6/ - 4 'Change parameter statement in commons') - stop - endif -c - if (outlev.ge.3) write(ioutpt,108) - 108 format(' exact solve initializations complete') - return - end -c -c -------- exsolv -c - subroutine exsolv - include 'commons' -c -c solve exactly on the coarsest grid -c -c debug output -c - if (outlev.ge.3) write(ioutpt,100) - 100 format(' solve exactly on coarsest grid') -c -c exact solve on coarse grid by linpack band routine -c - if (outlev.ge.4) write(ioutpt,107) - 107 format(' copy coef to band form') -c -c initialize coef to 0. -c - do 80 j=1,nnode0 - do 80 i=1,3*nband+1 - coefl1(i,j)=0. - 80 continue -c -c copy coef to band form -c - do 95 i=1,nnode0 - l1i = l1ord(i) - if (bndnod(i)) then - coefl1(2*nband+1,l1i)=1. - else - coefl1(2*nband+1,l1i)=coef(mxidlo+1,i) - endif - do 90 j=1,mxidlo - id = idcoef(j,i) - if (id .ne. 0.) then - l1id = l1ord(id) - if (.not.bndnod(i)) - 1 coefl1(2*nband+1+l1i-l1id,l1id)=coef(j,i) - if (.not.bndnod(id)) - 1 coefl1(2*nband+1+l1id-l1i,l1i) =coef(j,i) - endif - 90 continue - 95 continue -c -c debug output matrix in band form -c - if (outlev.ge.5) then - write(ioutpt,184) - do 181 j=1,nnode0 - do 180 i=1,3*nband+1 - write(ioutpt,182) i,j,coefl1(i,j) - 180 continue - write(ioutpt,183) - 181 continue - 182 format(2i6,1pe15.8) - 183 format(' ') - 184 format(' matrix in band form:') - endif -c -c call linpack factorization -c - if (outlev.ge.4) write(ioutpt,102) - 102 format(' begin factoring coarse grid equations') -c - call sgbco(coefl1,3*ndband+1,nnode0,nband,nband,ipvt1,rcond,rs1) - if (rcond .lt. 10.*r1mach(4)) then - write(ioutpt,185) - endif - 185 format(/' WARNING -- The condition number of the coarse grid'/, - . ' matrix is very large.'/, - . ' The solution may be unreliable.'//) -c -c copy right side -c - do 10 i=1,nnode0 - if (bndnod(i)) then - rs1(l1ord(i)) = u(i) - else - rs1(l1ord(i)) = rs(i) - endif - 10 continue -c -c call linpack sgbsl -c - call sgbsl(coefl1,3*ndband+1,nnode0,nband,nband,ipvt1,rs1,0) -c -c copy solution -c - do 20 i=1,nnode0 - if (.not.bndnod(i)) u(i) = rs1(l1ord(i)) - 20 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,200) - 200 format(' coarse grid solution is:') - call prvec(u,1,1) - endif -c - return - end -c -c -------- relax -c - subroutine relax(lev,nu) - include 'commons' - integer limit,lev,nu,vert,olnd,i,j,lim,blkhed -c -c regular form of relaxation -c -c perform nu half steps of red-black gauss siedel on level lev -c -c debug output -c - if (outlev.ge.4) write(ioutpt,901) nu,lev - 901 format(' relax ',i2,'/2 times on level ',i4) -c -c repeat nu/2 times -c - limit = int(nu/2) - if (limit.eq.0) go to 399 -c - do 320 i=1,limit -c - blkhed=-1 -c -c relax on highest level (red vertices) -c - vert = frstvt(lev) -c - 1 if (vert.eq.-1) go to 2 -c -c relax at the nodes associated with this vertex -c - call rlxred(vert) -c -c make note of which black nodes are neighbors -c - if (vrtlev(vert).gt.0) then - lim=iorder*iorder - else - lim=(iorder*(iorder+1))/2 - endif - do 20 j=1,lim - olnd = olndvt(j,vert) - if ((.not. inuse(olnd))) then - inuse(olnd) = .true. - nxtblk(olnd) = blkhed - blkhed=olnd - endif - 20 continue -c - vert = nextvt(vert) - go to 1 - 2 continue -c -c relax on other levels (black nodes) -c - olnd = blkhed - 101 if (olnd.eq.-1) go to 102 -c - call rlxblk(olnd) - inuse(olnd) = .false. - olnd = nxtblk(olnd) - go to 101 - 102 continue -c - 320 continue -c -c if nu is odd, relax red vertices one more time -c - 399 continue - if (2*limit .ne. nu) then - vert = frstvt(lev) - 401 if (vert.eq.-1) go to 402 -c -c relax at the nodes associated with this vertex -c - call rlxred(vert) -c - vert = nextvt(vert) - go to 401 - 402 continue - endif -c - return - end -c -c -------- rlxred -c - subroutine rlxred(vert) - include 'commons' - integer nod,i,limit,node1,k,vert - integer kpvt(ndord1),info - real sum -c -c relax at the red nodes associated with vert -c -c special case for iorder=2 -c - if (iorder.eq.2) then - if (.not.bndnod(vert)) then - sum=rs(vert) - do 5 i=1,4 - if (idcoef(i,vert).ne.0) then - sum=sum-coef(i,vert)*u(idcoef(i,vert)) - endif - 5 continue - u(vert)=sum/coef(5,vert) -c - endif - return - endif -c -c normal case for iorder>2 -c -c determine size of system -c - if (vrtlev(vert).gt.0) then - limit=nnodev - else - limit=nnodvb - endif - node1=nwndvt(vert) -c -c set up diagonal block associated with this vertex -c - do 110 i=1,limit - do 110 j=1,limit - block(i,j)=0. - 110 continue - do 130 i=1,limit - nod=node1+i-1 - do 120 j=1,mxidlo - if (idcoef(j,nod).ge.node1) then - block(i,idcoef(j,nod)-node1+1)=coef(j,nod) - block(idcoef(j,nod)-node1+1,i)=coef(j,nod) - endif - 120 continue - block(i,i)=coef(mxidlo+1,nod) - 130 continue -c -c set up right side for the system -c - do 20 k=1,limit -c - nod=node1-1+k -c - if (bndnod(nod)) go to 20 - u(nod)=rs(nod) -c -c contributions from lower triangular part -c - i=1 - 10 if (idcoef(i,nod).eq.0.or.idcoef(i,nod).ge.node1) go to 11 - u(nod)=u(nod)-coef(i,nod)*u(idcoef(i,nod)) - i=i+1 - go to 10 - 11 continue -c - 20 continue -c -c modify boundary rows -c - if (limit.eq.nnodvb) then - do 160 i=1,nnodvb - nod=i+node1-1 - if (bndnod(nod)) then - do 140 j=1,nnodvb - block(i,j)=0. - nod2=j+node1-1 - if (.not. bndnod(nod2)) then - u(nod2)=u(nod2)-block(j,i)*u(nod) - endif - block(j,i)=0. - 140 continue - block(i,i)=1. - endif - 160 continue - endif -c -c solve system -c - call ssifa(block,ndord1,limit,kpvt,info) - if (info .ne. 0) then - write(ioutpt,900) info - 900 format('ERROR -- linpack routine ssifa returned info = ',i8) - stop - endif - call ssisl(block,ndord1,limit,kpvt,u(node1)) -c - return - end -c -c -------- rlxblk -c - subroutine rlxblk(nod) - include 'commons' - integer nod,i,irow,icol - real sum -c -c relax at a black node -c - if (bndnod(nod)) return - sum=rs(nod) -c -c contributions from lower triangular part -c - do 10 i=1,mxidlo - if (idcoef(i,nod).ne.0) then - sum=sum-coef(i,nod)*u(idcoef(i,nod)) - endif - 10 continue -c -c contributions from upper triangular part -c - do 20 i=mxidlo+1,mxidup - if (idcoef(i,nod).ne.0) then -c -c find coef in lower triangular part -c - irow=idcoef(i,nod) - icol=1 - 1 if(idcoef(icol,irow).eq.nod) go to 2 - icol=icol+1 - if (icol.gt.mxidlo) then - write(ioutpt,100) nod,irow - stop - 100 format(/'********FATAL ERROR********'// - 1 ' couldnt find column ',i10,' in row ',i10, - 2 ' in rlxblk') - endif - go to 1 - 2 continue - sum=sum-coef(icol,irow)*u(irow) - endif - 20 continue -c - u(nod)=sum/coef(mxidlo+1,nod) -c - return - end -c -c -------- locrlx -c - subroutine locrlx(t) - include 'commons' - integer i,j,n,tri,vrt,limit,nod,t,trlist(24),neftri - logical onlist -c -c local relaxations after adding a new vertex -c the relaxation at the new nodes has already been done -c relaxes at the old nodes in the new triangles -c -c debug output -c - if (outlev.ge.4) write(ioutpt,100) - 100 format(' local relaxations') -c -c limit=number of old nodes -c - if (vrtlev(nvert).lt.0) then - limit=(iorder*(iorder+1))/2 - else - limit=iorder*iorder - endif -c -c relax at old nodes -c - do 10 n=1,limit - nod=olndvt(n,nvert) - call rlxblk(nod) - 10 continue -c -c correct error indicators at triangles by old nodes -c - if (vrtlev(nvert).lt.0) then - limit=3 - else - limit=4 - endif -c -c make a list of effected triangles -c - neftri=0 - do 30 i=1,limit -c -c find vertex -c - if (i.eq.1) then - vrt=vertex(1,t) - elseif (i.eq.2) then - vrt=vertex(2,t) - elseif (i.eq.3) then - vrt=vertex(1,ntri) - else - vrt=vertex(2,ntri) - endif -c -c add neighboring triangles to list if not already there -c - do 20 j=1,8 - tri=tringl(j,vrt) - if (tri.eq.0) go to 20 - onlist=.false. - if (neftri.ne.0) then - do 15 k=1,neftri - if (trlist(k).eq.tri) onlist=.true. - 15 continue - endif - if (.not. onlist) then - neftri=neftri+1 - trlist(neftri)=tri - endif - 20 continue - 30 continue -c -c debug output -c - if (outlev.ge.5) write(ioutpt,200) (trlist(k),k=1,neftri) - 200 format(' triangles whose error indicator is effected ', - 1 'by local relaxation '/12i6/12i6) -c -c correct error indicator for each neighboring triangle -c - do 40 j=1,neftri - tri=trlist(j) - call eitri(tri) - if(coefei(iorder*iorder+1,1,tri).eq.0.) - 1 tri=neigh(3,tri) - call elstrm(tri) - call elstad(tri) - 40 continue - return - end -c -c -------- esterr -c - subroutine esterr - include 'commons' - integer t,i - external clock -c -c compute error indicator for each triangle using -c 1 point local dirichlet, and compute global error estimate -c -c debug output -c - if (outlev.ge.2) write(ioutpt,101) - 101 format(/' begin error indicators') - if (outlev.ge.4) write(ioutpt,102) - 102 format(/' error indicators are:') -c -c begin timing -c - timeel = clock(0) -c -c compute error indicators -c - eimax = 0. - do 10 t=1,ntri - if (coefei(iorder*iorder+1,1,t).ne.0.) then - call eitri(t) - if (errind(t).gt.eimax) eimax=errind(t) - endif -c -c debug output -c - if (outlev.ge.4) write(ioutpt,103) t,errind(t) - 103 format(1x,i6,2x,1pe15.8) -c - 10 continue -c -c compute global error estimate -c - gerest = 0. - do 18 t=1,ntri - if (coefei(iorder*iorder+1,1,t).ne.0.) then - if (neigh(3,t).le.0) then - gerest=gerest+errind(t)*errind(t) - elseif(neigh(3,neigh(3,t)).eq.t) then - gerest=gerest+errind(t)*errind(t) - else - gerest=gerest+errind(t)*errind(t)/2. - endif - endif - 18 continue -c -c global error estimates -c - gerest = sqrt(abs((2**(iorder-1))*gerest/(2.**(iorder-1)-1.))) - if (abs(unrm) .gt. 1.e-10) then - rerest = gerest/unrm - else - rerest = gerest - endif -c -c create lists of error indicators in various ranges -c -c empty lists -c - do 20 i=1,4 - eihead(i) = -1 - eitail(i) = -1 - 20 continue -c -c add triangles with error indicators to lists -c - do 30 t=1,ntri - if (coefei(iorder*iorder+1,1,t).eq.0.) then - nxttri(t) = -1 - pretri(t) = -1 - else - call elstad(t) - endif - 30 continue -c -c finish timing -c - timeel = clock(0) - timeel - timeet = timeet + timeel -c -c save error estimate for gnuplot convergence file -c - gpeest(gplev)=rerest - gptime(gplev)=clock(0)-timett - gplev=gplev+1 -c -c debug output -c - if (outlev.ge.4) then - write(ioutpt,111) - do 110 i=1,4 - write(ioutpt,112) i - t = eihead(i) - 121 if (t.eq.-1) go to 122 - write(ioutpt,113) t - t = nxttri(t) - go to 121 - 122 continue - 110 continue - endif - 111 format(/' error indicator lists are') - 112 format(' list ',i2) - 113 format(i6) -c - if (outlev.ge.2) then - write(ioutpt,104) - write(ioutpt,105) eimax,gerest - if (abs(gerr) .gt. 1.e-10) then - effind = gerest/gerr - else - effind = 1. - endif - if (abs(rgerr) .gt. 1.e-10) then - refind = rerest/rgerr - else - refind = 1. - endif - write(ioutpt,106) effind - write(ioutpt,116) rerest,refind - write(ioutpt,107) timeel,timeet - endif - if (outlev.ge.4) then - call plttri(0,3) - endif - 104 format(/' error indicators and estimates complete') - 105 format(/' maximum error indicator ',1pe15.8/ - 1 ' error estimate ',1pe15.8) - 106 format( ' effectivity index ',1pe15.8) - 116 format( ' relative error estimate ',1pe15.8/ - 1 ' relative effect index ',1pe15.8) - 107 format(/' time for error estimates (this grid) ',f10.2/ - 1 ' time for error estimates (all grids) ',f10.2) -c -c write data files for run time graphics, check the menu, and -c update the plots -c - if (outlev.ge.2 .and. grafic) write(ioutpt,200) - 200 format(' begin update to convergence graphics') - if (grafic) then - call filcon - if (menuon) call mn2mg - call grfcon - endif - if (outlev.ge.2 .and. grafic) write(ioutpt,300) - 300 format(' graphics complete') -c - return - end -c -c -------- eitri -c - subroutine eitri(t) - include 'commons' - integer t,t1,nbr,ord2,nbrtyp,i,nod,j,limit,id,sumord,bctype - integer kpvt(ndord1) - real sum,bcrhs,cu - logical bondry,cmpdiv,dirich -c -c compute error indicator for triangle t -c -c avoid null triangle - if (t.eq.0) return -c -c determine whether t or its mate has the problem -c - ord2 = iorder*iorder - if (coefei(ord2+1,1,t).eq.0.) then - t1=neigh(3,t) - else - t1=t - endif -c -c set neighbor and case flags -c - nbr=neigh(3,t1) - if (nbr.le.0) then - bondry=.true. -c@@@ call is just to get bctype - call bcond(xvert(vertex(1,t1)),yvert(vertex(1,t1)), - 1 -nbr,cu,bcrhs,bctype) - if (bctype.eq.1) then - dirich = .true. - else - dirich = .false. - endif - cmpdiv=.true. - nbrtyp=0 - else - dirich = .false. - bondry=.false. - if (neigh(3,nbr).eq.t1) then - cmpdiv=.true. - nbrtyp=0 - else - cmpdiv=.false. - if (vertex(1,nbr).eq.vertex(1,t1)) then - nbrtyp=1 - else - nbrtyp=2 - endif - endif - endif -c -c special case for iorder=2 -c - if (iorder.eq.2) then -c -c boundary triangle - if (dirich) then - uei(1)=bcei(1,t1)-(u(vertex(1,t1))+u(vertex(2,t1)))/2. -c interior triangle - else -c contribution from nodes in t1 - uei(1)=rsei(1,t1)-coefei(1,1,t1)*u(vertex(1,t1)) - 1 -coefei(2,1,t1)*u(vertex(2,t1)) - 2 -coefei(3,1,t1)*u(vertex(3,t1)) -c contribution from node in nbr depends on compatability -c (and aren't there if the edge is boundary) - if (.not.bondry) then - if (cmpdiv) then - uei(1)=uei(1)-coefei(4,1,t1)*u(vertex(3,nbr)) - else - uei(1)=uei(1)-coefei(4,1,t1)*(u(vertex(1,nbr))+ - 1 u(vertex(2,nbr)))/2. - endif - endif -c solve system - uei(1)=uei(1)/coefei(5,1,t1) -c convert to coefficent of 2-level basis - uei(1)=uei(1)-(u(vertex(1,t1))+u(vertex(2,t1)))/2. - endif -c -c compute energy norm -c - errind(t1)=sqrt(abs(uei(1)*uei(1)*coefei(5,1,t1))) -c - else -c -c higher order methods -c -c set solution values for the neighbor if not compatably divisible -c - if (.not. cmpdiv) then - do 20 i=1,(iorder*(iorder-1))/2 -c -c find local numbering of node -c - nod=renum(nbrtyp,i+iorder) - if (nod.gt.0) then -c node is an existing node in the neighbor - ueiold(i)=u(node(nod,nbr)) - else -c node will be added when the neighbor is divided -c evaluate solution there - nod=-nod - ueiold(i)=0. - do 10 j=1,nbasch(nod) - ueiold(i)=ueiold(i)+cbasch(j,nod) - 1 *u(node(ibasch(j,nod),nbr)) - 10 continue - endif - 20 continue - endif -c -c set up right side for system -c - if (bondry) then - limit=nnodvb - else - limit=nnodev - endif - do 40 i=1,limit - uei(i)=rsei(i,t1)+rsei2(i,t1) -c -c no changes for nodes on the boundary -c - if (.not. bondry .or. nbasch(i).ne.iorder - 1 .or. .not. dirich) then -c -c contributions from existing nodes -c - j=1 - 21 if (j.gt.ord2) go to 22 - if (idcoei(j,i,t1).eq.0) go to 22 - id=idcoei(j,i,t1) - if (id.lt.0) then -c node is in non compatable neighbor - uei(i)=uei(i)-coefei(j,i,t1)*ueiold(-id) - else -c node exists - uei(i)=uei(i)-coefei(j,i,t1)*u(id) - endif - j=j+1 - go to 21 - 22 continue - else -c -c set Dirichlet boundary condition -c - uei(i)=bcei(i,t1) - endif - 40 continue -c -c copy blokei to block -c - do 51 i=1,limit - do 51 j=1,limit - block(i,j)=blokei(i,j,t1) - 51 continue -c -c solve system -c - call ssifa(block,ndord1,limit,kpvt,info) - if (info .ne. 0) then - write(ioutpt,900) info - 900 format('ERROR -- linpack routine ssifa returned info = ',i8) - stop - endif - call ssisl(block,ndord1,limit,kpvt,uei) -c -c convert solution to 2-level basis coefficents -c - sumord=(iorder*(iorder+1))/2 - do 120 i=1,limit - do 110 j=1,nbasch(i) - if (ibasch(j,i).le.sumord) then - uei(i)=uei(i)-cbasch(j,i)*u(node(ibasch(j,i),t1)) - elseif (cmpdiv) then - uei(i)=uei(i)-cbasch(j,i) - 1 *u(node(ibasch(j,i)-sumord+iorder,nbr)) - else - uei(i)=uei(i)-cbasch(j,i)*ueiold(ibasch(j,i)-sumord) - endif - 110 continue - 120 continue -c -c compute energy norm -c - errind(t1)=0. - sum=0. - do 140 i=1,limit - do 130 j=1,limit - sum=sum+blokei(i,j,t1)*uei(i)*uei(j) - 130 continue - 140 continue - errind(t1)=sqrt(abs(sum)) -c - endif -c - return - end -c -c -------- elstad -c - subroutine elstad(t) - include 'commons' - integer t,list - real e,cut1,cut2,cut3 - logical top -c - if (unifrm) return -c -c add triangle t to the correct error indicator list -c - e = errind(t) -c -c if e>eimax, shift lists to create a new list of largest error -c indicators. Don't worry about needing to shift more than once -c @future examine the effect of only checking for shift once -c - if ( e.gt.eimax ) then -c combine last two lists - if (eihead(3).ne.-1) then - if (eihead(4).eq.-1) then - eihead(4)=eihead(3) - eitail(4)=eitail(3) - else - nxttri(eitail(3)) = eihead(4) - pretri(eihead(4)) = eitail(3) - eihead(4) = eihead(3) - endif - endif -c shift other lists - eihead(3) = eihead(2) - eitail(3) = eitail(2) - eihead(2) = eihead(1) - eitail(2) = eitail(1) - eihead(1) = -1 - eitail(1) = -1 -c increase eimax - eimax = eimax*mgfreq**(iorder/2.) - if (outlev.ge.4) write(ioutpt,100) - 100 format(' shift error indicator lists for larger eimax') - endif -c -c determine which list this triangle goes in and whether -c it goes in the top or the bottom -c - cut1 = eimax*mgfreq**(-iorder/2.) - cut2 = eimax*mgfreq**(-float(iorder)) - cut3 = eimax*mgfreq**(-3.*iorder/2.) - if (e.ge.cut1) then - list = 1 - top = (e.gt. (eimax+cut1)/2.) - elseif (e.ge.cut2) then - list=2 - top = (e.gt. (cut1+cut2)/2.) - elseif (e.ge.cut3) then - list=3 - top = (e.gt. (cut2+cut3)/2.) - else - list=4 - top = (e.gt. cut3/2.) - endif -c -c add triangle to list -c - if (top) then -c - nxttri(t) = eihead(list) - pretri(t) = -1 - if (eihead(list) .eq. -1) then - eitail(list) = t - else - pretri(eihead(list)) = t - endif - eihead(list) = t -c - else -c - pretri(t) = eitail(list) - nxttri(t) = -1 - if (eitail(list) .eq. -1) then - eihead(list) = t - else - nxttri(eitail(list)) = t - endif - eitail(list) = t -c - endif -c -c debug output -c - if (outlev .ge. 5) then - if (top) then - write(ioutpt,201) t,list - else - write(ioutpt,202) t,list - endif - endif - 201 format(' add triangle ',i6,' to top of error indicator', - 1 ' list ',i2) - 202 format(' add triangle ',i6,' to bottom of error indicator', - 1 ' list ',i2) -c - return - end -c -c -------- elstrm -c - subroutine elstrm(t) - include 'commons' - integer t,list -c - if (unifrm) return -c -c remove triangle t from the error indicator lists -c -c if t is at the head of a list, find out which list -c - if (pretri(t).eq.-1) then - if (eihead(1).eq.t) then - list=1 - elseif (eihead(2).eq.t) then - list=2 - elseif (eihead(3).eq.t) then - list=3 - elseif (eihead(4).eq.t) then - list=4 - else - write(ioutpt,100) t - stop - 100 format(' ********FATAL ERROR********'// - 1 ' couldnt find which list ',i6,' is the head of') - endif -c -c change pointer before t -c - eihead(list) = nxttri(t) - else - nxttri(pretri(t)) = nxttri(t) - endif -c -c if t is at the end of a list, find out which list -c - if (nxttri(t) .eq. -1) then - if (eitail(1) .eq. t) then - list = 1 - elseif (eitail(2) .eq. t) then - list = 2 - elseif (eitail(3) .eq. t) then - list = 3 - elseif (eitail(4) .eq. t) then - list = 4 - else - write(ioutpt,200) t - stop - 200 format(' ********FATAL ERROR********'// - 1 ' couldnt find which list ',i6,' is the tail of') - endif -c -c change back pointer after t -c - eitail(list) = pretri(t) - else - pretri(nxttri(t)) = pretri(t) - endif -c -c debug output -c - if (outlev.ge.5) write(ioutpt,300) t - 300 format(' remove triangle ',i6,' from error indicator lists') -c - return - end -c -c -------- errors -c - subroutine errors(emaxv,emaxn,emaxq,eenrg) - include 'commons' - integer t,denom,i1,i2,i3,i,nod,j - real emaxv,emaxn,emaxq,eenrg,x1,x2,x3,y1,y2,y3,area, - 1 det,dz1dx,dz2dx,dz3dx,dz1dy,dz2dy,dz3dy,x,y - real uval, uxval, uyval, err, errx, erry - real qpf,qpp,qpq,qpr -c -c compute norms of error -c 4 norms : max norm at vertices, nodes, and quadrature points -c and continuous energy norm computed with the same -c quadrature rule as used for computing inner products -c - emaxv=0. - emaxn=0. - emaxq=0. - eenrg=0. -c -c computations one triangle at a time -c - do 40 t=1,ntri -c -c x-y coordinates of vertices of this triangle -c - x1=xvert(vertex(1,t)) - x2=xvert(vertex(2,t)) - x3=xvert(vertex(3,t)) - y1=yvert(vertex(1,t)) - y2=yvert(vertex(2,t)) - y3=yvert(vertex(3,t)) -c -c area of triangle and derivatives of zeta functions wrt x and y -c - det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) - area = abs(det/2.) - dz1dx = (y2-y3)/det - dz2dx = (y3-y1)/det - dz3dx = (y1-y2)/det - dz1dy = (x3-x2)/det - dz2dy = (x1-x3)/det - dz3dy = (x2-x1)/det -c -c weights for computing x-y coordinates of nodes -c - denom = iorder-1 - i1 = denom+1 - i2 = -1 - i3 = 0 -c -c pass through nodes for max err at nodes and vertices -c - do 10 i=1,nnodtr - nod = node(i,t) -c -c x-y coordinates of node -c - i1=i1-1 - i2=i2+1 - if (i1.lt.0) then - i3=i3+1 - i1=denom-i3 - i2=0 - endif - x=(i1*x1 + i2*x2 + i3*x3)/float(denom) - y=(i1*y1 + i2*y2 + i3*y3)/float(denom) -c -c error at this node -c - err = u(nod)-true(x,y) -c -c check for max -c - if (abs(err).gt.emaxn) emaxn=abs(err) - if ((i.eq.1 .or. i.eq.iorder .or. i.eq.nnodtr) - 1 .and. abs(err).gt.emaxv) emaxv=abs(err) -c - 10 continue -c -c pass through quadrature points for max err at quad pts and -c to compute integral for energy norm -c - do 30 i=1,nqpt -c -c x-y coordinates of quadrature points -c - x=x1*quadpt(1,i)+x2*quadpt(2,i)+x3*quadpt(3,i) - y=y1*quadpt(1,i)+y2*quadpt(2,i)+y3*quadpt(3,i) -c -c pde coefficents at quadrature point -c - call pde(x,y,qpp,qpq,qpr,qpf) -c -c value of approximate solution and derivatives at quadrature point -c - uval = 0. - uxval= 0. - uyval= 0. - do 20 j=1,nnodtr - uval = uval+qpbas(j,i)*u(node(j,t)) - uxval= uxval+(qpdbdz(1,j,i)*dz1dx - 1 + qpdbdz(2,j,i)*dz2dx - 2 + qpdbdz(3,j,i)*dz3dx)*u(node(j,t)) - uyval= uyval+(qpdbdz(1,j,i)*dz1dy - 1 + qpdbdz(2,j,i)*dz2dy - 2 + qpdbdz(3,j,i)*dz3dy)*u(node(j,t)) - 20 continue -c -c error and derivatives of error at quadrature point -c - err = uval - true(x,y) - errx = uxval - truex(x,y) - erry = uyval - truey(x,y) -c -c check for max error -c - if (abs(err).gt.emaxq) emaxq=abs(err) -c -c contribution to integral -c - eenrg = eenrg + area*quadw(i)* - 1 abs(qpp*errx*errx + qpq*erry*erry - 2 + qpr*err*err) -c - 30 continue - 40 continue -c - eenrg = sqrt(eenrg) -c - return - end -c -c -------- errred -c - subroutine errred(loop,oemaxv,oemaxn,oemaxq,oeenrg) - include 'commons' - integer loop - real emaxv,oemaxv,remaxv,emaxn,oemaxn,remaxn, - 1 emaxq,oemaxq,remaxq,eenrg,oeenrg,reenrg -c -c compute the amount of reduction in error -c this is usually called after a multigrid cycle -c - call errors(emaxv,emaxn,emaxq,eenrg) -c - if (oemaxv.ne.0.) then - remaxv = emaxv/oemaxv - else - remaxv = 1. - endif - if (oemaxn.ne.0.) then - remaxn = emaxn/oemaxn - else - remaxn = 1. - endif - if (oemaxq.ne.0.) then - remaxq = emaxq/oemaxq - else - remaxq = 1. - endif - if (oeenrg.ne.0.) then - reenrg = eenrg/oeenrg - else - reenrg = 1. - endif -c - oemaxv=emaxv - oemaxn=emaxn - oemaxq=emaxq - oeenrg=eenrg -c - write(ioutpt,100) loop,emaxv,remaxv,emaxn,remaxn,emaxq, - 1 remaxq,eenrg,reenrg - 100 format(/' after cycle number ',i3/ - 1 ' max norm at vertices ',1pe15.8,' reduced ',1pe15.8/ - 2 ' max norm at nodes ',1pe15.8,' reduced ',1pe15.8/ - 3 ' max norm at quad pts ',1pe15.8,' reduced ',1pe15.8/ - 4 ' continuous energy norm ',1pe15.8,' reduced ',1pe15.8/) -c - return - end -c -c -------- unorm -c - subroutine unorm(unm,trunm) - include 'commons' - integer t,i,j - real unm,trunm,x1,x2,x3,y1,y2,y3,area, - 1 det,dz1dx,dz2dx,dz3dx,dz1dy,dz2dy,dz3dy,x,y - real qpf,qpp,qpq,qpr - real uval, uxval, uyval, tru, trux, truy -c -c compute norms of the approximate solution and the true solution -c - unm = 0. - trunm = 0. -c -c computations one triangle at a time -c - do 40 t=1,ntri -c -c x-y coordinates of vertices of this triangle -c - x1=xvert(vertex(1,t)) - x2=xvert(vertex(2,t)) - x3=xvert(vertex(3,t)) - y1=yvert(vertex(1,t)) - y2=yvert(vertex(2,t)) - y3=yvert(vertex(3,t)) -c -c area of triangle and derivatives of zeta functions wrt x and y -c - det = x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2) - area = abs(det/2.) - dz1dx = (y2-y3)/det - dz2dx = (y3-y1)/det - dz3dx = (y1-y2)/det - dz1dy = (x3-x2)/det - dz2dy = (x1-x3)/det - dz3dy = (x2-x1)/det -c -c pass through quadrature points to compute integral for energy norm -c - do 30 i=1,nqpt -c -c x-y coordinates of quadrature points -c - x=x1*quadpt(1,i)+x2*quadpt(2,i)+x3*quadpt(3,i) - y=y1*quadpt(1,i)+y2*quadpt(2,i)+y3*quadpt(3,i) -c -c pde coefficents at quadrature point -c - call pde(x,y,qpp,qpq,qpr,qpf) -c -c value of approximate solution and derivatives at quadrature point -c - uval = 0. - uxval= 0. - uyval= 0. - do 20 j=1,nnodtr - uval = uval+qpbas(j,i)*u(node(j,t)) - uxval= uxval+(qpdbdz(1,j,i)*dz1dx - 1 + qpdbdz(2,j,i)*dz2dx - 2 + qpdbdz(3,j,i)*dz3dx)*u(node(j,t)) - uyval= uyval+(qpdbdz(1,j,i)*dz1dy - 1 + qpdbdz(2,j,i)*dz2dy - 2 + qpdbdz(3,j,i)*dz3dy)*u(node(j,t)) - 20 continue -c -c true solution at quadrature point -c - tru = true(x,y) - trux = truex(x,y) - truy = truey(x,y) -c -c contribution to integral -c - unm = unm + area*quadw(i)* - 1 abs(qpp*uxval*uxval + qpq*uyval*uyval - 2 + qpr*uval*uval) - trunm = trunm + area*quadw(i)* - 1 abs(qpp*trux*trux + qpq*truy*truy - 2 + qpr*tru*tru) -c - 30 continue - 40 continue -c - unm = sqrt(unm) - trunm = sqrt(trunm) -c - return - end -c -c -------- setei -c - subroutine setei(t) - include 'commons' - integer i,j,k,t,limit,inc,lim2,irow,icol,denom,ifact,ii, - 1 bctype - real x1,x2,y1,y2,x,y - real bcrhs,cu -c -c set error indicator problem for triangle t -c -c debug output -c - if (outlev.ge.4) write(ioutpt,101) t - 101 format(' set error indicator problem for triangle',i6) -c -c set idcoei for triangle t -c - call setide(t) -c -c zero coefei and rsei -c - do 20 i=1,nnodev - rsei(i,t)=0. - rsei2(i,t)=0. - do 10 j=1,iorder*iorder+1 - coefei(j,i,t)=0. - 10 continue - 20 continue -c -c zero diagonal block -c - do 25 i=1,nnodev - do 25 j=1,i - blokei(i,j,t)=0. - 25 continue -c -c number of triangles to do quadratures over -c - if (neigh(3,t).le.0) then - limit=2 - else - limit=4 - endif -c -c existing and fictitious node numbers -c - do 40 i=1,iorder - hldnod(i)=node(i,t) - 40 continue - do 50 i=iorder+1,(iorder*(iorder+1))/2 - hldnod(i)=-(i-iorder) - 50 continue -c -c quadratures over each triangle -c - do 600 ii=1,limit -c -c set vertices and define nodes -c use ntri+1 and nvert+1 to simulate the new triangles -c - if (ii.eq.1) then -c - vertex(1,ntri+1)=vertex(1,t) - vertex(2,ntri+1)=vertex(3,t) - vertex(3,ntri+1)=nvert+1 - xvert(nvert+1)=(xvert(vertex(1,t))+xvert(vertex(2,t)))/2. - yvert(nvert+1)=(yvert(vertex(1,t))+yvert(vertex(2,t)))/2. - neigh(1,ntri+1) = ntri+1 - neigh(2,ntri+1) = neigh(3,t) - neigh(3,ntri+1) = neigh(2,t) -c - do 120 i=1,nnodtr - if (renum(1,i).gt.0) then - nodeei(i)=node(renum(1,i),t) - else - nodeei(i)=-renum(1,i) - endif - 120 continue -c - elseif (ii.eq.2) then -c - vertex(1,ntri+1)=vertex(2,t) - neigh(3,ntri+1) = neigh(1,t) -c - do 220 i=1,nnodtr - if (renum(2,i).gt.0) then - nodeei(i)=node(renum(2,i),t) - else - nodeei(i)=-renum(2,i) - endif - 220 continue -c - elseif (ii.eq.3) then -c - vertex(1,ntri+1)=vertex(1,t) - if (neigh(3,neigh(3,t)).eq.t) then - vertex(2,ntri+1)=vertex(3,neigh(3,t)) - neigh(3,ntri+1) = neigh(2,neigh(3,t)) - else - xvert(nvert+2)=(xvert(vertex(1,neigh(3,t))) - 1 +xvert(vertex(2,neigh(3,t))))/2. - yvert(nvert+2)=(yvert(vertex(1,neigh(3,t))) - 1 +yvert(vertex(2,neigh(3,t))))/2. - vertex(2,ntri+1)=nvert+2 - neigh(3,ntri+1) = neigh(3,neigh(3,t)) - endif - neigh(2,ntri+1) = t -c - do 320 i=1,nnodtr - if (renum(3,i).gt.0) then - nodeei(i)=hldnod(renum(3,i)) - else - nodeei(i)=-renum(3,i) - endif - 320 continue -c - else -c - vertex(1,ntri+1)=vertex(2,t) - if (neigh(3,neigh(3,t)).eq.t) then - neigh(3,ntri+1) = neigh(1,neigh(3,t)) - else - neigh(3,ntri+1) = ntri+1 - endif -c - do 420 i=1,nnodtr - if (renum(4,i).gt.0) then - nodeei(i)=hldnod(renum(4,i)) - else - nodeei(i)=-renum(4,i) - endif - 420 continue -c - endif -c -c quadratures -c - call quad(ntri+1,3) -c -c add quadratures to right side -c - do 510 j=1,naddrs - rsei(nodeei(rowrs(j)),t)=rsei(nodeei(rowrs(j)),t)+addrs(j) - 510 continue -c -c add quadratures to matrix -c -c new node - new node inner products go in block -c - lim2=(naddrs*(naddrs+1))/2 - do 520 j=1,lim2 - irow=nodeei(row(j)) - icol=nodeei(col(j)) - if (irow.lt.icol) then - irow=icol - icol=nodeei(row(j)) - endif - blokei(irow,icol,t)=blokei(irow,icol,t)+add(j) - 520 continue -c -c new node - old node inner products go in coefei -c - do 530 j=lim2+1,nadd - irow=nodeei(row(j)) - icol=nodeei(col(j)) - k=1 - 521 if (idcoei(k,irow,t).eq.icol) go to 522 - k=k+1 - if (k.gt.iorder*iorder) then - write(ioutpt,525) icol,irow - stop - 525 format(' ********FATAL ERROR********'// - 1 ' couldnt find column ',i10,' in row ',i10, - 2 ' in routine setei') - endif - go to 521 - 522 continue - coefei(k,irow,t)=coefei(k,irow,t)+add(j) - 530 continue -c - 600 continue -c -c save diagonal in coefei -c - do 610 i=1,nnodev - coefei(iorder*iorder+1,i,t)=blokei(i,i,t) - 610 continue -c - if (iorder.ne.2) then -c -c complete diagonal block -c - do 620 j=2,nnodev - do 620 i=1,j-1 - blokei(i,j,t)=blokei(j,i,t) - 620 continue -c -c save blokei before boundary modifications -c - do 621 i=1,nnodev - do 621 j=1,nnodev - bloke2(i,j,t)=blokei(i,j,t) - 621 continue -c -c check for boundary nodes -c - do 630 i=1,nnodev - bndnei(i)=.false. - 630 continue - if (neigh(3,t).le.0) then - denom=2*(iorder-1) - ifact=denom+1 - inc=-2 - x1=xvert(vertex(1,t)) - x2=xvert(vertex(2,t)) - y1=yvert(vertex(1,t)) - y2=yvert(vertex(2,t)) - do 640 i=1,nnodvb - if (nbasch(i).eq.iorder) then - ifact=ifact+inc - if (inc.lt.0 .and. ifact.lt.denom/2) then - inc=2 - ifact=1 - endif - x=(ifact*x1+(denom-ifact)*x2)/float(denom) - y=(ifact*y1+(denom-ifact)*y2)/float(denom) - call bcond(x,y,-neigh(3,t),cu,bcrhs,bctype) - if (bctype.eq.1) then - bndnei(i)=.true. - bcei(i,t)=bcrhs - endif - endif - 640 continue - endif -c -c modify boundary rows of diagonal block -c - if (neigh(3,t).le.0) then - do 660 i=1,nnodvb - if (bndnei(i)) then - do 650 j=1,nnodvb - blokei(i,j,t)=0. - if (.not. bndnei(j)) then - rsei2(j,t)=rsei2(j,t)-blokei(j,i,t)*bcei(i,t) - endif - blokei(j,i,t)=0. - 650 continue - blokei(i,i,t)=1. - endif - 660 continue - endif -c -c special case for order 2 -c - else -c -c check for boundary -c - if (neigh(3,t).le.0) then - x=(xvert(vertex(1,t))+xvert(vertex(2,t)))/2. - y=(yvert(vertex(1,t))+yvert(vertex(2,t)))/2. - call bcond(x,y,-neigh(3,t),cu,bcrhs,bctype) - if (bctype.eq.1) then - bcei(1,t)=bcrhs - endif - endif -c - endif -c -c put t on any error indicator list -c the error indicator will be computed with local relaxations -c - errind(t)=eimax - call elstad(t) -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,102) - 102 format(' coefei and idcoei') - if (neigh(3,t).le.0) then - limit=nnodvb - else - limit=nnodev - endif - do 103 i=1,limit - write(ioutpt,104) (idcoei(j,i,t),coefei(j,i,t), - 1 j=1,iorder*iorder) - 104 format(3(i6,1pe15.8)) - write(ioutpt,105) coefei(iorder*iorder+1,i,t),rsei(i,t) - 105 format(' diagonal and right side ',1pe15.8,1pe15.8) - 103 continue - write(ioutpt,106) - 106 format(' blokei') - do 107 i=1,limit - write(ioutpt,108)(blokei(i,j,t),j=1,limit) - 108 format(3(1pe15.8)) - 107 continue - write(ioutpt,109) - 109 format(' boundary nodes') - write(ioutpt,110) (bndnei(j),j=1,limit) - 110 format(25l3) - endif -c - return - end -c -c -------- setei2 -c - subroutine setei2(t1,t2) - include 'commons' - integer t1,t2 -c -c set error indicator problem for second triangle -c -c t2 is the triangle recently created, t1 is its already -c existing mate. the error indicator problem for these two -c triangles already exists and is associated with t1. need -c to set the null problem up for t2 and change some column -c pointers for t1 for the recently created nodes in t2. -c -c flag to show t2 does not have the problem -c - coefei(iorder*iorder+1,1,t2)=0. - errind(t2)=0. -c -c look for negative column pointers in t1's error indicator -c problem and change them to the nodes in t2 -c - do 10 i=1,nnodev - do 10 j=1,iorder*iorder - if (idcoei(j,i,t1).lt.0) - 1 idcoei(j,i,t1)=node(iorder-idcoei(j,i,t1),t2) - 10 continue -c -c debug output -c - if (outlev.ge.5) then - write(ioutpt,100) t2,t1 - do 101 i=1,nnodev - write(ioutpt,200) (idcoei(j,i,t1),j=1,iorder*iorder) - 101 continue - endif - 100 format(' set null error indicator problem for triangle',i6/ - 1 ' new column pointers for triangle',i6,' are ') - 200 format(12i6) -c - return - end -c -c --------- setide -c - subroutine setide(t) - include 'commons' - integer sumord,i,j,t -c -c set idcoei, the column ponter for the error indicator -c problem, for triangle t -c -c new nodes in first triangle -c - sumord=(iorder*(iorder+1))/2 -c - do 40 i=1,nnodvb -c -c old nodes in first triangle -c - do 10 j=1,sumord - idcoei(j,i,t)=node(j,t) - 10 continue -c -c for nodes on the interface between triangles, old nodes -c in second triangle if it exists -c since the second triangle has not yet been defined, use a local -c numbering and negate it as a flag -c - if (nbasch(i).eq.iorder .and. neigh(3,t).gt.0) then - do 20 j=sumord+1,iorder*iorder - idcoei(j,i,t)=-(j-sumord) - 20 continue -c -c for nodes not on the interface zero the rest of idcoef -c - else -c - do 30 j=sumord+1,iorder*iorder - idcoei(j,i,t)=0 - 30 continue - endif -c - 40 continue -c -c new nodes in second triangle, if it exists -c - if (iorder.ne.2 .and. neigh(3,t).gt.0) then - do 80 i=nnodvb+1,nnodev -c -c old nodes on interface between triangles -c - do 50 j=1,iorder - idcoei(j,i,t)=node(j,t) - 50 continue -c -c old nodes in second triangle -c - do 60 j=iorder+1,sumord - idcoei(j,i,t)=-(j-iorder) - 60 continue -c -c zero the rest of idcoei -c - do 70 j=sumord+1,iorder*iorder - idcoei(j,i,t)=0 - 70 continue - 80 continue - endif -c - return - end - function clock(idum) -c -c returns user time since beginning of program -c - clock = second() -c - return - end -c -c -------- outhed -c - subroutine outhed - include 'commons' -c -c header output -c - write(ioutpt,100) - 100 format(' MULTIGRID GALERKIN HIERARCHICAL ADAPTIVE TRIANGLES', - 1 ' (MGGHAT)'//) - write(ioutpt,101) - 101 format(' Version 1.1 June 1994'/) -c - if (outlev.ge.1) write(ioutpt,200) outlev,iorder,ncyc,nu1, - 1 nu2,mgfreq,tol - 200 format(' input parameters'/ - 1 ' output level ',2x,i2/ - 1 ' polynomial order ',2x,i2/ - 1 ' number of cycles ',2x,i2/ - 2 ' relaxes before cgc ',2x,i2/ - 3 ' relaxes after cgc ',2x,i2/ - 3 ' multigrid frequency ',1pe15.8/ - 4 ' error tolerance ',1pe15.8) -c - if (outlev.ge.1) then - if (unifrm) then - write(ioutpt,201) - else - write(ioutpt,202) - endif - endif - 201 format(' refinement uniform'/) - 202 format(' refinement adaptive'/) -c - return - end -c -c -------- outref -c - subroutine outref - include 'commons' - integer i - real time - external clock -c -c debug output at end of refinement -c -c measure time -c - time = clock(0) -c - if(outlev.ge.2) then - write(ioutpt,100) nvert,nnode,ntri,nlev,timerl,timert - 100 format(/' refinement complete'// - 1 ' number of vertices ',i10/ - 2 ' number of nodes ',i10/ - 2 ' number of triangles',i10/ - 3 ' number of levels ',i10/ - 4 /' time for refinement (this grid) ',f10.2/ - 5 ' time for refinement (all grids) ',f10.2) - endif - if (outlev.ge.3) then - write(ioutpt,101) - write(ioutpt,102)(i,lbvert(i),lvert(i), - 1 lbvert(i)+lvert(i),i=1,nlev) - 101 format(/' number of vertices on each level is:'/ - 1 ' level boundary interior total') - 102 format(1x,i4,5x,i8,5x,i8,5x,i8) - endif -c - if(outlev.ge.4) then - call plttri(1,1) - call plttri(3,0) - endif -c -c remove time for this from total time -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time -c - return - end -c -c -------- outsol -c - subroutine outsol - include 'commons' - real emaxv,emaxn,emaxq,eenrg,time - external clock -c -c output at end of solution phase -c -c measure and save norms of u and true for later use -c - call unorm(un,trun) - unrm = un - trunrm = trun -c -c measure time to remove unnecessary work -c - time = clock(0) -c -c if useful, measure and save norms of error for later use -c - if (outlev.ge.2 .or. gpconv.ne.0 .or. grafic) then - call errors(emaxv,emaxn,emaxq,eenrg) - gerr = eenrg - if (trunrm.ge.1e-10) then - rgerr = gerr/trunrm - else - rgerr = gerr - endif - emax = emaxq - if (emaxn.gt.emax) emax=emaxn - gpmxer(gplev)=emax - gpener(gplev)=rgerr - gpnode(gplev)=nnode - endif -c -c debug output -c - if (outlev.ge.2) then - write(ioutpt,101) emaxv,emaxn,emaxq,eenrg,rgerr - 101 format(/' solution complete'/ - 1 /' norms of error (meaningful only if TRUE is supplied):'// - 1 ' max norm at vertices ',1pe15.8/ - 2 ' max norm at nodes ',1pe15.8/ - 3 ' max norm at quad pts ',1pe15.8/ - 4 ' continuous energy norm ',1pe15.8/ - 5 ' relative energy norm ',1pe15.8) - write(ioutpt,102) timesl,timest - 102 format(/' time for solution (this grid) ',f10.2/ - 1 ' time for solution (all grids) ',f10.2) - endif -c - if (outlev.ge.4) then - write(ioutpt,103) - 103 format(/' solution'/) - call prvec(u,1,nlev) - endif -c - if (outlev.ge.4) then - call plttri(2,0) - endif -c -c remove time for this from total time -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time -c - return - end -c -c -------- outtri -c - subroutine outtri - include 'commons' - integer i,j -c -c print triangulation information -c - write(ioutpt,100) - do 10 i=1,ntri - write(ioutpt,101) i,(vertex(j,i),j=1,3),(neigh(j,i),j=1,3) - 10 continue -c - write(ioutpt,200) - do 20 i=1,nvert - write(ioutpt,201) i,xvert(i),yvert(i),vrtlev(i),nextvt(i), - 1 (tringl(j,i),j=1,8) - if (vrtlev(i).lt.0) then - lim = nnodvb - else - lim = nnodev - endif - write(ioutpt,202) (olndvt(j,i),j=1,lim) - 20 continue - write(ioutpt,300) - do 30 i=1,ntri - write(ioutpt,301) i - write(ioutpt,302) (node(j,i),j=1,nnodtr) - 30 continue -c - 100 format(/' triangle data structures'/ - 1 /' triangle',11x,'vertices',12x,'neighbors') - 101 format(1x,i6,4x,3i6,4x,3i6) - 200 format(/' vertex data structures'/ - 1 /' vertex',9x,'x-coord',8x,'y-coord',7x,'level link') - 201 format(1x,i6,2(2x,1pe15.8),2i6/10x,'triangles',8i6) - 202 format(10x,'old nodes',16i6) - 300 format(/' nodes for each triangle'/) - 301 format(' triangle ',i6) - 302 format(10i6) -c - return - end -c -c -------- outmat -c - subroutine outmat - include 'commons' - integer i,j -c -c print matrix -c - write(ioutpt,100) - do 10 i=1,nnode - write(ioutpt,101) - write(ioutpt,102) (idcoef(j,i),coef(j,i),j=1,mxidlo), - 1 i,coef(mxidlo+1,i) - write(ioutpt,103) rs(i) - write(ioutpt,104) (idcoef(j,i),j=mxidlo+1,mxidup) - 10 continue -c - 100 format(' matrix') - 101 format(/) - 102 format(3(i6,1pe15.8)) - 103 format(' rs ',1pe15.8) - 104 format(11i6) -c - return - end -c -c -------- outend -c - subroutine outend - include 'commons' - real emaxv,emaxn,emaxq,eenrg,effind,rgeres - external clock -c -c make output files for gnuplot if runtime graphics haven't -c already made them and they were requested -c - if (.not. grafic) then - if ((gptri.ne.0 .or. gpsol.ne.0 .or. gpconv.ne.0) - . .and. outlev.ge.2) write(ioutpt,910) - 910 format(/' write data files for post processing graphics') - if (gptri.ne.0) call filtri - gpsolx=gpsol - gpsoly=gpsol - if (gpsol.ne.0) call filsol - if (gpconv.ne.0) call filcon - endif -c -c compute total time -c - timett = clock(0) - timett -c -c output at end of program -c - if (outlev.ge.1) write(ioutpt,901) - 901 format(/' final solution complete'/) - if (outlev.ge.3) then - call plttri(0,0) - write(ioutpt,250) - write(ioutpt,251) (i,lbvert(i),lvert(i), - 1 lbvert(i)+lvert(i),i=1,nlev) - write(ioutpt,252) - 250 format(/' number of vertices on each level is:'/ - 1 ' level boundary interior total') - 251 format(1x,i4,5x,i10,5x,i10,5x,i10) - 252 format(/) - endif - if (outlev.ge.1) then - call errors(emaxv,emaxn,emaxq,eenrg) - if (eenrg.ne.0.) then - effind=gerest/eenrg - else - effind=1. - endif - write(ioutpt,302) - write(ioutpt,301) emaxv,emaxn,emaxq,eenrg - write(ioutpt,303) eimax,gerest,effind - 302 format(' (errors and effectivity index are meaningful'/ - 1 ' only if TRUE is supplied)') - 301 format(' maximum error at vertices ',1pe15.8/ - 2 ' maximum error at nodes ',1pe15.8/ - 3 ' maximum error at quad pts ',1pe15.8/ - 4 ' continuous energy norm ',1pe15.8) - 303 format(/' maximum error indicator ',1pe15.8/ - 1 ' error estimate ',1pe15.8/ - 2 ' effectivity index ',1pe15.8) -c - call unorm(unrm,trunrm) - if (abs(unrm).gt.1.e-10) then - rgeres = gerest/unrm - else - rgeres = gerest - endif - if (abs(trunrm) .gt. 1.e-10) eenrg = eenrg/trunrm - if (eenrg .ne. 0.) then - effind = rgeres/eenrg - else - effind = 1. - endif - write(ioutpt,313) rgeres,effind - 313 format(/' relative energy norm ',1pe15.8/ - 1 ' relative effect index ',1pe15.8) -c - write(ioutpt,100) nvert,nnode,ntri,nlev - 100 format(/' number of vertices ',i10/ - 1 ' number of nodes ',i10/ - 1 ' number of triangles ',i10/ - 2 ' number of levels ',i10/) -c - write(ioutpt,150) timei,timert,timest,timeet,timett - 150 format(/' time for initializations ',f10.2/ - 1 ' time for refinement ',f10.2/ - 2 ' time for solution ',f10.2/ - 3 ' time for error estimates ',f10.2/ - 4 ' total time ',f10.2/) -c - write(ioutpt,151) ndrwrk, ndiwrk - 151 format(/' approximate memory allocation:'/ - 1 ' real words ',i10/ - 2 ' integer words ',i10/) - if (ierr.eq.0) then - write(ioutpt,401) - 401 format(/' termination by achieving error tolerence') - elseif (ierr.eq.1) then - write(ioutpt,402) - 402 format(/' termination due to achieving maximum vertices') - elseif (ierr.eq.2) then - write(ioutpt,403) - 403 format(/' termination due to achieving maximum triangles') - elseif (ierr.eq.3) then - write(ioutpt,404) - 404 format(/' termination due to achieving maximum level') - elseif (ierr.eq.4) then - write(ioutpt,405) - 405 format(/' termination due to achieving maximum nodes') - elseif (ierr.eq.5) then - write(ioutpt,406) - 406 format(/' termination due to time limit') - else - write(ioutpt,410) ierr - 410 format(/' error code ',i6) - endif -c - write(ioutpt,500) - 500 format(/' execution sucessful') - endif -c - return - end -c -c -------- prvec -c - subroutine prvec(vec,lev1,lev2) - include 'commons' - integer vert,i,j,l,lev1,lev2,pvert(3),node1,k,lolim - real pvec(3),vec(*) -c -c print the vector vec grouped by hierarchical levels -c start with level lev1 and print to level lev2 -c -c -c special case for level 1 vertices -c - lolim=lev1 - if (lev1.eq.1) then - lolim=2 - write(ioutpt,100) lev1 - i=0 - do 9 node1=1,nnode0 - i=i+1 - pvec(i) = vec(node1) - pvert(i) = node1 - if (i .eq. 3) then - write(ioutpt,200) (pvert(j),pvec(j),j=1,3) - i=0 - endif - 9 continue - if (i.ne.0) write(ioutpt,200) (pvert(j),pvec(j),j=1,i) - endif -c -c -c levels other than 1 -c - if (lolim.gt.lev2) go to 31 - do 30 l=lolim,lev2 - write(ioutpt,100) l - 100 format(/,' level ',i3/) -c - vert = frstvt(l) - i=0 - 1 if (vert .eq. -1) go to 2 - node1=nwndvt(vert)-1 - do 10 k=1,nnodev - i=i+1 - pvec(i) = vec(node1+k) - pvert(i) = node1+k - if (i .eq. 3) then - write(ioutpt,200) (pvert(j),pvec(j),j=1,3) - i=0 - endif - 10 continue - vert = nextvt(vert) - go to 1 - 2 continue - if (i.ne.0) write(ioutpt,200) (pvert(j),pvec(j),j=1,i) -c - 30 continue - 31 continue -c - 200 format(1x,3(i6,1x,1pe15.8,2x)) -c - return - end -c -c -------- plttri -c - subroutine plttri(labvrt,labtri) - include 'commons' - character*1 pp(67,65),c,num(0:9) - integer i,j,k,l,ix,iy,n,sub,tri,deg,v(4) - real x1,x2,y1,y2,t,x,y,dx,dy,ax,ay,bx,by - real rx1,rx2,rx3,ry1,ry2,ry3,rx,ry -c -c plot triangulation on the line printer including -c optional information at each vertex and triangle -c -c optional information is: -c -c labvrt - value to print at vertices -c -c 0 - nothing -c 1 - vertex number -c 2 - -log2(error at node) -c 3 - node numbers -c -c labtri - value to print at triangle centers -c -c 0 - nothing -c 1 - triangle number -c 2 - -c 3 - -log2(error indicator for triangle) -c -c -c indicate what follows -c - write(ioutpt,100) - 100 format(/' triangulation plot'/) - if(labvrt.eq.1) then - write(ioutpt,110) - elseif(labvrt.eq.2) then - write(ioutpt,111) - elseif(labvrt.eq.3) then - write(ioutpt,112) - endif - 110 format(' vertices labeled with vertex number') - 111 format(' nodes labeled with -log2(error at node)') - 112 format(' nodes labeled with node number') - if (labtri.eq.1) then - write(ioutpt,120) - elseif (labtri.eq.3) then - write(ioutpt,122) - endif - 120 format(' triangles labeled with triangle number') - 122 format(' triangles labeled with -log2(error indicator)') - write(ioutpt,150) - 150 format(/) -c -c start with blank plot -c - do 10 i=1,67 - do 10 j=1,65 - pp(i,j)=' ' - 10 continue -c -c initialize number characters -c - num(0) = '0' - num(1) = '1' - num(2) = '2' - num(3) = '3' - num(4) = '4' - num(5) = '5' - num(6) = '6' - num(7) = '7' - num(8) = '8' - num(9) = '9' -c -c find min and max x and y -c - i=frstvt(1) - ax=xvert(i) - bx=ax - ay=yvert(i) - by=ay - i=nextvt(i) - 1 if(i.eq.-1) go to 2 - if (xvert(i).lt.ax) ax=xvert(i) - if (xvert(i).gt.bx) bx=xvert(i) - if (yvert(i).lt.ay) ay=yvert(i) - if (yvert(i).gt.by) by=yvert(i) - i=nextvt(i) - go to 1 - 2 continue -c -c draw triangles -c - do 40 i=1,ntri - v(1)=vertex(1,i) - v(2)=vertex(2,i) - v(3)=vertex(3,i) - v(4)=vertex(1,i) - do 35 loop=1,3 -c -c find endpoints of line to draw -c - x1=xvert(v(loop)) - y1=yvert(v(loop)) - x2=xvert(v(loop+1)) - y2=yvert(v(loop+1)) -c -c scale points to plotting area -c - x1=(x1-ax)/(bx-ax) - y1=(y1-ay)/(by-ay) - x2=(x2-ax)/(bx-ax) - y2=(y2-ay)/(by-ay) -c -c determine character to use by the slope of the line -c - dx = x2-x1 - dy = y2-y1 - if (dx .eq. 0.) then - c = '|' - else - s=dy/dx - if (abs(s).gt.2) then - c = '|' - elseif (abs(s).lt..5) then - c = '-' - elseif (s.gt.0.) then - c = '/' - else - c = '\\' - endif - endif -c -c determine number of pixels in line segment -c - t = abs(dx) - if (abs(dy).gt.abs(dx)) t=abs(dy) - n = int(65.*t) -c -c draw line segment -c - do 30 j=0,n - t=float(j)/float(n+1) - x=t*x1 + (1.-t)*x2 - y=t*y1 + (1.-t)*y2 - ix=int(64.*x+1.5) - iy=int(64.*y+1.5) - pp(ix,iy)=c - 30 continue - 35 continue - 40 continue -c -c number the vertices -c - if (labvrt.eq.0) go to 51 - if (labvrt.gt.1) go to 52 - do 50 i=1,nvert - ix = int(64.*(xvert(i)-ax)/(bx-ax)+1.5) - iy = int(64.*(yvert(i)-ay)/(by-ay)+1.5) - j=i - if(j.lt.0) j=0 - if(j.ge.1000) j=j-1000*int(j/1000) - if(j.ge.100) then - k=int(j/100) - pp(ix,iy) = num(k) - ix = ix+1 - j=j-100*k - endif - if (j.ge.10) then - k = int(j/10) - pp(ix,iy) = num(k) - ix = ix+1 - j=j-10*k - endif - pp(ix,iy) = num(j) - 50 continue - go to 51 -c -c number the nodes -c - 52 continue - do 159 tri=1,ntri - rx1=xvert(vertex(1,tri)) - rx2=xvert(vertex(2,tri)) - rx3=xvert(vertex(3,tri)) - ry1=yvert(vertex(1,tri)) - ry2=yvert(vertex(2,tri)) - ry3=yvert(vertex(3,tri)) - x1=(rx1-ax)/(bx-ax) - y1=(ry1-ay)/(by-ay) - x2=(rx2-ax)/(bx-ax) - y2=(ry2-ay)/(by-ay) - x3=(rx3-ax)/(bx-ax) - y3=(ry3-ay)/(by-ay) - sub=1 - deg=iorder-1 - do 158 i=0,deg - do 157 j=0,deg-i - x=((deg-i-j)*x1+j*x2+i*x3)/float(deg) - y=((deg-i-j)*y1+j*y2+i*y3)/float(deg) - rx=((deg-i-j)*rx1+j*rx2+i*rx3)/float(deg) - ry=((deg-i-j)*ry1+j*ry2+i*ry3)/float(deg) - ix=int(64.*x+1.5) - iy=int(64.*y+1.5) - if (labvrt.eq.2) then - err=abs(u(node(sub,tri))-true(rx,ry)) - if (err.eq.0.) then - l=99 - else - l=-int(log(err)/log(2.)) - endif - elseif (labvrt.eq.3) then - l=node(sub,tri) - endif - if(l.lt.0) l=0 - if(l.ge.1000) l=l-1000*int(l/1000) - if(l.ge.100) then - k=int(l/100) - pp(ix,iy) = num(k) - ix = ix+1 - l=l-100*k - endif - if (l.ge.10) then - k = int(l/10) - pp(ix,iy) = num(k) - ix = ix+1 - l=l-10*k - endif - pp(ix,iy) = num(l) - sub=sub+1 - 157 continue - 158 continue - 159 continue -c -c number the triangles -c - 51 if (labtri.eq.0) go to 61 - do 60 i=1,ntri - x=(xvert(vertex(1,i))+xvert(vertex(2,i)) - 1 +xvert(vertex(3,i)))/3. - y=(yvert(vertex(1,i))+yvert(vertex(2,i)) - 1 +yvert(vertex(3,i)))/3. - x=(x-ax)/(bx-ax) - y=(y-ay)/(by-ay) - ix = int(64.*x+1.5) - iy = int(64.*y+1.5) - if (labtri.eq.1) then - j=i - elseif (labtri.eq.3) then - if (errind(i).eq.0.) then - j=99 - else - j=-int(log(errind(i))/log(2.)) - endif - endif - if(j.lt.0) j=0 - if(j.ge.1000) j=j-1000*int(j/1000) - if(j.ge.100) then - k=int(j/100) - pp(ix,iy) = num(k) - ix = ix+1 - j=j-100*k - endif - if (j.ge.10) then - k = int(j/10) - pp(ix,iy) = num(k) - ix = ix+1 - j=j-10*k - endif - pp(ix,iy) = num(j) - 60 continue - 61 continue -c -c print plot -c - write(ioutpt,500) ((pp(i,j),i=1,67),j=65,1,-1) - 500 format(1x,67a1) -c - return - end -c -c -------- solut -c - real function solut(x,y,iderv,t) -c - include 'commons' - real x,y - integer iderv,t -c -c evaluate the solution at the point (x,y) -c returns 0 if (x,y) is not in the domain -c -c iderv specifies what derivative to evaluate -c 1-uxx 2-uxy 3-uyy 4-ux 5-uy 6-u -c -c t is input as a guess of which triangle (x,y) is in -c t is returned as the correct triangle -c - solut = solut0(x,y,iderv,t,xvert,yvert,vertex, - . neigh,node,u,ntri,iorder,nnodtr,ndord3) -c - return - end -c -c -------- ssolut (saved solut) -c - real function ssolut(x,y,iderv,t,rwrk,iwrk) -c - real x,y,rwrk(*) - integer iderv,t,iwrk(*) -c - integer ndord3,nvert,ntri - integer xvert,yvert,u,vertex,neigh,node,iorder,nnodtr -c -c evaluate the saved solution at the point (x,y) -c returns 0 if (x,y) is not in the domain -c the solution is obtained from rwrk and iwrk, which must -c be filled by subroutine save -c -c iderv specifies what derivative to evaluate -c 1-uxx 2-uxy 3-uyy 4-ux 5-uy 6-u -c -c t is input as a guess of which triangle (x,y) is in -c t is returned as the correct triangle -c -c pick off needed saved dimensions and grid sizes -c - ndord3 = iwrk(12) - nvert = iwrk(16) - ntri = iwrk(17) -c -c find beginning of needed data structures -c - iorder = iwrk(20) - nnodtr = iwrk(21) - xvert = 1 - yvert = xvert + nvert - u = yvert + nvert - vertex = 22 - neigh = vertex + 3*ntri - node = neigh + 3*ntri -c - ssolut = solut0(x,y,iderv,t,rwrk(xvert),rwrk(yvert),iwrk(vertex), - . iwrk(neigh),iwrk(node),rwrk(u),ntri,iorder,nnodtr,ndord3) -c - return - end -c -c -------- solut0 -c - real function solut0(x,y,iderv,t,xvert,yvert,vertex, - . neigh,node,u,ntri,iorder,nnodtr,ndord3) - real xvert(*),yvert(*),u(*) - integer vertex(3,*),neigh(3,*),node(ndord3,*) - integer ntri,iorder,nnodtr,ndord3 - integer iderv,t,nodbc(3),deg,n,nod,i,j - real x,y,x1,x2,x3,y1,y2,y3,det,dzdx(3),dzdy(3),zeta(3), - 1 b,bx,by,bxx,bxy,byy,nf,factor,eps -c -c this is the real solution evaluation routine called by -c solut and ssolut -c - eps = 4.*r1mach(4) -c -c evaluate the solution at the point (x,y) -c returns 0 if (x,y) is not in the domain -c -c iderv specifies what derivative to evaluate -c 1-uxx 2-uxy 3-uyy 4-ux 5-uy 6-u -c -c t is input as a guess of which triangle (x,y) is in -c t is returned as the correct triangle -c -c start t as a legal triangle -c - if (t.lt.1) t=1 - if (t.gt.ntri) t=ntri -c -c find the triangle that contains the point -c - 1 continue -c -c constants that give the linear transformation from the -c reference triangle to triangle t -c - x1=xvert(vertex(1,t)) - x2=xvert(vertex(2,t)) - x3=xvert(vertex(3,t)) - y1=yvert(vertex(1,t)) - y2=yvert(vertex(2,t)) - y3=yvert(vertex(3,t)) - det=x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2) - dzdx(1)=(y2-y3)/det - dzdx(2)=(y3-y1)/det - dzdx(3)=(y1-y2)/det - dzdy(1)=(x3-x2)/det - dzdy(2)=(x1-x3)/det - dzdy(3)=(x2-x1)/det -c -c barycentric coordinates of x,y in this triangle -c - zeta(1)=x*dzdx(1)+y*dzdy(1)+(x2*y3-x3*y2)/det - zeta(2)=x*dzdx(2)+y*dzdy(2)+(x3*y1-x1*y3)/det - zeta(3)=x*dzdx(3)+y*dzdy(3)+(x1*y2-x2*y1)/det -c -c points that are within (4*)machine epsilon, in either x or y, -c of being on a line are placed on the line -c - if (abs(zeta(1))/amax1(abs(dzdx(1)),abs(dzdy(1))) .le. eps) - . zeta(1) = 0. - if (abs(zeta(2))/amax1(abs(dzdx(2)),abs(dzdy(2))) .le. eps) - . zeta(2) = 0. - if (abs(zeta(3))/amax1(abs(dzdx(3)),abs(dzdy(3))) .le. eps) - . zeta(3) = 0. -c -c if any zeta is negative the point is not in t, move to the -c triangle opposite that vertex -c - if (zeta(1).lt.0. .and. neigh(1,t).gt.0) then - t=neigh(1,t) - go to 1 - elseif (zeta(2).lt.0. .and. neigh(2,t).gt.0) then - t=neigh(2,t) - go to 1 - elseif (zeta(3).lt.0. .and. neigh(3,t).gt.0) then - t=neigh(3,t) - go to 1 - endif -c - solut0=0. -c -c if there is still a negative zeta, the triangle wasn't found. If -c the domain is not convex, it might have been missed, so check -c every triangle. -c - if (zeta(1).lt.0. .or. zeta(2).lt.0. .or. zeta(3).lt.0.) then - do 5 it=1,ntri - x1=xvert(vertex(1,it)) - x2=xvert(vertex(2,it)) - x3=xvert(vertex(3,it)) - y1=yvert(vertex(1,it)) - y2=yvert(vertex(2,it)) - y3=yvert(vertex(3,it)) - det=x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2) - dzdx(1)=(y2-y3)/det - dzdx(2)=(y3-y1)/det - dzdx(3)=(y1-y2)/det - dzdy(1)=(x3-x2)/det - dzdy(2)=(x1-x3)/det - dzdy(3)=(x2-x1)/det - zeta(1)=x*dzdx(1)+y*dzdy(1)+(x2*y3-x3*y2)/det - zeta(2)=x*dzdx(2)+y*dzdy(2)+(x3*y1-x1*y3)/det - zeta(3)=x*dzdx(3)+y*dzdy(3)+(x1*y2-x2*y1)/det - if (abs(zeta(1))/amax1(abs(dzdx(1)),abs(dzdy(1))) .le. eps) - . zeta(1) = 0. - if (abs(zeta(2))/amax1(abs(dzdx(2)),abs(dzdy(2))) .le. eps) - . zeta(2) = 0. - if (abs(zeta(3))/amax1(abs(dzdx(3)),abs(dzdy(3))) .le. eps) - . zeta(3) = 0. - if (zeta(1).ge.0. .and. zeta(2).ge.0. .and. zeta(3).ge.0.) then - t=it - go to 6 - endif - 5 continue -c -c if we still didn't find it, the point is not in the domain -c - return - endif -c - 6 continue -c -c have found the triangle containing (x,y) -c - nodbc(1)=iorder - nodbc(2)=-1 - nodbc(3)=0 - deg=iorder-1 -c -c for each node of the triangle . . . -c - do 30 n=1,nnodtr - nod=node(n,t) -c -c barycentric coordinates of node scaled by degree of basis -c - nodbc(1)=nodbc(1)-1 - nodbc(2)=nodbc(2)+1 - if (nodbc(1).lt.0) then - nodbc(3)=nodbc(3)+1 - nodbc(2)=0 - nodbc(1)=deg-nodbc(3) - endif -c -c evaluate the basis and derivatives at (x,y) -c - b=1. - bx=0. - by=0. - bxx=0. - bxy=0. - byy=0. - nf=1. - do 20 i=1,3 - do 10 j=0,deg-1 - if(nodbc(i).gt.j) then - nf=nf*float(nodbc(i)-j)/deg - factor=zeta(i)-float(j)/deg - if(iderv.eq.1) - 1 bxx=bxx*factor+2.*bx*dzdx(i) - if(iderv.eq.2) - 1 bxy=bxy*factor+bx*dzdy(i)+by*dzdx(i) - if(iderv.eq.3) - 1 byy=byy*factor+2.*by*dzdy(i) - if(iderv.eq.1.or.iderv.eq.2.or.iderv.eq.4) - 1 bx=bx*factor+b*dzdx(i) - if(iderv.eq.2.or.iderv.eq.3.or.iderv.eq.5) - 1 by=by*factor+b*dzdy(i) - b=b*factor - endif - 10 continue - 20 continue - b=b/nf - bx=bx/nf - by=by/nf - bxx=bxx/nf - bxy=bxy/nf - byy=byy/nf -c -c add to solut the basis (or derivative) value times the nodal value -c - if(iderv.eq.1) then - solut0=solut0+bxx*u(nod) - elseif(iderv.eq.2) then - solut0=solut0+bxy*u(nod) - elseif(iderv.eq.3) then - solut0=solut0+byy*u(nod) - elseif(iderv.eq.4) then - solut0=solut0+bx*u(nod) - elseif(iderv.eq.5) then - solut0=solut0+by*u(nod) - else - solut0=solut0+b*u(nod) - endif - 30 continue -c - return - end -c -c -------- icopy -c - subroutine icopy(n,sx,incx,sy,incy) -c -c this is exactly BLAS scopy with the name changed to icopy -c and the declaration of sx and sy changed to integer -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c - integer sx(*),sy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - sy(iy) = sx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sy(i) = sx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - sy(i) = sx(i) - sy(i + 1) = sx(i + 1) - sy(i + 2) = sx(i + 2) - sy(i + 3) = sx(i + 3) - sy(i + 4) = sx(i + 4) - sy(i + 5) = sx(i + 5) - sy(i + 6) = sx(i + 6) - 50 continue - return - end -c -c -------- lcopy -c - subroutine lcopy(n,sx,incx,sy,incy) -c -c this is exactly BLAS scopy with the name changed to lcopy -c and the declaration of sx and sy changed to logical -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c - logical sx(*),sy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - sy(iy) = sx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sy(i) = sx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - sy(i) = sx(i) - sy(i + 1) = sx(i + 1) - sy(i + 2) = sx(i + 2) - sy(i + 3) = sx(i + 3) - sy(i + 4) = sx(i + 4) - sy(i + 5) = sx(i + 5) - sy(i + 6) = sx(i + 6) - 50 continue - return - end -c -c -------- save -c - subroutine save(rwrk,iwrk,lwrk) -c -c this subroutine saves the common blocks into the arrays -c rwrk (real), iwrk (integer) and lwrk (logical). The arrays -c should be dimensioned with ndrwrk, ndiwrk and ndlwrk, respectively, -c which are parameters in the file 'commons' -c - include 'commons' -c real rwrk(ndrwrk) -c integer iwrk(ndiwrk) -c logical lwrk(ndlwrk) - real rwrk(*) - integer iwrk(*) - logical lwrk(*) -c - integer ir, ii, il -c -c ir, ii and il point to the first free space in the wrk arrays -c - ir = 1 - ii = 1 - il = 1 -c -c first save the parameters to verify dimensioning when restored -c and actual numbers of things to indicate how much is stored -c - iwrk(ii ) = ndvert - iwrk(ii+ 1) = ndlev - iwrk(ii+ 2) = ndord - iwrk(ii+ 3) = ndsave - iwrk(ii+ 4) = ndrow0 - iwrk(ii+ 5) = ndband - iwrk(ii+ 6) = ndtri - iwrk(ii+ 7) = ndnode - iwrk(ii+ 8) = ndqpt - iwrk(ii+ 9) = ndord1 - iwrk(ii+10) = ndord2 - iwrk(ii+11) = ndord3 - iwrk(ii+12) = ndord4 - iwrk(ii+13) = ndord5 - iwrk(ii+14) = ndord6 -c - iwrk(ii+15) = nvert - iwrk(ii+16) = ntri - iwrk(ii+17) = nnode - iwrk(ii+18) = nlev - ii = ii + 19 -c -c then save those needed for evaluating the solution -c - iwrk(ii ) = iorder - iwrk(ii+1) = nnodtr - ii = ii + 2 - call scopy(nvert,xvert,1,rwrk(ir),1) - ir = ir + nvert - call scopy(nvert,yvert,1,rwrk(ir),1) - ir = ir + nvert - call icopy(3*ntri,vertex,1,iwrk(ii),1) - ii = ii + 3*ntri - call icopy(3*ntri,neigh,1,iwrk(ii),1) - ii = ii + 3*ntri - call icopy(ndord3*ntri,node,1,iwrk(ii),1) - ii = ii + ndord3*ntri - call scopy(nnode,u,1,rwrk(ir),1) - ir = ir + nnode -c -c now save everything else -c - call icopy(8*nvert,tringl,1,iwrk(ii),1) - ii = ii + 8*nvert - call icopy(4*ndord3,renum,1,iwrk(ii),1) - ii = ii + 4*ndord3 - call scopy(3*ndqpt,quadpt,1,rwrk(ir),1) - ir = ir + 3*ndqpt - call scopy(ndqpt,qptb,1,rwrk(ir),1) - ir = ir + ndqpt - call scopy(ndqpt,qwtb,1,rwrk(ir),1) - ir = ir + ndqpt - call scopy(ndord*ndqpt,qpbasb,1,rwrk(ir),1) - ir = ir + ndord*ndqpt - call scopy(ndord*ndqpt,qpbbdz,1,rwrk(ir),1) - ir = ir + ndord*ndqpt - call icopy(nlev,frstvt,1,iwrk(ii),1) - ii = ii + nlev - call icopy(nvert,nextvt,1,iwrk(ii),1) - ii = ii + nvert - call icopy(ndord3,lnewnd,1,iwrk(ii),1) - ii = ii + ndord3 - call icopy(nvert,vrtlev,1,iwrk(ii),1) - ii = ii + nvert - call icopy(nlev,lvert,1,iwrk(ii),1) - ii = ii + nlev - call icopy(nlev,lbvert,1,iwrk(ii),1) - ii = ii + nlev - call icopy(4,eihead,1,iwrk(ii),1) - ii = ii + 4 - call icopy(4,eitail,1,iwrk(ii),1) - ii = ii + 4 - call icopy(ntri,nxttri,1,iwrk(ii),1) - ii = ii + ntri - call icopy(ntri,pretri,1,iwrk(ii),1) - ii = ii + ntri - call icopy(nnode,nxtblk,1,iwrk(ii),1) - ii = ii + nnode - call icopy(ndord3,lolnd1,1,iwrk(ii),1) - ii = ii + ndord3 - call icopy(nvert,nwndvt,1,iwrk(ii),1) - ii = ii + nvert - call icopy(ndord1,nbasch,1,iwrk(ii),1) - ii = ii + ndord1 - call icopy(ndord6,row,1,iwrk(ii),1) - ii = ii + ndord6 - call icopy(ndord6,col,1,iwrk(ii),1) - ii = ii + ndord6 - call icopy(ndord3,rowrs,1,iwrk(ii),1) - ii = ii + ndord3 - call icopy(nlev,stack,1,iwrk(ii),1) - ii = ii + nlev - call icopy(ndord3,hldnod,1,iwrk(ii),1) - ii = ii + ndord3 - call icopy(ndord3,nodeei,1,iwrk(ii),1) - ii = ii + ndord3 - call icopy(ndord3,lolnd2,1,iwrk(ii),1) - ii = ii + ndord3 - call scopy(ntri,errind,1,rwrk(ir),1) - ir = ir + ntri - call scopy(ndqpt,quadw,1,rwrk(ir),1) - ir = ir + ndqpt - call scopy(nnode,rs,1,rwrk(ir),1) - ir = ir + nnode - call scopy(ndord3,addrs,1,rwrk(ir),1) - ir = ir + ndord3 - call scopy(ndord1,uei,1,rwrk(ir),1) - ir = ir + ndord1 - call scopy(ndord3,ueiold,1,rwrk(ir),1) - ir = ir + ndord3 - call scopy(ndord6,add,1,rwrk(ir),1) - ir = ir + ndord6 - call lcopy(nnode,inuse,1,lwrk(il),1) - il = il + nnode - call lcopy(nnode,bndnod,1,lwrk(il),1) - il = il + nnode - call lcopy(ndord1,bndnei,1,lwrk(il),1) - il = il + ndord1 - iwrk(ii ) = mxvert - iwrk(ii+ 1) = mxtri - iwrk(ii+ 2) = mxlev - iwrk(ii+ 3) = mxnode - iwrk(ii+ 4) = nnodev - iwrk(ii+ 5) = nnodvb - iwrk(ii+ 6) = nnode0 - iwrk(ii+ 7) = mxidlo - iwrk(ii+ 8) = mxidup - iwrk(ii+ 9) = ntarg - iwrk(ii+10) = ierr - iwrk(ii+11) = nqpt - iwrk(ii+12) = ncyc - iwrk(ii+13) = nu1 - iwrk(ii+14) = nu2 - iwrk(ii+15) = outlev - iwrk(ii+16) = nadd - iwrk(ii+17) = naddrs - iwrk(ii+18) = ioutpt - iwrk(ii+19) = nvert0 - iwrk(ii+20) = nqptb - ii = ii + 21 - rwrk(ir ) = tol - rwrk(ir+ 1) = eimax - rwrk(ir+ 2) = gerest - rwrk(ir+ 3) = rerest - rwrk(ir+ 4) = timei - rwrk(ir+ 5) = timerl - rwrk(ir+ 6) = timert - rwrk(ir+ 7) = timesl - rwrk(ir+ 8) = timest - rwrk(ir+ 9) = timeel - rwrk(ir+10) = timeet - rwrk(ir+11) = timetl - rwrk(ir+12) = timett - rwrk(ir+13) = mgfreq - rwrk(ir+14) = mxtime - rwrk(ir+15) = gerr - rwrk(ir+16) = rgerr - rwrk(ir+17) = emax - rwrk(ir+18) = unrm - rwrk(ir+19) = trunrm - rwrk(ir+20) = nuniqx - rwrk(ir+21) = nuniqy - rwrk(ir+22) = nuniqv - ir = ir + 23 - lwrk(il ) = unifrm - lwrk(il+1) = gquiet - lwrk(il+2) = menuon - lwrk(il+3) = grafic - lwrk(il+4) = grpaws - lwrk(il+5) = nuniq - il = il + 6 - call lcopy(100,pltsel,1,lwrk(il),1) - il = il + 100 - call icopy(100,gunit,1,iwrk(ii),1) - ii = ii + 100 - iwrk(ii ) = gpfile - iwrk(ii+ 1) = gptri - iwrk(ii+ 2) = gpsol - iwrk(ii+ 3) = gpconv - iwrk(ii+ 4) = gplev - ii = ii + 5 - call icopy(ndsave,gpnode,1,iwrk(ii),1) - ii = ii + ndsave - iwrk(ii ) = gpsolx - iwrk(ii+1) = gpsoly - ii = ii + 2 - call scopy(ndsave,gpmxer,1,rwrk(ir),1) - ir = ir + ndsave - call scopy(ndsave,gpener,1,rwrk(ir),1) - ir = ir + ndsave - call scopy(ndsave,gpeest,1,rwrk(ir),1) - ir = ir + ndsave - call scopy(ndsave,gptime,1,rwrk(ir),1) - ir = ir + ndsave - call icopy(ndord5*nnode,idcoef,1,iwrk(ii),1) - ii = ii + ndord5*nnode - call icopy(ndord2*nvert,olndvt,1,iwrk(ii),1) - ii = ii + ndord2*nvert - call icopy(ndord3*ndord1,ibasch,1,iwrk(ii),1) - ii = ii + ndord3*ndord1 - call icopy(ndord2*ndord1*ntri,idcoei,1,iwrk(ii),1) - ii = ii + ndord2*ndord1*ntri - call scopy(ndord3*ndord1,cbasch,1,rwrk(ir),1) - ir = ir + ndord3*ndord1 - call scopy(ndord3*ndqpt,qpbas,1,rwrk(ir),1) - ir = ir + ndord3*ndqpt - call scopy(ndord1*ntri,rsei,1,rwrk(ir),1) - ir = ir + ndord1*ntri - call scopy(ndord1*ntri,bcei,1,rwrk(ir),1) - ir = ir + ndord1*ntri - call scopy(ndord4*nnode,coef,1,rwrk(ir),1) - ir = ir + ndord4*nnode - call scopy(ndord1*ntri,rsei2,1,rwrk(ir),1) - ir = ir + ndord1*ntri - call scopy(ndord1*ndord1,block,1,rwrk(ir),1) - ir = ir + ndord1*ndord1 - call scopy(3*ndord3*ndqpt,qpdbdz,1,rwrk(ir),1) - ir = ir + 3*ndord3*ndqpt - call scopy((ndord2+1)*ndord1*ntri,coefei,1,rwrk(ir),1) - ir = ir + (ndord2+1)*ndord1*ntri - call scopy(ndord1*ndord1*ntri,blokei,1,rwrk(ir),1) - ir = ir + ndord1*ndord1*ntri - call scopy(ndord1*ndord1*ntri,bloke2,1,rwrk(ir),1) - ir = ir + ndord1*ndord1*ntri - call icopy(ndrow0,ipvt1,1,iwrk(ii),1) - ii = ii + ndrow0 - call icopy(ndrow0,l1ord,1,iwrk(ii),1) - ii = ii + ndrow0 - iwrk(ii) = nband - ii = ii + 1 - call scopy((3*ndband+1)*ndrow0,coefl1,1,rwrk(ir),1) - ir = ir + (3*ndband+1)*ndrow0 - call scopy(ndrow0,rs1,1,rwrk(ir),1) - ir = ir + ndrow0 -c - return - end -c -c -------- restor -c - subroutine restor(rwrk,iwrk,lwrk) -c -c this subroutine restores the common blocks from the arrays -c rwrk (real), iwrk (integer) and lwrk (logical). The arrays -c should be dimensioned with ndrwrk, ndiwrk and ndlwrk, respectively, -c which are parameters in the file 'commons', and should have -c been filled by subroutine save with all the dimension parameter -c values the same as they are now. -c - include 'commons' -c real rwrk(ndrwrk) -c integer iwrk(ndiwrk) -c logical lwrk(ndlwrk) - real rwrk(1) - integer iwrk(1) - logical lwrk(1) -c - integer ir, ii, il -c -c ir, ii and il point to the first free space in the wrk arrays -c - ir = 1 - ii = 1 - il = 1 -c -c first check the parameters to verify dimensioning -c - if (ndvert .ne. iwrk(ii ) .or. - . ndlev .ne. iwrk(ii+ 1) .or. - . ndord .ne. iwrk(ii+ 2) .or. - . ndsave .ne. iwrk(ii+ 3) .or. - . ndrow0 .ne. iwrk(ii+ 4) .or. - . ndband .ne. iwrk(ii+ 5) .or. - . ndtri .ne. iwrk(ii+ 6) .or. - . ndnode .ne. iwrk(ii+ 7) .or. - . ndqpt .ne. iwrk(ii+ 8) .or. - . ndord1 .ne. iwrk(ii+ 9) .or. - . ndord2 .ne. iwrk(ii+10) .or. - . ndord3 .ne. iwrk(ii+11) .or. - . ndord4 .ne. iwrk(ii+12) .or. - . ndord5 .ne. iwrk(ii+13) .or. - . ndord6 .ne. iwrk(ii+14)) then -c -c ERROR -- dimensions are not the same as when saved -c - write(ioutpt,110) - 110 format('FATAL ERROR -- restore dimension not the same', - . ' as save dimension') - stop - endif -c - ii = ii + 15 - nvert = iwrk(ii ) - ntri = iwrk(ii+1) - nnode = iwrk(ii+2) - nlev = iwrk(ii+3) - ii = ii + 4 -c -c then restore the data structures -c - iorder = iwrk(ii ) - nnodtr = iwrk(ii+1) - ii = ii + 2 - call scopy(nvert,rwrk(ir),1,xvert,1) - ir = ir + nvert - call scopy(nvert,rwrk(ir),1,yvert,1) - ir = ir + nvert - call icopy(3*ntri,iwrk(ii),1,vertex,1) - ii = ii + 3*ntri - call icopy(3*ntri,iwrk(ii),1,neigh,1) - ii = ii + 3*ntri - call icopy(ndord3*ntri,iwrk(ii),1,node,1) - ii = ii + ndord3*ntri - call scopy(nnode,rwrk(ir),1,u,1) - ir = ir + nnode - call icopy(8*nvert,iwrk(ii),1,tringl,1) - ii = ii + 8*nvert - call icopy(4*ndord3,iwrk(ii),1,renum,1) - ii = ii + 4*ndord3 - call scopy(3*ndqpt,rwrk(ir),1,quadpt,1) - ir = ir + 3*ndqpt - call scopy(ndqpt,rwrk(ir),1,qptb,1) - ir = ir + ndqpt - call scopy(ndqpt,rwrk(ir),1,qwtb,1) - ir = ir + ndqpt - call scopy(ndord*ndqpt,rwrk(ir),1,qpbasb,1) - ir = ir + ndord*ndqpt - call scopy(ndord*ndqpt,rwrk(ir),1,qpbbdz,1) - ir = ir + ndord*ndqpt - call icopy(nlev,iwrk(ii),1,frstvt,1) - ii = ii + nlev - call icopy(nvert,iwrk(ii),1,nextvt,1) - ii = ii + nvert - call icopy(ndord3,iwrk(ii),1,lnewnd,1) - ii = ii + ndord3 - call icopy(nvert,iwrk(ii),1,vrtlev,1) - ii = ii + nvert - call icopy(nlev,iwrk(ii),1,lvert,1) - ii = ii + nlev - call icopy(nlev,iwrk(ii),1,lbvert,1) - ii = ii + nlev - call icopy(4,iwrk(ii),1,eihead,1) - ii = ii + 4 - call icopy(4,iwrk(ii),1,eitail,1) - ii = ii + 4 - call icopy(ntri,iwrk(ii),1,nxttri,1) - ii = ii + ntri - call icopy(ntri,iwrk(ii),1,pretri,1) - ii = ii + ntri - call icopy(nnode,iwrk(ii),1,nxtblk,1) - ii = ii + nnode - call icopy(ndord3,iwrk(ii),1,lolnd1,1) - ii = ii + ndord3 - call icopy(nvert,iwrk(ii),1,nwndvt,1) - ii = ii + nvert - call icopy(ndord1,iwrk(ii),1,nbasch,1) - ii = ii + ndord1 - call icopy(ndord6,iwrk(ii),1,row,1) - ii = ii + ndord6 - call icopy(ndord6,iwrk(ii),1,col,1) - ii = ii + ndord6 - call icopy(ndord3,iwrk(ii),1,rowrs,1) - ii = ii + ndord3 - call icopy(nlev,iwrk(ii),1,stack,1) - ii = ii + nlev - call icopy(ndord3,iwrk(ii),1,hldnod,1) - ii = ii + ndord3 - call icopy(ndord3,iwrk(ii),1,nodeei,1) - ii = ii + ndord3 - call icopy(ndord3,iwrk(ii),1,lolnd2,1) - ii = ii + ndord3 - call scopy(ntri,rwrk(ir),1,errind,1) - ir = ir + ntri - call scopy(ndqpt,rwrk(ir),1,quadw,1) - ir = ir + ndqpt - call scopy(nnode,rwrk(ir),1,rs,1) - ir = ir + nnode - call scopy(ndord3,rwrk(ir),1,addrs,1) - ir = ir + ndord3 - call scopy(ndord1,rwrk(ir),1,uei,1) - ir = ir + ndord1 - call scopy(ndord3,rwrk(ir),1,ueiold,1) - ir = ir + ndord3 - call scopy(ndord6,rwrk(ir),1,add,1) - ir = ir + ndord6 - call lcopy(nnode,lwrk(il),1,inuse,1) - il = il + nnode - call lcopy(nnode,lwrk(il),1,bndnod,1) - il = il + nnode - call lcopy(ndord1,lwrk(il),1,bndnei,1) - il = il + ndord1 - mxvert = iwrk(ii ) - mxtri = iwrk(ii+ 1) - mxlev = iwrk(ii+ 2) - mxnode = iwrk(ii+ 3) - nnodev = iwrk(ii+ 4) - nnodvb = iwrk(ii+ 5) - nnode0 = iwrk(ii+ 6) - mxidlo = iwrk(ii+ 7) - mxidup = iwrk(ii+ 8) - ntarg = iwrk(ii+ 9) - ierr = iwrk(ii+10) - nqpt = iwrk(ii+11) - ncyc = iwrk(ii+12) - nu1 = iwrk(ii+13) - nu2 = iwrk(ii+14) - outlev = iwrk(ii+15) - nadd = iwrk(ii+16) - naddrs = iwrk(ii+17) - ioutpt = iwrk(ii+18) - nvert0 = iwrk(ii+19) - nqptb = iwrk(ii+20) - ii = ii + 21 - tol = rwrk(ir ) - eimax = rwrk(ir+ 1) - gerest = rwrk(ir+ 2) - rerest = rwrk(ir+ 3) - timei = rwrk(ir+ 4) - timerl = rwrk(ir+ 5) - timert = rwrk(ir+ 6) - timesl = rwrk(ir+ 7) - timest = rwrk(ir+ 8) - timeel = rwrk(ir+ 9) - timeet = rwrk(ir+10) - timetl = rwrk(ir+11) - timett = rwrk(ir+12) - mgfreq = rwrk(ir+13) - mxtime = rwrk(ir+14) - gerr = rwrk(ir+15) - rgerr = rwrk(ir+16) - emax = rwrk(ir+17) - unrm = rwrk(ir+18) - trunrm = rwrk(ir+19) - nuniqx = rwrk(ir+20) - nuniqy = rwrk(ir+21) - nuniqv = rwrk(ir+22) - ir = ir + 23 - unifrm = lwrk(il ) - gquiet = lwrk(il+ 1) - menuon = lwrk(il+ 2) - grafic = lwrk(il+ 3) - grpaws = lwrk(il+ 4) - nuniq = lwrk(il+ 5) - il = il + 6 - call lcopy(100,lwrk(il),1,pltsel,1) - il = il + 100 - call icopy(100,iwrk(ii),1,gunit,1) - ii = ii + 100 - gpfile = iwrk(ii+ 1) - gptri = iwrk(ii+ 2) - gpsol = iwrk(ii+ 3) - gpconv = iwrk(ii+ 4) - gplev = iwrk(ii+ 5) - ii = ii + 5 - call icopy(ndsave,iwrk(ii),1,gpnode,1) - ii = ii + ndsave - gpsolx = iwrk(ii ) - gpsoly = iwrk(ii+1) - ii = ii + 2 - call scopy(ndsave,rwrk(ir),1,gpmxer,1) - ir = ir + ndsave - call scopy(ndsave,rwrk(ir),1,gpener,1) - ir = ir + ndsave - call scopy(ndsave,rwrk(ir),1,gpeest,1) - ir = ir + ndsave - call scopy(ndsave,rwrk(ir),1,gptime,1) - ir = ir + ndsave - call icopy(ndord5*nnode,iwrk(ii),1,idcoef,1) - ii = ii + ndord5*nnode - call icopy(ndord2*nvert,iwrk(ii),1,olndvt,1) - ii = ii + ndord2*nvert - call icopy(ndord3*ndord1,iwrk(ii),1,ibasch,1) - ii = ii + ndord3*ndord1 - call icopy(ndord2*ndord1*ndtri,iwrk(ii),1,idcoei,1) - ii = ii + ndord2*ndord1*ndtri - call scopy(ndord3*ndord1,rwrk(ir),1,cbasch,1) - ir = ir + ndord3*ndord1 - call scopy(ndord3*ndqpt,rwrk(ir),1,qpbas,1) - ir = ir + ndord3*ndqpt - call scopy(ndord1*ntri,rwrk(ir),1,rsei,1) - ir = ir + ndord1*ntri - call scopy(ndord1*ntri,rwrk(ir),1,bcei,1) - ir = ir + ndord1*ntri - call scopy(ndord4*nnode,rwrk(ir),1,coef,1) - ir = ir + ndord4*nnode - call scopy(ndord1*ntri,rwrk(ir),1,rsei2,1) - ir = ir + ndord1*ntri - call scopy(ndord1*ndord1,rwrk(ir),1,block,1) - ir = ir + ndord1*ndord1 - call scopy(3*ndord3*ndqpt,rwrk(ir),1,qpdbdz,1) - ir = ir + 3*ndord3*ndqpt - call scopy((ndord2+1)*ndord1*ntri,rwrk(ir),1,coefei,1) - ir = ir + (ndord2+1)*ndord1*ntri - call scopy(ndord1*ndord1*ntri,rwrk(ir),1,blokei,1) - ir = ir + ndord1*ndord1*ntri - call scopy(ndord1*ndord1*ntri,rwrk(ir),1,bloke2,1) - ir = ir + ndord1*ndord1*ntri - call icopy(ndrow0,iwrk(ii),1,ipvt1,1) - ii = ii + ndrow0 - call icopy(ndrow0,iwrk(ii),1,l1ord,1) - ii = ii + ndrow0 - nband = iwrk(ii) - ii = ii + 1 - call scopy((3*ndband+1)*ndrow0,rwrk(ir),1,coefl1,1) - ir = ir + (3*ndband+1)*ndrow0 - call scopy(ndrow0,rwrk(ir),1,rs1,1) - ir = ir + ndrow0 -c - return - end -c -c --------------- subroutines associated with graphics -c -c -------- filtri -c - subroutine filtri - include 'commons' - external clock -c -c write files for triangulation plots via gnuplot -c - time = clock(0) -c -c triangulation file -c - if (outlev.ge.3) write(ioutpt,601) - open(gpfile,file='gptri.dat') - write(gpfile,604) - if (iorder.eq.2) then - uhere1 = u(vertex(1,1)) - else -c it=1 -c uhere1=solut(xvert(vertex(1,1)),yvert(vertex(1,1)),6,it) - uhere1=u(node(1,1)) - endif - there1=true(xvert(vertex(1,1)),yvert(vertex(1,1))) - umin=u(1) - umax=u(1) - do 5 i=2,nnode - umin=min(umin,u(i)) - umax=max(umax,u(i)) - 5 continue - umin=umin-.25*(umax-umin) - write(gpfile,602) xvert(vertex(1,1)),yvert(vertex(1,1)), - . uhere1,there1,uhere1-there1,umin - do 10 i=1,ntri - if (iorder.eq.2) then - uhere1 = u(vertex(1,i)) - uhere2 = u(vertex(2,i)) - uhere3 = u(vertex(3,i)) - else - uhere1=u(node(1,i)) - uhere2=u(node(iorder,i)) - uhere3=u(node(nnodtr,i)) -c it=i -c uhere1=solut(xvert(vertex(1,i)),yvert(vertex(1,i)),6,it) -c uhere2=solut(xvert(vertex(2,i)),yvert(vertex(2,i)),6,it) -c uhere3=solut(xvert(vertex(3,i)),yvert(vertex(3,i)),6,it) - endif - there1=true(xvert(vertex(1,i)),yvert(vertex(1,i))) - there2=true(xvert(vertex(2,i)),yvert(vertex(2,i))) - there3=true(xvert(vertex(3,i)),yvert(vertex(3,i))) - write(gpfile,602) xvert(vertex(1,i)),yvert(vertex(1,i)), - . uhere1,there1,uhere1-there1,umin - write(gpfile,602) xvert(vertex(2,i)),yvert(vertex(2,i)), - . uhere2,there2,uhere2-there2,umin - write(gpfile,602) xvert(vertex(3,i)),yvert(vertex(3,i)), - . uhere3,there3,uhere3-there3,umin - write(gpfile,602) xvert(vertex(1,i)),yvert(vertex(1,i)), - . uhere1,there1,uhere1-there1,umin - write(gpfile,'()') - 10 continue - close(gpfile) - if (outlev.ge.3) write(ioutpt,603) - 601 format(' write data file with triangulation') - 602 format(6(1pe13.4)) - 603 format(' done writing triangulation file') - 604 format('# This file was created by MGGHAT Version 1.1'/ - . '# It contains information about the triangulation.'/ - . '# Each group of 4 pairs of numbers is the vertices of a'/ - . '# triangle with the first vertex repeated as the 4th line.'/ - . '# The first vertex of the first triangle is included twice'/ - . '# so that the file does not look like grid data to gnuplot.'/ - . '# The third and fourth numbers are the computed and true', - . ' solutions'/ - . '# The fifth number is the error = computed - true.'/ - . '# The sixth number is slightly less than the minimum.') -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time -c - return - end -c -c -------- filsol -c - subroutine filsol - include 'commons' - external clock -c -c write files for surface plots via gnuplot -c - time = clock(0) -c -c solution file -c - if (gpsolx.lt.2) gpsolx=2 - if (gpsoly.lt.2) gpsoly=2 - if (outlev.ge.3) write(ioutpt,611) - open(gpfile,file='gpsol.dat') - write(gpfile,614) gpsolx,gpsoly -c -c find x and y range -c - xmin = xvert(1) - xmax = xvert(1) - ymin = yvert(1) - ymax = yvert(1) - do 20 i=2,nvert - if (xvert(i).lt.xmin) xmin=xvert(i) - if (xvert(i).gt.xmax) xmax=xvert(i) - if (yvert(i).lt.ymin) ymin=yvert(i) - if (yvert(i).gt.ymax) ymax=yvert(i) - 20 continue - hx = (xmax-xmin)/gpsolx - hy = (ymax-ymin)/gpsoly - it = 1 - do 40 j=0,gpsoly - y=ymin+j*hy - do 30 i=0,gpsolx - x=xmin+i*hx - z=solut(x,y,6,it) - zt=true(x,y) - write(gpfile,612) x,y,z,zt,z-zt - 30 continue - write(gpfile,'()') - 40 continue - close(gpfile) - if (outlev.ge.3) write(ioutpt,613) - 611 format(' write data file with solution') - 612 format(5(1pe13.4)) - 613 format(' done writing solution file') - 614 format('# This file was created by MGGHAT Version 1.1'/ - . '# It contains the computed and true solutions on a'/ - . '# ',i4,' X ',i4,' grid. Columns are:'/ - . '# x y computed true error') -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time -c - return - end -c -c -------- filcon -c - subroutine filcon - include 'commons' - external clock -c -c write file for convergence plot via gnuplot -c - time = clock(0) -c - if (outlev.ge.3) write(ioutpt,621) - open(gpfile,file='gpconv.dat') - write(gpfile,623) - if (gplev.eq.2) then - write(gpfile,622) gpnode(1),.001,gpmxer(1), - 1 gpener(1),gpeest(1) - write(gpfile,622) 2*gpnode(1),.01,gpmxer(1)/2., - 1 gpener(1)/2.,gpeest(1)/2. - else - if (gptime(1).eq.0.) gptime(1) = gptime(2)/2. - do 50 i=1,gplev-1 - write(gpfile,622) gpnode(i),gptime(i),gpmxer(i), - 1 gpener(i),gpeest(i) - 50 continue - endif - close(gpfile) - 621 format(' write data file with convergence info') - 622 format(i10,4(1pe15.8)) - 623 format('# This file was created by MGGHAT Version 1.1'/ - . '# It contains information about convergence of the error.'/ - . '# The columns are:'/ - . '# nodes time max error energy error error estimate') - 624 format(' done writing convergence file') -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time -c - return - end -c -c -------- grftri -c - subroutine grftri - include 'commons' - integer gpopen - external clock -c -c update triangulation plots -c - time = clock(0) -c - do 10 iplot=41,41 -c -c if gunit(iplot) .eq. -1, this is a new plot to be initialized -c otherwise, just replot -c - if (pltsel(iplot)) then - if (gunit(iplot).eq.-1) then - gunit(iplot)=gpopen() - call initgp(iplot,gunit(iplot)) - else - call gnuplt(gunit(iplot),'replot') - endif - endif - 10 continue -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time - return - end -c -c -------- grfsol -c - subroutine grfsol - include 'commons' - integer gpopen - external clock -c -c update solution plots -c - time = clock(0) -c - do 10 iplot=1,39 - if (pltsel(iplot)) then - if (gunit(iplot).eq.-1) then - gunit(iplot)=gpopen() - call initgp(iplot,gunit(iplot)) - else - call gnuplt(gunit(iplot),'replot') - endif - endif - 10 continue -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time - return - end -c -c -------- grfcon -c - subroutine grfcon - include 'commons' - integer gpopen - external clock -c -c update convergence plots -c - time = clock(0) -c - do 10 iplot=51,99 - if (pltsel(iplot)) then - if (gunit(iplot).eq.-1) then - gunit(iplot)=gpopen() - call initgp(iplot,gunit(iplot)) - else - call gnuplt(gunit(iplot),'replot') - endif - endif - 10 continue -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time - return - end -c -c -------- mn2mg -c - subroutine mn2mg - include 'commons' - logical there,wait,newiso - character*80 s - integer gpopen - external clock -c -c check for message from menu to mgghat, and process -c - time = clock(0) -c -c if the message file does not exist, return -c - if (outlev.ge.3) write(ioutpt,201) - inquire(file=tmpdir//'men2mgg',exist=there) - if (.not. there) then - if (outlev.ge.3) write(ioutpt,202) - return - endif -c -c wait for the lock file to go away -c - 2 inquire(file='lmen2mgg',exist=wait) - if (wait) go to 2 -c -c set a lock file -c - 3 open(gpfile,file='lmgg2men') - write(gpfile,100) - 100 format(' ') - close(gpfile) -c -c if the file lmen2mgg has reappeared, destroy lmgg2men and wait for -c lmen2mgg to disappear again -c - inquire(file='lmen2mgg',exist=wait) - if (wait) then - call system('rm lmgg2men') - go to 2 - endif -c -c read in messages from the menu, and set graphics selection flags, and -c take requested actions -c - newiso = .false. - open(gpfile,file=tmpdir//'men2mgg') - 4 read(gpfile,*,end=5) i1,i2 -c -c if i1 == 2, the gnuplot command is on the next line -c - if (i1.eq.2) then - read(gpfile,'(a80)',end=5) s - if (i2.gt.0 .and. i2.le.100) then - if (gunit(i2).ne.-1) then - call gnuplt(gunit(i2),s) - endif - endif -c -c if i1 == 3, the menu was quit -c - elseif (i1.eq.3) then - menuon = .false. -c -c if i1 == 4, it's a change in number of isolines -c - elseif (i1.eq.4) then - gpsolx = i2 - read(gpfile,*) i2 - gpsoly = i2 - newiso = .true. - else - if (i2.gt.0 .and. i2.le.100) then -c -c if i1 == 0, it's a request to close the plot -c - if (i1.eq.0) then - pltsel(i2)=.false. - if (gunit(i2).ne.-1) then - call gpclos(gunit(i2)) - gunit(i2) = -1 - endif -c -c if i1 == 1, it's a request to open the plot -c - elseif (i1.eq.1) then - pltsel(i2)=.true. - if (gunit(i2).eq.-1) then - gunit(i2) = gpopen() - call initgp(i2,gunit(i2)) - endif - endif - endif - endif - go to 4 -c -c remove message file and lock file -c - 5 close(gpfile) - call system('rm '//tmpdir//'men2mgg') - call system('rm lmgg2men') -c -c if new isolines were defined, replot surface plots -c - if (newiso) then - call filsol - if (gunit( 1).ne.-1) call gnuplt(gunit( 1),'replot') - if (gunit( 4).ne.-1) call gnuplt(gunit( 4),'replot') - if (gunit(11).ne.-1) call gnuplt(gunit(11),'replot') - if (gunit(14).ne.-1) call gnuplt(gunit(14),'replot') - if (gunit(21).ne.-1) call gnuplt(gunit(21),'replot') - if (gunit(24).ne.-1) call gnuplt(gunit(24),'replot') - if (gunit(31).ne.-1) call gnuplt(gunit(31),'replot') - if (gunit(34).ne.-1) call gnuplt(gunit(34),'replot') - endif -c - if (outlev.ge.3) write(ioutpt,203) -c - 201 format(' check for message from menu') - 202 format(' no message found') - 203 format(' message received') -c -c adjust timer -c - time = clock(0) - time - timetl = timetl + time - timett = timett + time - return - end -c -c -------- initgp -c - subroutine initgp(ip,iu) - include 'commons' -c -c initialize a gnuplot -c ip is the kind of plot to start -c iu is the fortran i/o unit -c -c computed solution, surface -c - if (ip.eq.1) then - call gnuplt(iu,'set title ''Computed Solution; Surface''') - call gnuplt(iu,'set hidden') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set noxtics') - call gnuplt(iu,'set noytics') - call gnuplt(iu,'splot ''gpsol.dat'' using 3 with lines') -c -c computed solution, contour -c - elseif (ip.eq.2) then - call gnuplt(iu,'set title ''Computed Solution; Contour''') - call gnuplt(iu,'set contour') - call gnuplt(iu,'set cntrparam levels 20') - call gnuplt(iu,'set nosurface') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set view 0,0') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:3 with lines') -c -c computed solution, facets -c - elseif (ip.eq.3) then - call gnuplt(iu,'set title ''Computed Solution; Facets''') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:3 with lines') -c -c computed solution, surface with triangulation -c - elseif (ip.eq.4) then - call gnuplt(iu,'set title ''Computed Solution;'// - . ' Surface & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:3, '// - . '''gptri.dat'' using 1:2:6') -c -c computed solution, facets with triangulation -c - elseif (ip.eq.6) then - call gnuplt(iu,'set title ''Computed Solution;'// - . ' Facets & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:3, '// - . '''gptri.dat'' using 1:2:6') -c -c true solution, surface -c - elseif (ip.eq.11) then - call gnuplt(iu,'set title ''True Solution; Surface''') - call gnuplt(iu,'set hidden') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set noxtics') - call gnuplt(iu,'set noytics') - call gnuplt(iu,'splot ''gpsol.dat'' using 4 with lines') -c -c true solution, contour -c - elseif (ip.eq.12) then - call gnuplt(iu,'set title ''True Solution; Contour''') - call gnuplt(iu,'set contour') - call gnuplt(iu,'set cntrparam levels 20') - call gnuplt(iu,'set nosurface') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set view 0,0') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:4 with lines') -c -c true solution, facets -c - elseif (ip.eq.13) then - call gnuplt(iu,'set title ''True Solution; Facets''') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:4 with lines') -c -c true solution, surface with triangulation -c - elseif (ip.eq.14) then - call gnuplt(iu,'set title ''True Solution;'// - . ' Surface & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:4, '// - . '''gptri.dat'' using 1:2:6') -c -c true solution, facets with triangulation -c - elseif (ip.eq.16) then - call gnuplt(iu,'set title ''True Solution;'// - . ' Facets & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:4, '// - . '''gptri.dat'' using 1:2:6') -c -c computed and true solutions, surface -c - elseif (ip.eq.21) then - call gnuplt(iu,'set title ''Computed and True Solutions;'// - . ' Surface''') - call gnuplt(iu,'set hidden') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set noxtics') - call gnuplt(iu,'set noytics') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 3, '// - . '''gpsol.dat'' using 4') -c -c computed and true solutions, contour -c - elseif (ip.eq.22) then - call gnuplt(iu,'set title ''Computed and True Solutions;'// - . ' Contour''') - call gnuplt(iu,'set contour') - call gnuplt(iu,'set cntrparam levels 20') - call gnuplt(iu,'set nosurface') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set view 0,0') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:3, '// - . '''gpsol.dat'' using 1:2:4') -c -c computed and true solutions, facets -c - elseif (ip.eq.23) then - call gnuplt(iu,'set title ''Computed and True Solutions;'// - . ' Facets''') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:3, '// - . '''gptri.dat'' using 1:2:4') -c -c computed and true solutions, surface with triangulation -c - elseif (ip.eq.24) then - call gnuplt(iu,'set title ''Computed and True Solutions;'// - . ' Surface & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:3, '// - . '''gpsol.dat'' using 1:2:4, '// - . '''gptri.dat'' using 1:2:6') -c -c computed and true solutions, facets with triangulation -c - elseif (ip.eq.26) then - call gnuplt(iu,'set title ''Computed and True Solutions;'// - . ' Facets & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:3, '// - . '''gptri.dat'' using 1:2:4, '// - . '''gptri.dat'' using 1:2:6') -c -c error, surface -c - elseif (ip.eq.31) then - call gnuplt(iu,'set title ''Error; Surface''') - call gnuplt(iu,'set hidden') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set noxtics') - call gnuplt(iu,'set noytics') - call gnuplt(iu,'splot ''gpsol.dat'' using 5 with lines') -c -c error, contour -c - elseif (ip.eq.32) then - call gnuplt(iu,'set title ''Error; Contour''') - call gnuplt(iu,'set contour') - call gnuplt(iu,'set cntrparam levels 20') - call gnuplt(iu,'set nosurface') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set view 0,0') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:5 with lines') -c -c error, facets -c - elseif (ip.eq.33) then - call gnuplt(iu,'set title ''Error; Facets''') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:5 with lines') -c -c error, surface with triangulation -c - elseif (ip.eq.34) then - call gnuplt(iu,'set title ''Error; Surface & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gpsol.dat'' using 1:2:5, '// - . '''gptri.dat'' using 1:2:6') -c -c error, facets with triangulation -c - elseif (ip.eq.36) then - call gnuplt(iu,'set title ''Error; Facets & Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set parametric') - call gnuplt(iu,'set ticslevel 0') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'splot ''gptri.dat'' using 1:2:5, '// - . '''gptri.dat'' using 1:2:6') -c -c triangulation -c - else if (ip.eq.41) then - call gnuplt(iu,'set title ''Triangulation''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set noborder') - call gnuplt(iu,'set noxtics') - call gnuplt(iu,'set noytics') - call gnuplt(iu,'plot ''gptri.dat'' with lines') -c -c convergence, nodes vs. energy error -c - elseif (ip.eq.51) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Number of Nodes''') - call gnuplt(iu,'set ylabel ''Relative Energy Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 1:4') -c -c convergence, nodes vs. max error -c - elseif (ip.eq.52) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Number of Nodes''') - call gnuplt(iu,'set ylabel ''Maximum Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 1:3') -c -c convergence, nodes vs. energy error estimate -c - elseif (ip.eq.53) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Number of Nodes''') - call gnuplt(iu, - . 'set ylabel ''Relative Energy Error Estimate''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 1:5') -c -c convergence, nodes vs. energy error and estimate -c - elseif (ip.eq.54) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set xlabel ''Number of Nodes''') - call gnuplt(iu,'set ylabel ''Relative Energy Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu, - . 'plot ''gpconv.dat'' using 1:4 title ''error'', - . ''gpconv.dat'' using 1:5 title ''estimate''') -c -c convergence, time vs. energy error -c - elseif (ip.eq.61) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Time (seconds)''') - call gnuplt(iu,'set ylabel ''Relative Energy Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 2:4') -c -c convergence, time vs. max error -c - elseif (ip.eq.62) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Time (seconds)''') - call gnuplt(iu,'set ylabel ''Maximum Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 2:3') -c -c convergence, time vs. energy error estimate -c - elseif (ip.eq.63) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set nokey') - call gnuplt(iu,'set xlabel ''Time (seconds)''') - call gnuplt(iu, - . 'set ylabel ''Relative Energy Error Estimate''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu,'plot ''gpconv.dat'' using 2:5') -c -c convergence, time vs. energy error and estimate -c - elseif (ip.eq.64) then - call gnuplt(iu,'set logscale xy') - call gnuplt(iu,'set title ''Convergence Graph''') - call gnuplt(iu,'set xlabel ''Time (seconds)''') - call gnuplt(iu,'set ylabel ''Relative Energy Error''') - call gnuplt(iu,'set data style lines') - call gnuplt(iu, - . 'plot ''gpconv.dat'' using 2:4 title ''error'', - . ''gpconv.dat'' using 2:5 title ''estimate''') - else - print *,'don''t know how to make plot type ',ip - call gpclos(iu) - pltsel(ip)=.false. - iu=-1 - endif -c -c give the user a chance to size and position the window, if -c graphics-pause (grpaws) is true -c - if (pltsel(ip) .and. grpaws) then - print * - print *,'Resize and position the new window, and press return' - print * - read * - endif -c - return - end //GO.SYSIN DD src/mgghat.f echo src/makefile 1>&2 sed >src/makefile <<'//GO.SYSIN DD src/makefile' 's/^-//' -SHELL = /bin/sh -# LINPACK and DLINPACK need to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me -DLINPACK = dfix.me - -FFLAGS = -O3 -CFLAGS = -O -F77 = f77 -CC = gcc -DOUBLE = -r8 - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: $(DLINPACK) commons makefile mgghat8.o user8.o second8.o \ - gnuplt.o - $(F77) $(FFLAGS) $(DOUBLE) -o mgghat \ - mgghat8.o user8.o second8.o gnuplt.o \ - $(DLINPACK) - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.f - $(F77) $(FFLAGS) -c second.f - -mgghat8.o: commons makefile mgghat.f - $(F77) $(FFLAGS) $(DOUBLE) -c mgghat.f -o mgghat8.o - -user8.o: commons makefile user.f - $(F77) $(FFLAGS) $(DOUBLE) -c user.f -o user8.o - -second8.o: commons makefile second.f - $(F77) $(FFLAGS) $(DOUBLE) -c second.f -o second8.o - -gnuplt.o: commons makefile gnuplt.c - $(CC) $(CFLAGS) -c gnuplt.c - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi - -$(DLINPACK): makefile r1mach8.f - @if [ "$@" = "dfix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c r1mach8.f ; \ - else if [ "$@" = "linpack8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c linpack.f -o linpack8.o; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile echo src/user.f 1>&2 sed >src/user.f <<'//GO.SYSIN DD src/user.f' 's/^-//' -c This is an example 'main' program for calling MGGHAT -c - program main -c -c In 'commons', parameter statements are used to set the dimension for -c the arrays. Also, all of the program parameters are passed through it. -c - include 'commons' -c -c solve the problem -c - call mgghat - stop - end -c -c -------- pde -c - subroutine pde(x,y,p,q,r,f) - real x,y,p,q,r,f -c -c return the values of the pde coefficents at (x,y) -c pde is -c -c -( p(x,y) * u ) -( q(x,y) * u ) + r(x,y) * u = f(x,y) -c x x y y -c -c NOTE: BE CAREFUL TO GET THE SIGNS RIGHT -c e.g. p=q=1. means f=-(uxx+uyy) -c - ipower=5 - p=1. - q=1. - r = 0. - f=-ipower*(ipower-1.)*(x**(ipower-2)+y**(ipower-2)) -c - return - end -c -c -------- bcond -c - subroutine bcond(x,y,ipiece,c,g,itype) - real x,y,c,g - integer ipiece,itype -c -c returns boundary condition coefficients at (x,y) -c -c boundary condition is either -c -c u + c(x,y)*u = g(x,y) or u = g(x,y) -c n -c -c (the natural b.c. is the Neumann b.c. because p=q=1) -c -c ipiece indicates the boundary piece from which the boundary condition -c is determined. itype must be set to the type of boundary condition for -c that piece (the type cannot change within a piece). -c itype = 1 Dirichlet (second condition above) -c 2 Neuman (first condition with c = 0) -c 3 Mixed (first condition with c != 0) -c -c (these pieces assume the assignment in the example inittr for -c a rectangular domain) -c - if (ipiece.eq.1) then -c left side; Dirichlet b.c.; U=g - itype = 1 - c = 0. - g = true(x,y) - elseif (ipiece.eq.2) then -c bottom; Mixed b.c.; Un + U = g - itype = 3 - c = 1. - g = true(x,y) - truey(x,y) - elseif (ipiece.eq.3) then -c right side; Neuman; Un = g - itype = 2 - c = 0. - g = truex(x,y) - else -c top; dirichlet b.c.; U=g - itype = 1 - c = 0. - g = true(x,y) - endif -c - return - end -c -c -------- true -c - real function true(x,y) - real x,y - ipower=5 - true = x**ipower + y**ipower - return - end -c -c -------- truex -c - real function truex(x,y) - real x,y - ipower = 5 - truex = ipower*x**(ipower-1) - return - end -c -c -------- truey -c - real function truey(x,y) - real x,y - ipower = 5 - truey = ipower*y**(ipower-1) - return - end -c -c -------- inittr -c - subroutine inittr - include 'commons' -c -c rectangular domain (ax,bx) X (ay,by) with an ngridx X ngridy grid -c - ax = 0. - bx = 1. - ay = 0. - by = 1. - ngridx = 2 - ngridy = 2 -c - if (outlev.ge.3) write(ioutpt,101) ax,bx,ay,by - 101 format(' begin initializing triangulation'/ - . ' triangulation for rectangle (',f8.2, - . ',',f8.2,') X (',f8.2,',',f8.2,')') -c -c set initial triangulation -c -c this is a user provided routine to define the domain and -c the initial triangulation -c -c the user provides: -c -c nvert - number of vertices -c ntri - number of triangles -c xvert(1..nvert),yvert(1..nvert) - x and y coordinates -c of the vertices -c vertex(1..3,1..ntri) - the 3 vertices of each triangle -c neigh(i,1..ntri) - which piece of the boundary contains the triangle -c side opposite vertex i. Need not be set if -c that side is not on the domain boundary. -c -c the peak of each triangle is the third vertex, i.e., -c peak(triangle)=vertex(3,triangle) -c -c assumptions on the triangulation are: -c -c 1) each vertex is in the same position (first, second, or third) -c in every triangle that contains it, e.g., if vertex 2 is -c the first vertex of triangle 3 (vertex(1,3)=2). vertex 2 must -c also be the first vertex of any other triangle containing it. -c thus we can have vertex(1,4)=2, and cannot have vertex(2,4)=2 -c -c 2) vertices which are first or second vertices can be in at most -c 8 triangles. vertices which are third vertices (peaks) can -c be in at most 4 triangles -c -c This version of the routine triangulates the rectangle (ax,bx)X(ay,by). -c ngridx and ngridy specify the number of intervals in each dimension. -c The boundary pieces (ipiece for subroutine bcond) are: -c 1 - left -c 2 - bottom -c 3 - right -c 4 - top -c -c for the case of a 4X4 grid, the vertex and triangle numbers are: -c -c 5---10---15---20---25 -c |\ | /|\ | /| -c | \ 8|15/ | \24|31/ | -c | 7\ | /16|23\ | /32| -c | \|/ | \|/ | -c 4----9---14---19---24 -c | /|\ | /|\ | -c | 5/ | \14|21/ | \30| -c | /6 |13\ | /22|29\ | -c |/ | \|/ | \| -c 3----8---13---18---23 -c |\ | /|\ | /| -c | \4 |11/ | \20|27/ | -c | 3\ | /12|19\ | /28| -c | \|/ | \|/ | -c 2----7---12---17---22 -c | /|\ | /|\ | -c | 1/ | \10|17/ | \26| -c | /2 | 9\ | /18|25\ | -c |/ | \|/ | \| -c 1----6---11---16---21 -c - dy = by-ay - dx = bx-ax - dy = dy/ngridy - dx = dx/ngridx -c -c set number of triangles and vertices -c - nvert = (ngridx+1)*(ngridy+1) - ntri = 2*ngridx*ngridy -c -c set coordinates of vertices -c - k=0 - do 11 i=1,ngridx+1 - xtemp=ax+(i-1)*dx - if (i.eq.ngridx+1) xtemp=bx - do 10 j=1,ngridy+1 - k=k+1 - xvert(k)=xtemp - yvert(k)=ay+(j-1)*dy - if (j.eq.ngridy+1) yvert(k)=by - 10 continue - 11 continue -c -c set vertices and boundary pieces of triangles -c - do 21 i=1,ngridx,2 - do 20 j=1,ngridy,2 - ivbase=(i-1)*(ngridy+1)+j - itbase=2*((i-1)*ngridy+j)-1 - vertex(1,itbase) = ivbase+ngridy+2 - vertex(2,itbase) = ivbase - vertex(3,itbase) = ivbase+1 - if (i.eq.1) neigh(1,itbase) = -1 - if (j.eq.ngridy) neigh(2,itbase) = -4 - vertex(1,itbase+1) = ivbase+ngridy+2 - vertex(2,itbase+1) = ivbase - vertex(3,itbase+1) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+1) = -2 - if (i.eq.ngridx) neigh(2,itbase+1) = -3 - if (j.ne.ngridy) then - vertex(1,itbase+2) = ivbase+ngridy+2 - vertex(2,itbase+2) = ivbase+2 - vertex(3,itbase+2) = ivbase+1 - if (i.eq.1) neigh(1,itbase+2) = -1 - vertex(1,itbase+3) = ivbase+ngridy+2 - vertex(2,itbase+3) = ivbase+2 - vertex(3,itbase+3) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+3) = -4 - if (i.eq.ngridx) neigh(2,itbase+3) = -3 - endif - if (i.ne.ngridx) then - vertex(1,itbase+2*ngridy) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+2*ngridy) = -2 - vertex(1,itbase+2*ngridy+1) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+1) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy+1) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+1) = -3 - if (j.eq.ngridy) neigh(2,itbase+2*ngridy+1) = -4 - if (j.ne.ngridy) then - vertex(1,itbase+2*ngridy+2) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+2) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+2) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+2*ngridy+2) = -4 - vertex(1,itbase+2*ngridy+3) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+3) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+3) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+3) = -3 - endif - endif - 20 continue - 21 continue -c - if (outlev.ge.3) then - write(ioutpt,102) ngridx,ngridy,ntri,nvert - 102 format(' grid lines ',i3,' X',i3/ - 1 ' triangles ',i5/ - 2 ' vertices ',i5/ - 3 ' initial triangulation complete') - endif - return - end //GO.SYSIN DD src/user.f echo src/commons 1>&2 sed >src/commons <<'//GO.SYSIN DD src/commons' 's/^-//' -c -c parameters that can be set by the user -c -c set the following 6 parameters for dimensioning: -c ndvert = maximum number of vertices in the grid -c ndlev = maximum number of refinement levels -c ndord = maximum polynomial order to be used -c ndsave = maximum number of data points saved for convergence plots -c ndrow0 = maximum number of rows in the initial grid matrix, i.e., -c maximum number of nodes in the inital grid -c ndband = maximum bandwidth of the initial grid matrix -c -c tmpdir = a directory in which to write files with messages between -c mgghat and grmenu (the widget-based menu for graphics). -c Also make sure it is declared with enough characters. -c - character*5 tmpdir - parameter (ndvert=1000,ndlev=40,ndord=4,ndsave=100, - 1 ndrow0=100,ndband=48,tmpdir='/tmp/', - 1 ndtri=2*ndvert,ndnode=ndvert*(ndord-1)**2, - 2 ndqpt=6,ndord1=(ndord-1)**2,ndord2=ndord**2, - 3 ndord3=(ndord*(ndord+1))/2, - 4 ndord4=2*ndord*(ndord-1)+1, - 5 ndord5=6*ndord*(ndord-1), - 6 ndord6=(ndord**4+2*ndord**3+3*ndord**2+2*ndord)/8, - . ndrwrk=6*ndqpt+2*ndord*ndqpt+2*ndvert+ndtri+2*ndnode - . +2*ndord3+ndord1+ndord6+20+4*ndsave+ndord3*ndord1 - . +4*ndord3*ndqpt+4*ndord1*ndtri+ndord4*ndnode - . +ndord1*ndord1+ndord1*ndtri*ndord2 - . +2*ndord1*ndord1*ndtri+3*ndrow0*ndband+2*ndrow0, - . ndiwrk=56+(8+ndord3)*ndtri+(11+ndord2)*ndvert+10*ndord3 - . +(1+ndord5)*ndnode+(1+ndord3+ndtri*ndord2)*ndord1 - . +4*ndlev+2*ndord6+ndsave+2*ndrow0, - . ndlwrk=1+2*ndnode+ndord1) -c -c global variables -c - common / cinteg / mxvert,mxtri ,mxlev ,mxnode,nvert , - 1 ntri ,nlev ,nnode ,nnodtr,nnodev, - 2 nnodvb,nnode0,mxidlo,mxidup,ntarg , - 3 ierr ,nqpt ,iorder,ncyc ,nu1 , - 4 nu2 ,outlev,nadd ,naddrs,ioutpt, - 5 nvert0,nqptb - common / creal / tol ,eimax ,gerest,rerest,timei , - 1 timerl,timert,timesl,timest,timeel, - 2 timeet,timetl,timett,mgfreq,mxtime, - 3 gerr ,rgerr ,emax ,unrm ,trunrm, - 4 nuniqx,nuniqy,nuniqv - common / clogic / unifrm,gquiet,menuon,grafic,grpaws, - 1 nuniq - common / cpltse / pltsel - common / cfrstv / frstvt - common / cnextv / nextvt - common / cvrtle / vrtlev - common / clvert / lvert - common / clbver / lbvert - common / ceihea / eihead - common / ceitai / eitail - common / cnxttr / nxttri - common / cpretr / pretri - common / cnxtbl / nxtblk - common / cnwndv / nwndvt - common / cnbasc / nbasch - common / crow / row - common / ccol / col - common / crowrs / rowrs - common / cadd / add - common / caddrs / addrs - common / cxvert / xvert - common / cyvert / yvert - common / crs / rs - common / cu / u - common / cerrin / errind - common / cstack / stack - common / cquadw / quadw - common / cinuse / inuse - common / cbndno / bndnod - common / cneigh / neigh - common / cverte / vertex - common / ctring / tringl - common / cquadp / quadpt - common / chldno / hldnod - common / cbndne / bndnei - common / cnodee / nodeei - common / crenum / renum - common / cuei / uei - common / cueiol / ueiold - common / cloln1 / lolnd1 - common / cloln2 / lolnd2 - common / clnewn / lnewnd - common / cigplt /gpfile,gptri ,gpsol ,gpconv,gplev ,gpnode, - . gpsolx,gpsoly - common / crgplt /gpmxer,gpener,gpeest,gptime - common / cgunit / gunit - common / cidcoe / idcoef - common / cnode / node - common / colndv / olndvt - common / cibasc / ibasch - common / ccoef / coef - common / cblock / block - common / ccbasc / cbasch - common / cqpbas / qpbas - common / cqpdbd / qpdbdz - common / ccoefe / coefei - common / cidcoi / idcoei - common / cbloke / blokei - common / cblok2 / bloke2 - common / crsei / rsei - common / crsei2 / rsei2 - common / cbcei / bcei - common / cqptb / qptb - common / cqwtb / qwtb - common / cqbasb / qpbasb - common / cqbbdz / qpbbdz - common / cipvt1 / ipvt1 - common / cl1ord / l1ord - common / ccoef1 / coefl1 - common / crs1 / rs1 - common / cnband / nband -c -c declarations for global variables -c - integer neigh(3,ndtri ),vertex(3,ndtri ),tringl(8,ndvert), - 1 renum(4,ndord3) - real quadpt(3,ndqpt ),qptb(ndqpt),qwtb(ndqpt), - 1 qpbasb(ndord,ndqpt),qpbbdz(ndord,ndqpt) - integer frstvt(ndlev ),nextvt(ndvert),lnewnd(ndord3), - 1 vrtlev(ndvert), lvert(ndlev ),lbvert(ndlev ), - 2 eihead(4 ),eitail(4 ),nxttri(ndtri ), - 3 pretri(ndtri ),nxtblk(ndnode),lolnd1(ndord3), - 4 nwndvt(ndvert),nbasch(ndord1), row(ndord6), - 5 col(ndord6), rowrs(ndord3), stack(ndlev ), - 6 hldnod(ndord3),nodeei(ndord3),lolnd2(ndord3) - real xvert(ndvert), yvert(ndvert),errind(ndtri ), - 2 quadw(ndqpt ) - real rs(ndnode), u(ndnode), addrs(ndord3), - 1 uei(ndord1),ueiold(ndord3), add(ndord6) - logical inuse(ndnode),bndnod(ndnode), - 1 bndnei(ndord1) - integer mxvert, mxtri, mxlev,mxnode, nvert, ntri, nlev, - 1 nnode,nnodtr,nnodev,nnodvb,nnode0,mxidlo,mxidup, - 2 ntarg, ierr, nqpt,iorder, ncyc, nu1, nu2, - 3 outlev, nadd,naddrs,ioutpt,nvert0, nqptb - real tol, eimax,gerest,rerest, timei,timerl,timert, - 1 timesl,timest,timeel,timeet,timetl,timett,mgfreq, - 2 mxtime,gerr ,rgerr ,emax ,unrm ,trunrm,nuniqx, - 3 nuniqy,nuniqv - logical unifrm,gquiet,menuon,grafic,grpaws,nuniq - logical pltsel(100) - integer gunit(100) - integer gpfile,gptri, gpsol,gpconv, gplev,gpnode(ndsave), - 1 gpsolx,gpsoly - real gpmxer(ndsave),gpener(ndsave),gpeest(ndsave), - 1 gptime(ndsave) - integer idcoef(ndord5,ndnode), node(ndord3,ndtri ), - 1 olndvt(ndord2,ndvert),ibasch(ndord3,ndord1), - 2 idcoei(ndord2,ndord1,ndtri) - real cbasch(ndord3,ndord1), - 1 qpbas(ndord3,ndqpt ) - real rsei(ndord1,ndtri ), bcei(ndord1,ndtri ), - 1 coef(ndord4,ndnode), rsei2(ndord1,ndtri ), - 2 block(ndord1,ndord1) - real qpdbdz(3,ndord3,ndqpt) - real coefei(ndord2+1,ndord1,ndtri),blokei(ndord1,ndord1,ndtri), - 1 bloke2(ndord1,ndord1,ndtri) - integer ipvt1(ndrow0),l1ord(ndrow0),nband - real coefl1(3*ndband+1,ndrow0),rs1(ndrow0) //GO.SYSIN DD src/commons echo src/second.f 1>&2 sed >src/second.f <<'//GO.SYSIN DD src/second.f' 's/^-//' - FUNCTION SECOND () -C -C ------------------------------------------------ -C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) -C ------------------------------------------------ -C - REAL*4 TARRAY(2) - REAL*4 ETIME - TOTAL = ETIME(TARRAY) - SECOND = TARRAY(1) - RETURN - END //GO.SYSIN DD src/second.f echo src/user.f.poisson 1>&2 sed >src/user.f.poisson <<'//GO.SYSIN DD src/user.f.poisson' 's/^-//' -c This is an example 'main' program for calling MGGHAT -c - program main -c -c In 'commons', parameter statements are used to set the dimension for -c the arrays. Also, all of the program parameters are passed through it. -c - include 'commons' -c -c solve the problem -c - call mgghat - stop - end -c -c -------- pde -c - subroutine pde(x,y,p,q,r,f) - real x,y,p,q,r,f -c -c return the values of the pde coefficents at (x,y) -c pde is -c -c -( p(x,y) * u ) -( q(x,y) * u ) + r(x,y) * u = f(x,y) -c x x y y -c -c NOTE: BE CAREFUL TO GET THE SIGNS RIGHT -c e.g. p=q=1. means f=-(uxx+uyy) -c - ipower=5 - p=1. - q=1. - r = 0. - f=-ipower*(ipower-1.)*(x**(ipower-2)+y**(ipower-2)) -c - return - end -c -c -------- bcond -c - subroutine bcond(x,y,ipiece,c,g,itype) - real x,y,c,g - integer ipiece,itype -c -c returns boundary condition coefficients at (x,y) -c -c boundary condition is either -c -c u + c(x,y)*u = g(x,y) or u = g(x,y) -c n -c -c (the natural b.c. is the Neumann b.c. because p=q=1) -c -c ipiece indicates the boundary piece from which the boundary condition -c is determined. itype must be set to the type of boundary condition for -c that piece (the type cannot change within a piece). -c itype = 1 Dirichlet (second condition above) -c 2 Neuman (first condition with c = 0) -c 3 Mixed (first condition with c != 0) -c -c (these pieces assume the assignment in the example inittr for -c a rectangular domain) -c - if (ipiece.eq.1) then -c left side; Dirichlet b.c.; U=g - itype = 1 - c = 0. - g = true(x,y) - elseif (ipiece.eq.2) then -c bottom; Mixed b.c.; Un + U = g - itype = 3 - c = 1. - g = true(x,y) - truey(x,y) - elseif (ipiece.eq.3) then -c right side; Neuman; Un = g - itype = 2 - c = 0. - g = truex(x,y) - else -c top; dirichlet b.c.; U=g - itype = 1 - c = 0. - g = true(x,y) - endif -c - return - end -c -c -------- true -c - real function true(x,y) - real x,y - ipower=5 - true = x**ipower + y**ipower - return - end -c -c -------- truex -c - real function truex(x,y) - real x,y - ipower = 5 - truex = ipower*x**(ipower-1) - return - end -c -c -------- truey -c - real function truey(x,y) - real x,y - ipower = 5 - truey = ipower*y**(ipower-1) - return - end -c -c -------- inittr -c - subroutine inittr - include 'commons' -c -c rectangular domain (ax,bx) X (ay,by) with an ngridx X ngridy grid -c - ax = 0. - bx = 1. - ay = 0. - by = 1. - ngridx = 2 - ngridy = 2 -c - if (outlev.ge.3) write(ioutpt,101) ax,bx,ay,by - 101 format(' begin initializing triangulation'/ - . ' triangulation for rectangle (',f8.2, - . ',',f8.2,') X (',f8.2,',',f8.2,')') -c -c set initial triangulation -c -c this is a user provided routine to define the domain and -c the initial triangulation -c -c the user provides: -c -c nvert - number of vertices -c ntri - number of triangles -c xvert(1..nvert),yvert(1..nvert) - x and y coordinates -c of the vertices -c vertex(1..3,1..ntri) - the 3 vertices of each triangle -c neigh(i,1..ntri) - which piece of the boundary contains the triangle -c side opposite vertex i. Need not be set if -c that side is not on the domain boundary. -c -c the peak of each triangle is the third vertex, i.e., -c peak(triangle)=vertex(3,triangle) -c -c assumptions on the triangulation are: -c -c 1) each vertex is in the same position (first, second, or third) -c in every triangle that contains it, e.g., if vertex 2 is -c the first vertex of triangle 3 (vertex(1,3)=2). vertex 2 must -c also be the first vertex of any other triangle containing it. -c thus we can have vertex(1,4)=2, and cannot have vertex(2,4)=2 -c -c 2) vertices which are first or second vertices can be in at most -c 8 triangles. vertices which are third vertices (peaks) can -c be in at most 4 triangles -c -c This version of the routine triangulates the rectangle (ax,bx)X(ay,by). -c ngridx and ngridy specify the number of intervals in each dimension. -c The boundary pieces (ipiece for subroutine bcond) are: -c 1 - left -c 2 - bottom -c 3 - right -c 4 - top -c -c for the case of a 4X4 grid, the vertex and triangle numbers are: -c -c 5---10---15---20---25 -c |\ | /|\ | /| -c | \ 8|15/ | \24|31/ | -c | 7\ | /16|23\ | /32| -c | \|/ | \|/ | -c 4----9---14---19---24 -c | /|\ | /|\ | -c | 5/ | \14|21/ | \30| -c | /6 |13\ | /22|29\ | -c |/ | \|/ | \| -c 3----8---13---18---23 -c |\ | /|\ | /| -c | \4 |11/ | \20|27/ | -c | 3\ | /12|19\ | /28| -c | \|/ | \|/ | -c 2----7---12---17---22 -c | /|\ | /|\ | -c | 1/ | \10|17/ | \26| -c | /2 | 9\ | /18|25\ | -c |/ | \|/ | \| -c 1----6---11---16---21 -c - dy = by-ay - dx = bx-ax - dy = dy/ngridy - dx = dx/ngridx -c -c set number of triangles and vertices -c - nvert = (ngridx+1)*(ngridy+1) - ntri = 2*ngridx*ngridy -c -c set coordinates of vertices -c - k=0 - do 11 i=1,ngridx+1 - xtemp=ax+(i-1)*dx - if (i.eq.ngridx+1) xtemp=bx - do 10 j=1,ngridy+1 - k=k+1 - xvert(k)=xtemp - yvert(k)=ay+(j-1)*dy - if (j.eq.ngridy+1) yvert(k)=by - 10 continue - 11 continue -c -c set vertices and boundary pieces of triangles -c - do 21 i=1,ngridx,2 - do 20 j=1,ngridy,2 - ivbase=(i-1)*(ngridy+1)+j - itbase=2*((i-1)*ngridy+j)-1 - vertex(1,itbase) = ivbase+ngridy+2 - vertex(2,itbase) = ivbase - vertex(3,itbase) = ivbase+1 - if (i.eq.1) neigh(1,itbase) = -1 - if (j.eq.ngridy) neigh(2,itbase) = -4 - vertex(1,itbase+1) = ivbase+ngridy+2 - vertex(2,itbase+1) = ivbase - vertex(3,itbase+1) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+1) = -2 - if (i.eq.ngridx) neigh(2,itbase+1) = -3 - if (j.ne.ngridy) then - vertex(1,itbase+2) = ivbase+ngridy+2 - vertex(2,itbase+2) = ivbase+2 - vertex(3,itbase+2) = ivbase+1 - if (i.eq.1) neigh(1,itbase+2) = -1 - vertex(1,itbase+3) = ivbase+ngridy+2 - vertex(2,itbase+3) = ivbase+2 - vertex(3,itbase+3) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+3) = -4 - if (i.eq.ngridx) neigh(2,itbase+3) = -3 - endif - if (i.ne.ngridx) then - vertex(1,itbase+2*ngridy) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+2*ngridy) = -2 - vertex(1,itbase+2*ngridy+1) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+1) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy+1) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+1) = -3 - if (j.eq.ngridy) neigh(2,itbase+2*ngridy+1) = -4 - if (j.ne.ngridy) then - vertex(1,itbase+2*ngridy+2) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+2) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+2) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+2*ngridy+2) = -4 - vertex(1,itbase+2*ngridy+3) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+3) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+3) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+3) = -3 - endif - endif - 20 continue - 21 continue -c - if (outlev.ge.3) then - write(ioutpt,102) ngridx,ngridy,ntri,nvert - 102 format(' grid lines ',i3,' X',i3/ - 1 ' triangles ',i5/ - 2 ' vertices ',i5/ - 3 ' initial triangulation complete') - endif - return - end //GO.SYSIN DD src/user.f.poisson echo src/user.f.system 1>&2 sed >src/user.f.system <<'//GO.SYSIN DD src/user.f.system' 's/^-//' -c This is an example 'main' program for calling MGGHAT -c -c This example illustrates how to use MGGHAT to solve a system -c of elliptic equations. In this example, we solve the system -c of 2 equations: -c -c Vxx + (1+W)*Vyy + y*(1-W)*V = f1(x,y) -c (1+V)*Wxx + Wyy + y*(1+V)*W = f2(x,y) -c -c with Dirichlet boundary conditions on the unit square. -c -c f1 and f2 are constructed such that the exact solutions are -c V = (x+y)**4 W = exp(x-y) -c -c This example is taken from _Solving_Elliptic_Problems_ -c _Using_ELLPACK_, Rice and Boisvert, Springer-Verlag, 1985. -c - program main -c -c In 'commons', parameter statements are used to set the dimension for -c the arrays. Also, all of the program parameters are passed through it. -c - include 'commons' -c -c keqn is used to tell which equation we are currently solving. -c keqn = 0 -- a trivial equation used to initialize W=0 -c = 1 -- the equation for V -c = 2 -- the equation for W -c rwrkv and iwrkv are storage spaces used to keep and evaluate -c the V solution while solving the W equation. Similarly, -c rwrkw and iwrkw keep the W solution. The dimensions are -c computed in a 'commons' parameter statement. -c These common blocks also appear in the pde, bcond and true routines. -c - common / cwhich / keqn - common / csaver / rwrkv,rwrkw - common / csavei / iwrkv,iwrkw -c - real rwrkv(ndrwrk),rwrkw(ndrwrk) - integer iwrkv(ndiwrk),iwrkw(ndiwrk) - logical lwrkv(ndlwrk),lwrkw(ndlwrk) -c - real v10x10(10,10), w10x10(10,10), hold10(10,10), deltav, deltaw - integer i,j -c -c don't prompt for run time graphics -c - gquiet = .true. -c -c solve the trivial problem to get initial guess w = 0 -c - mxvert = 15 - keqn = 0 - call mgghat - call save(rwrkw,iwrkw,lwrkw) -c -c set initial v and w tables to 0. -c - do 20 i=1,10 - do 10 j=1,10 - v10x10(i,j) = 0. - w10x10(i,j) = 0. - 10 continue - 20 continue -c -c alternate solving for v and w -c -c use 2nd order method, printed output at the end of the -c solution, and terminate on error estimate < .05 -c - mxvert = ndvert - iorder = 2 - outlev = 1 - tol = .05 -c -c solve the V equation -c - 1 keqn = 1 - call mgghat -c -c save the data structures -c - call save(rwrkv,iwrkv,lwrkv) -c -c see how much V has changed -c - do 40 i=1,10 - do 30 j=1,10 - hold10(i,j) = v10x10(i,j) - 30 continue - 40 continue - deltav = change(hold10,v10x10,10,rwrkv,iwrkv) - print * - print *,'change since last V solution is ',deltav -c -c solve the W equation -c - keqn = 2 - call mgghat -c -c save the data structures -c - call save(rwrkw,iwrkw,lwrkw) -c -c see how much W has changed -c - do 50 i=1,10 - do 50 j=1,10 - hold10(i,j) = w10x10(i,j) - 50 continue - 60 continue - deltaw = change(hold10,w10x10,10,rwrkw,iwrkw) - print * - print *,'change since last W solution is ',deltaw -c -c continue the V-W iteration until both have changes less than 10**-3 -c - if (deltav.gt.1.e-3 .or. deltaw.gt.1.e-3) go to 1 -c -c solve them each one more time, but this time save the solution -c for later gnuplot graphics -c - gptri = 1 - gpsol = 20 - keqn = 1 - call mgghat - call system('mv gptri.dat gptriv.dat') - call system('mv gpsol.dat gpsolv.dat') - call save(rwrkv,iwrkv,lwrkv) - keqn = 2 - call mgghat - call system('mv gptri.dat gptriw.dat') - call system('mv gpsol.dat gpsolw.dat') -c - stop - end -c - function change(old,new,n,rwrk,iwrk) - real old(n,n),new(n,n),rwrk(*) - integer iwrk(*) -c -c evaluate the saved solution on a nXn grid of the unit square, -c returning it in new, and calculate the maximum change from old -c (maximum change is returned as the function value) -c - it = 1 - difmax = -1. - do 20 i=1,n - x = float(i-1)/float(n-1) - do 10 j=1,n - y = float(j-1)/float(n-1) - new(i,j) = ssolut(x,y,6,it,rwrk,iwrk) - if (abs(new(i,j)-old(i,j)).gt.difmax) - . difmax = abs(new(i,j)-old(i,j)) - 10 continue - 20 continue -c - change = difmax -c - return - end -c -c -------- pde -c - subroutine pde(x,y,p,q,r,f) -c -c this version is for an example of a system of 2 equations -c - real x,y,p,q,r,f - include 'commons' - common / cwhich / keqn - common / csaver / rwrkv,rwrkw - common / csavei / iwrkv,iwrkw - real rwrkv(ndrwrk),rwrkw(ndrwrk) - integer iwrkv(ndiwrk),iwrkw(ndiwrk) -c -c return the values of the pde coefficents at (x,y) -c pde is -c -c -( p(x,y) * u ) -( q(x,y) * u ) + r(x,y) * u = f(x,y) -c x x y y -c -c NOTE: BE CAREFUL TO GET THE SIGNS RIGHT -c e.g. p=q=1. means f=-(uxx+uyy) -c -c some useful expressions -c - xpy = x+y - xpy2 = xpy*xpy - xpy3 = xpy*xpy2 - xpy4 = xpy*xpy3 - exmy = exp(x-y) -c -c trivial problem, to get an initial guess of 0. -c - if (keqn.eq.0) then - p=1. - q=1. - r=0. - f=0. -c -c the equation for V -c - elseif (keqn.eq.1) then - it = 1 - w = ssolut(x,y,6,it,rwrkw,iwrkw) - p=1. - q=1.+w - r=y*(1.-w) - f = xpy2*(-24. +4.*exmy*xpy -12.*exmy - . +y*(1.-exmy)*xpy2) -c -c the equation for W -c - elseif (keqn.eq.2) then - it=1 - v = ssolut(x,y,6,it,rwrkv,iwrkv) - p=1.+v - q=1. - r=y*(1.+v) - f=exmy*(-4.*xpy3 -1. +(y-1.)*(1.+xpy4)) -c - else - print *,'ERROR -- pde called with keqn = ',keqn - stop - endif -c - return - end -c -c -------- bcond -c - subroutine bcond(x,y,ipiece,c,g,itype) - real x,y,c,g - integer ipiece,itype -c -c Dirichlet boundary condition everywhere for both equations -c - itype = 1 - c = 0. - g = true(x,y) -c - return - end -c -c -------- true -c - real function true(x,y) - real x,y - common / cwhich / keqn -c -c the true solution. see subroutine pde for the cases. -c same holds for truex and truey -c - if (keqn.eq.0) then - true=0. - elseif (keqn.eq.1) then - xpy=x+y - true=xpy*xpy*xpy*xpy - elseif (keqn.eq.2) then - true=exp(x-y) - else - print *,'ERROR -- true called with keqn = ',keqn - stop - endif - return - end -c -c -------- truex -c - real function truex(x,y) - real x,y - common / cwhich / keqn - if (keqn.eq.0) then - truex=0. - elseif (keqn.eq.1) then - xpy=x+y - truex=4.*xpy*xpy*xpy - elseif (keqn.eq.2) then - truex=exp(x-y) - else - print *,'ERROR -- truex called with keqn = ',keqn - stop - endif - return - end -c -c -------- truey -c - real function truey(x,y) - real x,y - common / cwhich / keqn - if (keqn.eq.0) then - truey=0. - elseif (keqn.eq.1) then - xpy=x+y - truey=4.*xpy*xpy*xpy - elseif (keqn.eq.2) then - truey=-exp(x-y) - else - print *,'ERROR -- truey called with keqn = ',keqn - stop - endif - return - end -c -c -------- inittr -c There are no changes in this routine, w.r.t user.f.poisson -c - subroutine inittr - include 'commons' -c -c rectangular domain (ax,bx) X (ay,by) with an ngridx X ngridy grid -c - ax = 0. - bx = 1. - ay = 0. - by = 1. - ngridx = 2 - ngridy = 2 -c - if (outlev.ge.3) write(ioutpt,101) ax,bx,ay,by - 101 format(' begin initializing triangulation'/ - . ' triangulation for rectangle (',f8.2, - . ',',f8.2,') X (',f8.2,',',f8.2,')') -c -c set initial triangulation -c -c this is a user provided routine to define the domain and -c the initial triangulation -c -c the user provides: -c -c nvert - number of vertices -c ntri - number of triangles -c xvert(1..nvert),yvert(1..nvert) - x and y coordinates -c of the vertices -c vertex(1..3,1..ntri) - the 3 vertices of each triangle -c neigh(i,1..ntri) - which piece of the boundary contains the triangle -c side opposite vertex i. Need not be set if -c that side is not on the domain boundary. -c -c the peak of each triangle is the third vertex, i.e., -c peak(triangle)=vertex(3,triangle) -c -c assumptions on the triangulation are: -c -c 1) each vertex is in the same position (first, second, or third) -c in every triangle that contains it, e.g., if vertex 2 is -c the first vertex of triangle 3 (vertex(1,3)=2). vertex 2 must -c also be the first vertex of any other triangle containing it. -c thus we can have vertex(1,4)=2, and cannot have vertex(2,4)=2 -c -c 2) vertices which are first or second vertices can be in at most -c 8 triangles. vertices which are third vertices (peaks) can -c be in at most 4 triangles -c -c This version of the routine triangulates the rectangle (ax,bx)X(ay,by). -c ngridx and ngridy specify the number of intervals in each dimension. -c The boundary pieces (ipiece for subroutine bcond) are: -c 1 - left -c 2 - bottom -c 3 - right -c 4 - top -c -c for the case of a 4X4 grid, the vertex and triangle numbers are: -c -c 5---10---15---20---25 -c |\ | /|\ | /| -c | \ 8|15/ | \24|31/ | -c | 7\ | /16|23\ | /32| -c | \|/ | \|/ | -c 4----9---14---19---24 -c | /|\ | /|\ | -c | 5/ | \14|21/ | \30| -c | /6 |13\ | /22|29\ | -c |/ | \|/ | \| -c 3----8---13---18---23 -c |\ | /|\ | /| -c | \4 |11/ | \20|27/ | -c | 3\ | /12|19\ | /28| -c | \|/ | \|/ | -c 2----7---12---17---22 -c | /|\ | /|\ | -c | 1/ | \10|17/ | \26| -c | /2 | 9\ | /18|25\ | -c |/ | \|/ | \| -c 1----6---11---16---21 -c - dy = by-ay - dx = bx-ax - dy = dy/ngridy - dx = dx/ngridx -c -c set number of triangles and vertices -c - nvert = (ngridx+1)*(ngridy+1) - ntri = 2*ngridx*ngridy -c -c set coordinates of vertices -c - k=0 - do 11 i=1,ngridx+1 - xtemp=ax+(i-1)*dx - if (i.eq.ngridx+1) xtemp=bx - do 10 j=1,ngridy+1 - k=k+1 - xvert(k)=xtemp - yvert(k)=ay+(j-1)*dy - if (j.eq.ngridy+1) yvert(k)=by - 10 continue - 11 continue -c -c set vertices and boundary pieces of triangles -c - do 21 i=1,ngridx,2 - do 20 j=1,ngridy,2 - ivbase=(i-1)*(ngridy+1)+j - itbase=2*((i-1)*ngridy+j)-1 - vertex(1,itbase) = ivbase+ngridy+2 - vertex(2,itbase) = ivbase - vertex(3,itbase) = ivbase+1 - if (i.eq.1) neigh(1,itbase) = -1 - if (j.eq.ngridy) neigh(2,itbase) = -4 - vertex(1,itbase+1) = ivbase+ngridy+2 - vertex(2,itbase+1) = ivbase - vertex(3,itbase+1) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+1) = -2 - if (i.eq.ngridx) neigh(2,itbase+1) = -3 - if (j.ne.ngridy) then - vertex(1,itbase+2) = ivbase+ngridy+2 - vertex(2,itbase+2) = ivbase+2 - vertex(3,itbase+2) = ivbase+1 - if (i.eq.1) neigh(1,itbase+2) = -1 - vertex(1,itbase+3) = ivbase+ngridy+2 - vertex(2,itbase+3) = ivbase+2 - vertex(3,itbase+3) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+3) = -4 - if (i.eq.ngridx) neigh(2,itbase+3) = -3 - endif - if (i.ne.ngridx) then - vertex(1,itbase+2*ngridy) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+2*ngridy) = -2 - vertex(1,itbase+2*ngridy+1) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+1) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy+1) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+1) = -3 - if (j.eq.ngridy) neigh(2,itbase+2*ngridy+1) = -4 - if (j.ne.ngridy) then - vertex(1,itbase+2*ngridy+2) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+2) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+2) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+2*ngridy+2) = -4 - vertex(1,itbase+2*ngridy+3) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+3) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+3) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+3) = -3 - endif - endif - 20 continue - 21 continue -c - if (outlev.ge.3) then - write(ioutpt,102) ngridx,ngridy,ntri,nvert - 102 format(' grid lines ',i3,'X',i3/ - 1 ' triangles ',i5/ - 2 ' vertices ',i5/ - 3 ' initial triangulation complete') - endif - return - end //GO.SYSIN DD src/user.f.system echo src/makefile.convex 1>&2 sed >src/makefile.convex <<'//GO.SYSIN DD src/makefile.convex' 's/^-//' -SHELL = /bin/sh -# LINPACK and DLINPACK need to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me -DLINPACK = dfix.me - -FFLAGS = -fn -O2 -CFLAGS = -fn -O2 -F77 = fc -CC = cc -DOUBLE = -p8 - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: $(DLINPACK) commons makefile mgghat8.o user8.o second8.o \ - gnuplt.o - $(F77) $(FFLAGS) $(DOUBLE) -o mgghat \ - mgghat8.o user8.o second8.o gnuplt.o \ - $(DLINPACK) - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.f - $(F77) $(FFLAGS) -c second.f - -mgghat8.o: commons makefile mgghat.f - $(F77) $(FFLAGS) $(DOUBLE) -c mgghat.f -o mgghat8.o - -user8.o: commons makefile user.f - $(F77) $(FFLAGS) $(DOUBLE) -c user.f -o user8.o - -second8.o: commons makefile second.f - $(F77) $(FFLAGS) $(DOUBLE) -c second.f -o second8.o - -gnuplt.o: commons makefile gnuplt.c - $(CC) $(CFLAGS) -c gnuplt.c - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi - -$(DLINPACK): makefile r1mach8.f - @if [ "$@" = "dfix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c r1mach8.f ; \ - else if [ "$@" = "linpack8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c linpack.f -o linpack8.o; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.convex echo src/gnuplt.cray.c 1>&2 sed >src/gnuplt.cray.c <<'//GO.SYSIN DD src/gnuplt.cray.c' 's/^-//' -/* Copyright (c) 1993 by P. Klosowski at NIST. All Rights Reserved */ - -/*** - NAME - lgnuplot - PURPOSE - fortran-> gnuplot interface - NOTES - - HISTORY - przemek - Mar 2, 1993: Created. - ---- -May 1994. Changes made by William F. Mitchell, Applied and -Computational Mathematics Division, NIST: - -1) changed names gnuplot_open, gnuplot and gnuplot_close to -gpopen, gnuplt and gpclos, respectively, to conform with -FORTRAN 77 standard of 6 characters for identifiers. - -2) removed procedure "pause", since I'm not using it and one -of the compilers I tried balked at something in it. - -3) replaced procedure names with upper case version without -trailing underscore, as expected by Cray. - -4) replaced string conversion by the Cray way of doing it, -using #include , _fcd and _fcdtocp. - -The original version is from the user contributed software -for gnuplot. It is in the file gpcontrb.zip which is -available with gnuplot release 3.5. - -Bill ---- - -***/ -#include -#include -long -GPOPEN(void) -{ - FILE * fp = popen("gnuplot","w"); - if (fp == NULL) { - printf("Can't run gnuplot\n"); - } - return (long) fp; -} -void -GNUPLT(FILE ** fpp, _fcd command) -{ - char buf[200]; - int size; - - size = _fcdlen(command); - strncpy(buf,_fcdtocp(command),size); buf[size] = '\0'; - if(buf[size-1] != '\n') - strcat(buf,"\n"); - fprintf(*fpp,buf); - fflush(*fpp); -} -void -GPCLOS(FILE ** fpp) -{ - if (pclose(*fpp) == -1) - printf("Problem closing communications to gnuplot\n"); -} //GO.SYSIN DD src/gnuplt.cray.c echo src/inittr.L 1>&2 sed >src/inittr.L <<'//GO.SYSIN DD src/inittr.L' 's/^-//' -c This is an example of a subroutine to set the initial triangulation -c - subroutine inittr - include 'commons' -c -c set initial triangulation -c -c initial triangulation (with vertex and triangle numbers) is: -c -c 3--7--2 -c |\6|3/| -c |5\|/4| -c 5--4--8 -c |1/| -c |/2| -c 1--6 -c -c set number of triangles and vertices -c - nvert = 8 - ntri = 6 -c -c set coordinates of vertices -c - xvert(1) = -1. - yvert(1) = -1. - xvert(2) = 1. - yvert(2) = 1. - xvert(3) = -1. - yvert(3) = 1. - xvert(4) = 0. - yvert(4) = 0. - xvert(5) = -1. - yvert(5) = 0. - xvert(6) = 0. - yvert(6) = -1. - xvert(7) = 0. - yvert(7) = 1. - xvert(8) = 1. - yvert(8) = 0. -c -c set vertices of triangles -c - vertex(1,1)=1 - vertex(2,1)=4 - vertex(3,1)=5 - vertex(1,2)=1 - vertex(2,2)=4 - vertex(3,2)=6 - vertex(1,3)=2 - vertex(2,3)=4 - vertex(3,3)=7 - vertex(1,4)=2 - vertex(2,4)=4 - vertex(3,4)=8 - vertex(1,5)=3 - vertex(2,5)=4 - vertex(3,5)=5 - vertex(1,6)=3 - vertex(2,6)=4 - vertex(3,6)=7 -c -c Set all the neighbors to be -1 (this is OK when only one boundary piece). -c If bcond checks the boundary piece, set neigh to -ipiece -c when the side opposite the vertex is part of boundary piece ipiece. -c - do 20 i=1,3 - do 10 j=1,6 - neigh(i,j)=-1 - 10 continue - 20 continue -c - if (outlev.ge.1) then - write(ioutpt,100) - 100 format(' INITIAL TRIANGULATION'// - 1 ' generated L-shaped domain'/) - endif -c - return - end //GO.SYSIN DD src/inittr.L echo src/second.c 1>&2 sed >src/second.c <<'//GO.SYSIN DD src/second.c' 's/^-//' -/* measure execution time in seconds */ -/* Bill Mitchell 10/9/92 */ -/* */ -/* Use unix routine"times"to measure */ -/* user execution time between */ -/* calls to second in seconds. */ -/* Callable from FORTRAN and C. */ -/* Returns real */ -/* in FORTRAN and float in C. */ - -/* FORTRAN callable version */ -static int holdtime,flagtime=1; -float second_() -{ -/* just call C version */ - float second(); - return second(); -} - -/* C callable version */ -float second() -{ -#include -#include -#include - clock_t times(); - clock_t t; - struct tms t1; - -/* call "times" */ - t=times(&t1); - if (flagtime) { - flagtime=0; - holdtime=t; - } -/* user time in 1/HZ seconds is in tms_utime */ -/* HZ is in sys/param.h */ - return ((float)t1.tms_utime)/((float)HZ); -} //GO.SYSIN DD src/second.c echo src/makefile.sunos 1>&2 sed >src/makefile.sunos <<'//GO.SYSIN DD src/makefile.sunos' 's/^-//' -SHELL = /bin/sh -# LINPACK and DLINPACK need to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me -DLINPACK = dfix.me - -FFLAGS = -O3 -CFLAGS = -O -F77 = f77 -CC = gcc -DOUBLE = -r8 - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: $(DLINPACK) commons makefile mgghat8.o user8.o second8.o \ - gnuplt.o - $(F77) $(FFLAGS) $(DOUBLE) -o mgghat \ - mgghat8.o user8.o second8.o gnuplt.o \ - $(DLINPACK) - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.f - $(F77) $(FFLAGS) -c second.f - -mgghat8.o: commons makefile mgghat.f - $(F77) $(FFLAGS) $(DOUBLE) -c mgghat.f -o mgghat8.o - -user8.o: commons makefile user.f - $(F77) $(FFLAGS) $(DOUBLE) -c user.f -o user8.o - -second8.o: commons makefile second.f - $(F77) $(FFLAGS) $(DOUBLE) -c second.f -o second8.o - -gnuplt.o: commons makefile gnuplt.c - $(CC) $(CFLAGS) -c gnuplt.c - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi - -$(DLINPACK): makefile r1mach8.f - @if [ "$@" = "dfix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c r1mach8.f ; \ - else if [ "$@" = "linpack8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c linpack.f -o linpack8.o; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.sunos echo src/README 1>&2 sed >src/README <<'//GO.SYSIN DD src/README' 's/^-//' -This directory contains the source code for MGGHAT Version 1.1. - -See the directory "doc" for information on what MGGHAT does, the -method it uses, how to install it, and how to use it. - -You WILL have to change the makefile. See mgghat/doc/install.ascii. - - ---- - -William F. Mitchell -mitchell@cam.nist.gov -na.wmitchell@na-net.ornl.gov //GO.SYSIN DD src/README echo src/system.cray.f 1>&2 sed >src/system.cray.f <<'//GO.SYSIN DD src/system.cray.f' 's/^-//' - subroutine system(str) - character*(*) str -c -c Cray uses ishell instead of system -c - call ishell(str) - return - end //GO.SYSIN DD src/system.cray.f echo src/makefile.hpux 1>&2 sed >src/makefile.hpux <<'//GO.SYSIN DD src/makefile.hpux' 's/^-//' -SHELL = /bin/sh -# LINPACK needs to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me - -FFLAGS = -O -CFLAGS = -O -Aa -F77 = f77 -CC = cc -DOUBLE = - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: - @echo "auto double not available with hp f77" - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.c - $(CC) -c second.c -o second.o - -gnuplt.o: commons makefile gnuplt.no_.c - $(CC) $(CFLAGS) -c gnuplt.no_.c -o gnuplt.o - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.hpux echo src/grmenu 1>&2 sed >src/grmenu <<'//GO.SYSIN DD src/grmenu' 's/^-//' -#!wish -f -# -# This is a tcl/tk script that creates the graphics selection menu - -#set auto_path "$tk_library/demos $auto_path" -wm title . "MGGHAT Graphics Control" - -set phi 60 -set theta 30 -set view 0 -set num_isox 20 -set num_isoy 20 - -frame .menu -relief raised -borderwidth 1 - -pack append . .menu {top fillx} - - -menubutton .menu.select -text "Add/Delete" -menu .menu.select.m -menu .menu.select.m -.menu.select.m add cascade -label "Computed Solution =>" -menu .menu.select.m.soln -.menu.select.m add cascade -label "True Solution=>" -menu .menu.select.m.true -.menu.select.m add cascade -label "Computed & True =>" -menu .menu.select.m.both -.menu.select.m add cascade -label "Error =>" -menu .menu.select.m.error -.menu.select.m add cascade -label "Triangulation =>" -menu .menu.select.m.tri -.menu.select.m add cascade -label "Convergence =>" -menu .menu.select.m.conv - -menubutton .menu.mod -text "Modify" -menu .menu.mod.m -menu .menu.mod.m -.menu.mod.m add cascade -label "Rotate View =>" -menu .menu.mod.m.view -.menu.mod.m add command -label "Isolines" -command "set_iso" - -menubutton .menu.quit -text "Quit" -menu .menu.quit.m -menu .menu.quit.m -.menu.quit.m add command -label "Quit" -command "all_done" - -menu .menu.select.m.conv -.menu.select.m.conv add cascade -label "Nodes vs. =>" -menu .menu.select.m.conv.node -.menu.select.m.conv add cascade -label "Time vs. =>" -menu .menu.select.m.conv.time - -menu .menu.select.m.soln -.menu.select.m.soln add check -label "Surface" \ - -variable soln_surf \ - -onvalue 1 -offvalue -1 \ - -command "check_proc soln_surf 0" -.menu.select.m.soln add check -label "Contour" \ - -variable soln_cont \ - -onvalue 2 -offvalue -2 \ - -command "check_proc soln_cont none" -.menu.select.m.soln add check -label "Facets" \ - -variable soln_face \ - -onvalue 3 -offvalue -3 \ - -command "check_proc soln_face 1" -.menu.select.m.soln add check -label "Surface & Triangulation" \ - -variable soln_surf_tri \ - -onvalue 4 -offvalue -4 \ - -command "check_proc soln_surf_tri 2" -#.menu.select.m.soln add check -label "Contour & Triangulation" \ -# -variable soln_cont_tri \ -# -onvalue 5 -offvalue -5 \ -# -command "check_proc soln_cont_tri none" \ -# -state disabled -.menu.select.m.soln add check -label "Facets & Triangulation" \ - -variable soln_face_tri \ - -onvalue 6 -offvalue -6 \ - -command "check_proc soln_face_tri 3" - -menu .menu.select.m.true -.menu.select.m.true add check -label "Surface" \ - -variable true_surf \ - -onvalue 11 -offvalue -11 \ - -command "check_proc true_surf 4" -.menu.select.m.true add check -label "Contour" \ - -variable true_cont \ - -onvalue 12 -offvalue -12 \ - -command "check_proc true_cont none" -.menu.select.m.true add check -label "Facets" \ - -variable true_face \ - -onvalue 13 -offvalue -13 \ - -command "check_proc true_face 5" -.menu.select.m.true add check -label "Surface & Triangulation" \ - -variable true_surf_tri \ - -onvalue 14 -offvalue -14 \ - -command "check_proc true_surf_tri 6" -#.menu.select.m.true add check -label "Contour & Triangulation" \ -# -variable true_cont_tri \ -# -onvalue 15 -offvalue -15 \ -# -command "check_proc true_cont_tri none" \ -# -state disabled -.menu.select.m.true add check -label "Facets & Triangulation" \ - -variable true_face_tri \ - -onvalue 16 -offvalue -16 \ - -command "check_proc true_face_tri 7" - -menu .menu.select.m.both -.menu.select.m.both add check -label "Surface" \ - -variable both_surf \ - -onvalue 21 -offvalue -21 \ - -command "check_proc both_surf 8" -.menu.select.m.both add check -label "Contour" \ - -variable both_cont \ - -onvalue 22 -offvalue -22 \ - -command "check_proc both_cont none" -.menu.select.m.both add check -label "Facets" \ - -variable both_face \ - -onvalue 23 -offvalue -23 \ - -command "check_proc both_face 9" -.menu.select.m.both add check -label "Surface & Triangulation" \ - -variable both_surf_tri \ - -onvalue 24 -offvalue -24 \ - -command "check_proc both_surf_tri 10" -#.menu.select.m.both add check -label "Contour & Triangulation" \ -# -variable both_cont_tri \ -# -onvalue 25 -offvalue -25 \ -# -command "check_proc both_cont_tri none" \ -# -state disabled -.menu.select.m.both add check -label "Facets & Triangulation" \ - -variable both_face_tri \ - -onvalue 26 -offvalue -26 \ - -command "check_proc both_face_tri 11" - -menu .menu.select.m.error -.menu.select.m.error add check -label "Surface" \ - -variable error_surf \ - -onvalue 31 -offvalue -31 \ - -command "check_proc error_surf 12" -.menu.select.m.error add check -label "Contour" \ - -variable error_cont \ - -onvalue 32 -offvalue -32 \ - -command "check_proc error_cont none" -.menu.select.m.error add check -label "Facets" \ - -variable error_face \ - -onvalue 33 -offvalue -33 \ - -command "check_proc error_face 13" -.menu.select.m.error add check -label "Surface & Triangulation" \ - -variable error_surf_tri \ - -onvalue 34 -offvalue -34 \ - -command "check_proc error_surf_tri 14" -#.menu.select.m.error add check -label "Contour & Triangulation" \ -# -variable error_cont_tri \ -# -onvalue 35 -offvalue -35 \ -# -command "check_proc error_cont_tri none" \ -# -state disabled -.menu.select.m.error add check -label "Facets & Triangulation" \ - -variable error_face_tri \ - -onvalue 36 -offvalue -36 \ - -command "check_proc error_face_tri 15" - -menu .menu.select.m.tri -.menu.select.m.tri add check -label "Triangulation" \ - -variable tri \ - -onvalue 41 -offvalue -41 \ - -command "check_proc tri none" - -menu .menu.select.m.conv.node -.menu.select.m.conv.node add check -label "Energy Error" \ - -variable convn_enerr \ - -onvalue 51 -offvalue -51 \ - -command "check_proc convn_enerr none" -.menu.select.m.conv.node add check -label "Max Error" \ - -variable convn_maxerr \ - -onvalue 52 -offvalue -52 \ - -command "check_proc convn_maxerr none" -.menu.select.m.conv.node add check -label "Energy Estimate" \ - -variable convn_enest \ - -onvalue 53 -offvalue -53 \ - -command "check_proc convn_enest none" -.menu.select.m.conv.node add check -label "Energy Error & Estimate" \ - -variable convn_maxest \ - -onvalue 54 -offvalue -54 \ - -command "check_proc convn_maxest none" - -menu .menu.select.m.conv.time -.menu.select.m.conv.time add check -label "Energy Error" \ - -variable convt_enerr \ - -onvalue 61 -offvalue -61 \ - -command "check_proc convt_enerr none" -.menu.select.m.conv.time add check -label "Max Error" \ - -variable convt_maxerr \ - -onvalue 62 -offvalue -62 \ - -command "check_proc convt_maxerr none" -.menu.select.m.conv.time add check -label "Energy Estimate" \ - -variable convt_enest \ - -onvalue 63 -offvalue -63 \ - -command "check_proc convt_enest none" -.menu.select.m.conv.time add check -label "Energy Error & Estimate" \ - -variable convt_maxest \ - -onvalue 64 -offvalue -64 \ - -command "check_proc convt_maxest none" - -menu .menu.mod.m.view -.menu.mod.m.view add command -label "Computed Solution; Surface" \ - -command "rot 1" \ - -state disabled -.menu.mod.m.view add command -label "Computed Solution; Facets" \ - -command "rot 3" \ - -state disabled -.menu.mod.m.view add command -label "Computed Solution; Surface & Triangulation" \ - -command "rot 4" \ - -state disabled -.menu.mod.m.view add command -label "Computed Solution; Facets & Triangulation" \ - -command "rot 6" \ - -state disabled -.menu.mod.m.view add command -label "True Solution; Surface" \ - -command "rot 11" \ - -state disabled -.menu.mod.m.view add command -label "True Solution; Facets" \ - -command "rot 13" \ - -state disabled -.menu.mod.m.view add command -label "True Solution; Surface & Triangulation" \ - -command "rot 14" \ - -state disabled -.menu.mod.m.view add command -label "True Solution; Facets & Triangulation" \ - -command "rot 16" \ - -state disabled -.menu.mod.m.view add command -label "Computed and True; Surface" \ - -command "rot 21" \ - -state disabled -.menu.mod.m.view add command -label "Computed and True; Facets" \ - -command "rot 23" \ - -state disabled -.menu.mod.m.view add command -label "Computed and True; Surface & Triangulation" \ - -command "rot 24" \ - -state disabled -.menu.mod.m.view add command -label "Computed and True; Facets & Triangulation" \ - -command "rot 26" \ - -state disabled -.menu.mod.m.view add command -label "Error; Surface" \ - -command "rot 31" \ - -state disabled -.menu.mod.m.view add command -label "Error; Facets" \ - -command "rot 33" \ - -state disabled -.menu.mod.m.view add command -label "Error; Surface & Triangulation" \ - -command "rot 34" \ - -state disabled -.menu.mod.m.view add command -label "Error; Facets & Triangulation" \ - -command "rot 36" \ - -state disabled - -pack append .menu .menu.select left .menu.mod left .menu.quit left - -proc rot {v} { -global view -set view $v -mkVScale -} - -proc check_proc {var string} { -global $var -if ($$var>0) { - .menu.mod.m.view entryconfigure $string -state normal - set lockfileid [open "lmen2mgg" a+] - set outfileid [open "/tmp/men2mgg" a+] - puts $outfileid "1 [expr $$var]" - flush $outfileid - close $outfileid - close $lockfileid - exec rm lmen2mgg -} else { - .menu.mod.m.view entryconfigure $string -state disabled - set lockfileid [open "lmen2mgg" a+] - set outfileid [open "/tmp/men2mgg" a+] - puts $outfileid "0 [expr -$$var]" - flush $outfileid - close $outfileid - close $lockfileid - exec rm lmen2mgg -} -} - -proc all_done {} { - set lockfileid [open "lmen2mgg" a+] - set outfileid [open "/tmp/men2mgg" a+] - puts $outfileid "3 0" - flush $outfileid - close $outfileid - close $lockfileid - exec rm lmen2mgg - destroy . -} - - -proc mkVScale {{w .scale1}} { -global theta -global phi - catch {destroy $w} - toplevel $w - wm geometry $w +500+100 - wm title $w "Rotation" - wm iconname $w "Scale" - frame $w.frame -borderwidth 10 - set c $w.c - canvas $c -width 300 -height 300 - pack append $w.frame \ - [scale $w.frame.scalev -orient vertical -length 360 -from 0 -to 180 \ - -command "setHeight $c" -tickinterval 30 \ - -bg Bisque1] {left expand frame ne} - pack append $w.frame \ - [scale $w.frame.scaleh -orient horizontal -length 360 -from 0 -to 360 \ - -command "setWidth $c" -tickinterval 30 \ - -bg Bisque1] {bottom expand frame sw} \ - $c {top expand frame ne} - $w.frame.scalev set $phi - $w.frame.scaleh set $theta - button $w.apply -text Apply -command "dorot" - button $w.quit -text Done -command "destroy $w" - - pack append $w $w.frame {top expand fill} \ - $w.apply {bottom expand fill left} $w.quit {bottom expand fill right} -} - -proc setHeight {c height} { -global theta -global phi -set phi $height -set ph $phi -set th $theta -set sinph [expr {$ph<180?[expr $ph*(180.-$ph)/8100.]: \ - [expr (180.-$ph)*(360.-$ph)/8100.]}] -set sinth [expr {$th<180?[expr $th*(180.-$th)/8100.]: \ - [expr (180.-$th)*(360.-$th)/8100.]}] -set ph [expr {$ph>270?[expr $ph-360]:[expr $ph]}] -set th [expr {$th>270?[expr $th-360]:[expr $th]}] -set cosph [expr {$ph<90?[expr ($ph+90.)*(90.-$ph)/8100.]: \ - [expr (90.-$ph)*(270.-$ph)/8100.]}] -set costh [expr {$th<90?[expr ($th+90.)*(90.-$th)/8100.]: \ - [expr (90.-$th)*(270.-$th)/8100.]}] -set x 150 -set y [expr -$sinph*100.+150.] - $c delete all - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "z" -set x [expr $costh*100.+150.] -set y [expr $cosph*$sinth*100.+150.] - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "x" -set x [expr $sinth*100.+150.] -set y [expr -$cosph*$costh*100.+150.] - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "y" -} - -proc setWidth {c width} { -global theta -global phi -set theta $width -set ph $phi -set th $theta -set sinph [expr {$ph<180?[expr $ph*(180.-$ph)/8100.]: \ - [expr (180.-$ph)*(360.-$ph)/8100.]}] -set sinth [expr {$th<180?[expr $th*(180.-$th)/8100.]: \ - [expr (180.-$th)*(360.-$th)/8100.]}] -set ph [expr {$ph>270?[expr $ph-360]:[expr $ph]}] -set th [expr {$th>270?[expr $th-360]:[expr $th]}] -set cosph [expr {$ph<90?[expr ($ph+90.)*(90.-$ph)/8100.]: \ - [expr (90.-$ph)*(270.-$ph)/8100.]}] -set costh [expr {$th<90?[expr ($th+90.)*(90.-$th)/8100.]: \ - [expr (90.-$th)*(270.-$th)/8100.]}] -set x 150 -set y [expr -$sinph*100.+150.] - $c delete all - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "z" -set x [expr $costh*100.+150.] -set y [expr $cosph*$sinth*100.+150.] - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "x" -set x [expr $sinth*100.+150.] -set y [expr -$cosph*$costh*100.+150.] - $c create line 150 150 $x $y -arrow last - $c create text [expr $x-10] [expr $y-10] -text "y" -} - -proc dorot {} { -global theta -global phi -global view -set lockfileid [open "lmen2mgg" a+] -set outfileid [open "/tmp/men2mgg" a+] -puts $outfileid "2 [expr $view]" -puts $outfileid "set view $phi , $theta; replot" -flush $outfileid -close $outfileid -close $lockfileid -exec rm lmen2mgg -} - -proc set_iso {} { -mkEntry -} - -proc mkEntry {{w .e1}} { -global num_isox -global num_isoy - catch {destroy $w} - toplevel $w - wm title $w "Isolines" - message $w.msg -aspect 200 \ - -text "Enter desired number of isolines and click on \"OK\"" - frame $w.frame1 -borderwidth 10 - frame $w.frame2 -borderwidth 10 - button $w.ok -text OK -command "set_iso_done $w" - pack append $w $w.msg {top fill} $w.frame1 {top fill} \ - $w.frame2 {top fill} $w.ok {top fill} - - label $w.frame1.l1 -text "X" - entry $w.frame1.e1 -relief sunken -width 10 - pack append $w.frame1 $w.frame1.l1 left $w.frame1.e1 left - label $w.frame2.l2 -text "Y" - entry $w.frame2.e2 -relief sunken -width 10 - pack append $w.frame2 $w.frame2.l2 left $w.frame2.e2 left - - $w.frame1.e1 insert 0 $num_isox - $w.frame2.e2 insert 0 $num_isoy -} - -proc set_iso_done {w} { -global num_isox -global num_isoy -set num_isox [$w.frame1.e1 get] -set num_isoy [$w.frame2.e2 get] -set lockfileid [open "lmen2mgg" a+] -set outfileid [open "/tmp/men2mgg" a+] -puts $outfileid "4 [expr $num_isox]" -puts $outfileid "[expr $num_isoy]" -flush $outfileid -close $outfileid -close $lockfileid -exec rm lmen2mgg -destroy $w -} //GO.SYSIN DD src/grmenu echo src/gnuplt.no_.c 1>&2 sed >src/gnuplt.no_.c <<'//GO.SYSIN DD src/gnuplt.no_.c' 's/^-//' -/* Copyright (c) 1993 by P. Klosowski at NIST. All Rights Reserved */ - -/*** - NAME - lgnuplot - PURPOSE - fortran-> gnuplot interface - NOTES - - HISTORY - przemek - Mar 2, 1993: Created. - ---- -May 1994. Changes made by William F. Mitchell, Applied and -Computational Mathematics Division, NIST: - -1) changed names gnuplot_open, gnuplot and gnuplot_close to -gpopen, gnuplt and gpclos, respectively, to conform with -FORTRAN 77 standard of 6 characters for identifiers. - -2) removed procedure "pause", since I'm not using it and one -of the compilers I tried balked at something in it. - -3) removed the trailing underscore from the procedure names -to provide a version for systems that don't excpect it - -The original version is from the user contributed software -for gnuplot. It is in the file gpcontrb.zip which is -available with gnuplot release 3.5. - -Bill ---- - -***/ -#include -long -gpopen(void) -{ - FILE * fp = popen("gnuplot","w"); - if (fp == NULL) { - printf("Can't run gnuplot\n"); - } - return (long) fp; -} -void -gnuplt(FILE ** fpp, char * command, int size) -{ - char buf[200]; - - strncpy(buf,command,size); buf[size]='\0'; - if(buf[size-1] != '\n') - strcat(buf,"\n"); - fprintf(*fpp,buf); - fflush(*fpp); -} -void -gpclos(FILE ** fpp) -{ - if (pclose(*fpp) == -1) - printf("Problem closing communications to gnuplot\n"); -} //GO.SYSIN DD src/gnuplt.no_.c echo src/gnuplt.c 1>&2 sed >src/gnuplt.c <<'//GO.SYSIN DD src/gnuplt.c' 's/^-//' -/* Copyright (c) 1993 by P. Klosowski at NIST. All Rights Reserved */ - -/*** - NAME - lgnuplot - PURPOSE - fortran-> gnuplot interface - NOTES - - HISTORY - przemek - Mar 2, 1993: Created. - ---- -May 1994. Changes made by William F. Mitchell, Applied and -Computational Mathematics Division, NIST: - -1) changed names gnuplot_open, gnuplot and gnuplot_close to -gpopen, gnuplt and gpclos, respectively, to conform with -FORTRAN 77 standard of 6 characters for identifiers. - -2) removed procedure "pause", since I'm not using it and one -of the compilers I tried balked at something in it. - -The original version is from the user contributed software -for gnuplot. It is in the file gpcontrb.zip which is -available with gnuplot release 3.5. - -Bill ---- - -***/ -#include -long -gpopen_(void) -{ - FILE * fp = popen("gnuplot","w"); - if (fp == NULL) { - printf("Can't run gnuplot\n"); - } - return (long) fp; -} -void -gnuplt_(FILE ** fpp, char * command, int size) -{ - char buf[200]; - - strncpy(buf,command,size); buf[size]='\0'; - if(buf[size-1] != '\n') - strcat(buf,"\n"); - fprintf(*fpp,buf); - fflush(*fpp); -} -void -gpclos_(FILE ** fpp) -{ - if (pclose(*fpp) == -1) - printf("Problem closing communications to gnuplot\n"); -} //GO.SYSIN DD src/gnuplt.c echo src/second.aix.f 1>&2 sed >src/second.aix.f <<'//GO.SYSIN DD src/second.aix.f' 's/^-//' - FUNCTION SECOND () -C -C ------------------------------------------------ -C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) -C ------------------------------------------------ -C -C AIX version -C - INTEGER MCLOCK - SECOND = MCLOCK()/100.0 -C - RETURN - END //GO.SYSIN DD src/second.aix.f echo src/second8.c 1>&2 sed >src/second8.c <<'//GO.SYSIN DD src/second8.c' 's/^-//' -/* measure execution time in seconds */ -/* Bill Mitchell 10/9/92 */ -/* */ -/* Use unix routine"times"to measure */ -/* user execution time between */ -/* calls to second in seconds. */ -/* Callable from FORTRAN and C. */ -/* Returns double precsion (real*8) */ -/* in FORTRAN and double in C. */ - -/* FORTRAN callable version */ -static int holdtime,flagtime=1; -double second_() -{ -/* just call C version */ - double second(); - return second(); -} - -/* C callable version */ -double second() -{ -#include -#include -#include - clock_t times(); - clock_t t; - struct tms t1; - -/* call "times" */ - t=times(&t1); - if (flagtime) { - flagtime=0; - holdtime=t; - } -/* user time in 1/HZ seconds is in tms_utime */ -/* HZ is in sys/param.h */ - return ((double)t1.tms_utime)/((double)HZ); -} //GO.SYSIN DD src/second8.c echo src/need.setup 1>&2 sed >src/need.setup <<'//GO.SYSIN DD src/need.setup' 's/^-//' -echo "" -echo "****************************************************" -echo "* You need to modify the makefile *" -echo "* See the instructions in mgghat/doc/install.ascii *" -echo "****************************************************" -echo "" //GO.SYSIN DD src/need.setup chmod +x src/need.setup echo src/makefile.cray 1>&2 sed >src/makefile.cray <<'//GO.SYSIN DD src/makefile.cray' 's/^-//' -SHELL = /bin/sh -# LINPACK needs to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me - -FFLAGS = -CFLAGS = -F77 = cf77 -CC = cc -DOUBLE = - -mgghat: $(LINPACK) commons makefile mgghat.o user.o gnuplt.o \ - system.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o gnuplt.o system.o \ - $(LINPACK) - -double: - @echo "auto double not available with Cray f77" - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.f - $(F77) $(FFLAGS) -c second.f - -system.o: commons makefile system.cray.f - $(F77) $(FFLAGS) -Wf"-b system.o" -c system.cray.f - -gnuplt.o: commons makefile gnuplt.cray.c - $(CC) $(CFLAGS) -o gnuplt.o -c gnuplt.cray.c - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.cray echo src/r1mach.f 1>&2 sed >src/r1mach.f <<'//GO.SYSIN DD src/r1mach.f' 's/^-//' - REAL FUNCTION R1MACH(I) -C***BEGIN PROLOGUE R1MACH -C***DATE WRITTEN 790101 (YYMMDD) -C***REVISION DATE 860825 (YYMMDD) -C***CATEGORY NO. R1 -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR FOX, P. A., (BELL LABS) -C HALL, A. D., (BELL LABS) -C SCHRYER, N. L., (BELL LABS) -C***PURPOSE Returns single precision machine dependent constants -C***DESCRIPTION -C -C This is the CMLIB version of R1MACH, the real machine -C constants subroutine originally developed for the PORT library. -C -C R1MACH can be used to obtain machine-dependent parameters -C for the local machine environment. It is a function -C subroutine with one (input) argument, and can be called -C as follows, for example -C -C A = R1MACH(I) -C -C where I=1,...,5. The (output) value of A above is -C determined by the (input) value of I. The results for -C various values of I are discussed below. -C -C Single-Precision Machine Constants -C R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. -C R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C R1MACH(3) = B**(-T), the smallest relative spacing. -C R1MACH(4) = B**(1-T), the largest relative spacing. -C R1MACH(5) = LOG10(B) -C***REFERENCES FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR -C A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE- -C MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978, -C PP. 177-188. -C***ROUTINES CALLED XERROR -C***END PROLOGUE R1MACH -C - INTEGER SMALL(2) - INTEGER LARGE(2) - INTEGER RIGHT(2) - INTEGER DIVER(2) - INTEGER LOG10(2) -C - REAL RMACH(5) -C - EQUIVALENCE (RMACH(1),SMALL(1)) - EQUIVALENCE (RMACH(2),LARGE(1)) - EQUIVALENCE (RMACH(3),RIGHT(1)) - EQUIVALENCE (RMACH(4),DIVER(1)) - EQUIVALENCE (RMACH(5),LOG10(1)) -C -C -C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T -C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T -C PC 7300), SUN SPARCSTATIONS, SILICON GRAPHCS WORKSTATIONS, HP -C 9000 WORKSTATIONS, IBM RS/6000 WORKSTATIONS, AND 8087 BASED -C MICROS (E.G. IBM PC AND AT&T 6300). -C -C === MACHINE = ATT.3B -C === MACHINE = ATT.6300 -C === MACHINE = ATT.7300 -C === MACHINE = HP.9000 -C === MACHINE = IBM.PC -C === MACHINE = IBM.RS6000 -C === MACHINE = IEEE.MOST-SIG-BYTE-FIRST -C === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST -C === MACHINE = SGI -C === MACHINE = SUN -C === MACHINE = 68000 -C === MACHINE = 8087 - DATA SMALL(1) / 8388608 / - DATA LARGE(1) / 2139095039 / - DATA RIGHT(1) / 864026624 / - DATA DIVER(1) / 872415232 / - DATA LOG10(1) / 1050288283 / -C -C MACHINE CONSTANTS FOR SUN WORKSTATIONS. f77 WITH -r8 OPTION. -C MACHINE CONSTANTS FOR IBM RS/6000 WORKSTATIONS WITH -qautodbl=dblpad. -C -C === MACHINE = IBM.RS6000.XLF-WITH-AUTODBL-OPTION -C === MACHINE = SUN.F77-WITH-R8-OPTION -C DATA RMACH(1) / 2.2250738585072E-308 / -C DATA RMACH(2) / 1.7976931348623E308 / -C DATA RMACH(3) / 1.1102230246252E-16 / -C DATA RMACH(4) / 2.2204460492503E-16 / -C DATA RMACH(5) / 0.30102999566398 / -C -C MACHINE CONSTANTS FOR AMDAHL MACHINES. -C -C === MACHINE = AMDAHL -C DATA SMALL(1) / 1048576 / -C DATA LARGE(1) / 2147483647 / -C DATA RIGHT(1) / 990904320 / -C DATA DIVER(1) / 1007681536 / -C DATA LOG10(1) / 1091781651 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C === MACHINE = BURROUGHS.1700 -C DATA RMACH(1) / Z400800000 / -C DATA RMACH(2) / Z5FFFFFFFF / -C DATA RMACH(3) / Z4E9800000 / -C DATA RMACH(4) / Z4EA800000 / -C DATA RMACH(5) / Z500E730E8 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. -C -C === MACHINE = BURROUGHS.5700 -C === MACHINE = BURROUGHS.6700 -C === MACHINE = BURROUGHS.7700 -C DATA RMACH(1) / O1771000000000000 / -C DATA RMACH(2) / O0777777777777777 / -C DATA RMACH(3) / O1311000000000000 / -C DATA RMACH(4) / O1301000000000000 / -C DATA RMACH(5) / O1157163034761675 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES (NATIVE MODE) -C -C === MACHINE = CONVEX -C DATA RMACH(1) / 2.9387360E-39 / -C DATA RMACH(2) / 1.7014117E+38 / -C DATA RMACH(3) / 5.9604645E-08 / -C DATA RMACH(4) / 1.1920929E-07 / -C DATA RMACH(5) / 3.0102999E-01 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (NATIVE MODE) -C WITH -P8 OPTION -C -C === MACHINE = CONVEX.P8 -C DATA RMACH(1) / 5.562684646268007E-309 / -C DATA RMACH(2) / 8.988465674311577E+307 / -C DATA RMACH(3) / 1.110223024625157E-016 / -C DATA RMACH(4) / 2.220446049250313E-016 / -C DATA RMACH(5) / 3.010299956639812E-001 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (IEEE MODE) -C -C === MACHINE = CONVEX.IEEE -C DATA RMACH(1) / 1.1754945E-38 / -C DATA RMACH(2) / 3.4028234E+38 / -C DATA RMACH(3) / 5.9604645E-08 / -C DATA RMACH(4) / 1.1920929E-07 / -C DATA RMACH(5) / 3.0102999E-01 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (IEEE MODE) -C WITH -P8 OPTION -C -C === MACHINE = CONVEX.IEEE.P8 -C DATA RMACH(1) / 2.225073858507202E-308 / -C DATA RMACH(2) / 1.797693134862315E+308 / -C DATA RMACH(3) / 1.110223024625157E-016 / -C DATA RMACH(4) / 2.220446049250313E-016 / -C DATA RMACH(5) / 3.010299956639812E-001 / -C -C MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5). -C -C === MACHINE = CYBER.170.NOS -C === MACHINE = CYBER.180.NOS -C DATA RMACH(1) / O"00014000000000000000" / -C DATA RMACH(2) / O"37767777777777777777" / -C DATA RMACH(3) / O"16404000000000000000" / -C DATA RMACH(4) / O"16414000000000000000" / -C DATA RMACH(5) / O"17164642023241175720" / -C -C MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE -C -C === MACHINE = CYBER.180.NOS/VE -C DATA RMACH(1) / Z"3001800000000000" / -C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / -C DATA RMACH(3) / Z"3FD2800000000000" / -C DATA RMACH(4) / Z"3FD3800000000000" / -C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / -C -C MACHINE CONSTANTS FOR THE CYBER 205 -C -C === MACHINE = CYBER.205 -C DATA RMACH(1) / X'9000400000000000' / -C DATA RMACH(2) / X'6FFF7FFFFFFFFFFF' / -C DATA RMACH(3) / X'FFA3400000000000' / -C DATA RMACH(4) / X'FFA4400000000000' / -C DATA RMACH(5) / X'FFD04D104D427DE8' / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. -C -C === MACHINE = CDC.6000 -C === MACHINE = CDC.7000 -C DATA RMACH(1) / 00014000000000000000B / -C DATA RMACH(2) / 37767777777777777777B / -C DATA RMACH(3) / 16404000000000000000B / -C DATA RMACH(4) / 16414000000000000000B / -C DATA RMACH(5) / 17164642023241175720B / -C -C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. -C -C === MACHINE = CRAY.46-BIT-INTEGER -C === MACHINE = CRAY.64-BIT-INTEGER -C DATA RMACH(1) / 200034000000000000000B / -C DATA RMACH(2) / 577767777777777777776B / -C DATA RMACH(3) / 377224000000000000000B / -C DATA RMACH(4) / 377234000000000000000B / -C DATA RMACH(5) / 377774642023241175720B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - -C STATIC RMACH(5) -C -C === MACHINE = DATA_GENERAL.ECLIPSE.S/200 -C DATA SMALL/20K,0/,LARGE/77777K,177777K/ -C DATA RIGHT/35420K,0/,DIVER/36020K,0/ -C DATA LOG10/40423K,42023K/ -C -C ELXSI 6400 -C -C === MACHINE = ELSXI.6400 -C DATA SMALL(1) / '00800000'X / -C DATA LARGE(1) / '7F7FFFFF'X / -C DATA RIGHT(1) / '33800000'X / -C DATA DIVER(1) / '34000000'X / -C DATA LOG10(1) / '3E9A209B'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 -C -C === MACHINE = HARRIS.220 -C === MACHINE = HARRIS.SLASH6 -C === MACHINE = HARRIS.SLASH7 -C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1),LARGE(2) / '37777777, '00000177 / -C DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 / -C DATA DIVER(1),DIVER(2) / '20000000, '00000353 / -C DATA LOG10(1),LOG10(2) / '23210115, '00000377 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. -C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. -C -C === MACHINE = HONEYWELL.600/6000 -C === MACHINE = HONEYWELL.DPS.8/70 -C DATA RMACH(1) / O402400000000 / -C DATA RMACH(2) / O376777777777 / -C DATA RMACH(3) / O714400000000 / -C DATA RMACH(4) / O716400000000 / -C DATA RMACH(5) / O776464202324 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION WITH FTN4 -C -C === MACHINE = HP.2100.3_WORD_DP -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION WITH FTN4 -C -C === MACHINE = HP.2100.4_WORD_DP -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE91), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND -C THE INTERDATA 3230 AND INTERDATA 7/32. -C -C === MACHINE = IBM.360 -C === MACHINE = IBM.370 -C === MACHINE = XEROX.SIGMA.5 -C === MACHINE = XEROX.SIGMA.7 -C === MACHINE = XEROX.SIGMA.9 -C === MACHINE = SEL.85 -C === MACHINE = SEL.86 -C === MACHINE = INTERDATA.3230 -C === MACHINE = INTERDATA.7/32 -C DATA RMACH(1) / Z00100000 / -C DATA RMACH(2) / Z7FFFFFFF / -C DATA RMACH(3) / Z3B100000 / -C DATA RMACH(4) / Z3C100000 / -C DATA RMACH(5) / Z41134413 / -C -C MACHINE CONSTANTS FOR THE INTERDATA 8/32 -C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. -C -C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE -C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. -C -C === MACHINE = INTERDATA.8/32.UNIX -C DATA RMACH(1) / Z'00100000' / -C DATA RMACH(2) / Z'7EFFFFFF' / -C DATA RMACH(3) / Z'3B100000' / -C DATA RMACH(4) / Z'3C100000' / -C DATA RMACH(5) / Z'41134413' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). -C -C === MACHINE = PDP-10.KA -C === MACHINE = PDP-10.KI -C DATA RMACH(1) / "000400000000 / -C DATA RMACH(2) / "377777777777 / -C DATA RMACH(3) / "146400000000 / -C DATA RMACH(4) / "147400000000 / -C DATA RMACH(5) / "177464202324 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C === MACHINE = PDP-11.32-BIT -C DATA SMALL(1) / 8388608 / -C DATA LARGE(1) / 2147483647 / -C DATA RIGHT(1) / 880803840 / -C DATA DIVER(1) / 889192448 / -C DATA LOG10(1) / 1067065499 / -C -C DATA RMACH(1) / O00040000000 / -C DATA RMACH(2) / O17777777777 / -C DATA RMACH(3) / O06440000000 / -C DATA RMACH(4) / O06500000000 / -C DATA RMACH(5) / O07746420233 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C === MACHINE = PDP-11.16-BIT -C DATA SMALL(1),SMALL(2) / 128, 0 / -C DATA LARGE(1),LARGE(2) / 32767, -1 / -C DATA RIGHT(1),RIGHT(2) / 13440, 0 / -C DATA DIVER(1),DIVER(2) / 13568, 0 / -C DATA LOG10(1),LOG10(2) / 16282, 8347 / -C -C DATA SMALL(1),SMALL(2) / O000200, O000000 / -C DATA LARGE(1),LARGE(2) / O077777, O177777 / -C DATA RIGHT(1),RIGHT(2) / O032200, O000000 / -C DATA DIVER(1),DIVER(2) / O032400, O000000 / -C DATA LOG10(1),LOG10(2) / O037632, O020233 / -C -C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. -C -C === MACHINE = SEQUENT.BALANCE.8000 -C DATA SMALL(1) / $00800000 / -C DATA LARGE(1) / $7F7FFFFF / -C DATA RIGHT(1) / $33800000 / -C DATA DIVER(1) / $34000000 / -C DATA LOG10(1) / $3E9A209B / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C === MACHINE = UNIVAC.1100 -C DATA RMACH(1) / O000400000000 / -C DATA RMACH(2) / O377777777777 / -C DATA RMACH(3) / O146400000000 / -C DATA RMACH(4) / O147400000000 / -C DATA RMACH(5) / O177464202324 / -C -C MACHINE CONSTANTS FOR THE VAX 11/780 -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** -C -C === MACHINE = VAX.11/780 -C DATA SMALL(1) / 128 / -C DATA LARGE(1) / -32769 / -C DATA RIGHT(1) / 13440 / -C DATA DIVER(1) / 13568 / -C DATA LOG10(1) / 547045274 / -C -C ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS*** -C -C DATA SMALL(1) / Z00000080 / -C DATA LARGE(1) / ZFFFF7FFF / -C DATA RIGHT(1) / Z00003480 / -C DATA DIVER(1) / Z00003500 / -C DATA LOG10(1) / Z209B3F9A / -C -C -C***FIRST EXECUTABLE STATEMENT R1MACH -C - R1MACH = RMACH(I) - RETURN -C - END //GO.SYSIN DD src/r1mach.f echo src/r1mach8.f 1>&2 sed >src/r1mach8.f <<'//GO.SYSIN DD src/r1mach8.f' 's/^-//' - REAL FUNCTION R1MACH(I) -C***BEGIN PROLOGUE R1MACH -C***DATE WRITTEN 790101 (YYMMDD) -C***REVISION DATE 860825 (YYMMDD) -C***CATEGORY NO. R1 -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR FOX, P. A., (BELL LABS) -C HALL, A. D., (BELL LABS) -C SCHRYER, N. L., (BELL LABS) -C***PURPOSE Returns single precision machine dependent constants -C***DESCRIPTION -C -C This is the CMLIB version of R1MACH, the real machine -C constants subroutine originally developed for the PORT library. -C -C R1MACH can be used to obtain machine-dependent parameters -C for the local machine environment. It is a function -C subroutine with one (input) argument, and can be called -C as follows, for example -C -C A = R1MACH(I) -C -C where I=1,...,5. The (output) value of A above is -C determined by the (input) value of I. The results for -C various values of I are discussed below. -C -C Single-Precision Machine Constants -C R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. -C R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C R1MACH(3) = B**(-T), the smallest relative spacing. -C R1MACH(4) = B**(1-T), the largest relative spacing. -C R1MACH(5) = LOG10(B) -C***REFERENCES FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR -C A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE- -C MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978, -C PP. 177-188. -C***ROUTINES CALLED XERROR -C***END PROLOGUE R1MACH -C - INTEGER SMALL(2) - INTEGER LARGE(2) - INTEGER RIGHT(2) - INTEGER DIVER(2) - INTEGER LOG10(2) -C - REAL RMACH(5) -C - EQUIVALENCE (RMACH(1),SMALL(1)) - EQUIVALENCE (RMACH(2),LARGE(1)) - EQUIVALENCE (RMACH(3),RIGHT(1)) - EQUIVALENCE (RMACH(4),DIVER(1)) - EQUIVALENCE (RMACH(5),LOG10(1)) -C -C -C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T -C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T -C PC 7300), SUN SPARCSTATIONS, SILICON GRAPHCS WORKSTATIONS, HP -C 9000 WORKSTATIONS, IBM RS/6000 WORKSTATIONS, AND 8087 BASED -C MICROS (E.G. IBM PC AND AT&T 6300). -C -C === MACHINE = ATT.3B -C === MACHINE = ATT.6300 -C === MACHINE = ATT.7300 -C === MACHINE = HP.9000 -C === MACHINE = IBM.PC -C === MACHINE = IBM.RS6000 -C === MACHINE = IEEE.MOST-SIG-BYTE-FIRST -C === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST -C === MACHINE = SGI -C === MACHINE = SUN -C === MACHINE = 68000 -C === MACHINE = 8087 -C DATA SMALL(1) / 8388608 / -C DATA LARGE(1) / 2139095039 / -C DATA RIGHT(1) / 864026624 / -C DATA DIVER(1) / 872415232 / -C DATA LOG10(1) / 1050288283 / -C -C MACHINE CONSTANTS FOR SUN WORKSTATIONS. f77 WITH -r8 OPTION. -C MACHINE CONSTANTS FOR IBM RS/6000 WORKSTATIONS WITH -qautodbl=dblpad. -C -C === MACHINE = IBM.RS6000.XLF-WITH-AUTODBL-OPTION -C === MACHINE = SUN.F77-WITH-R8-OPTION - DATA RMACH(1) / 2.2250738585072E-308 / - DATA RMACH(2) / 1.7976931348623E308 / - DATA RMACH(3) / 1.1102230246252E-16 / - DATA RMACH(4) / 2.2204460492503E-16 / - DATA RMACH(5) / 0.30102999566398 / -C -C MACHINE CONSTANTS FOR AMDAHL MACHINES. -C -C === MACHINE = AMDAHL -C DATA SMALL(1) / 1048576 / -C DATA LARGE(1) / 2147483647 / -C DATA RIGHT(1) / 990904320 / -C DATA DIVER(1) / 1007681536 / -C DATA LOG10(1) / 1091781651 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C === MACHINE = BURROUGHS.1700 -C DATA RMACH(1) / Z400800000 / -C DATA RMACH(2) / Z5FFFFFFFF / -C DATA RMACH(3) / Z4E9800000 / -C DATA RMACH(4) / Z4EA800000 / -C DATA RMACH(5) / Z500E730E8 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. -C -C === MACHINE = BURROUGHS.5700 -C === MACHINE = BURROUGHS.6700 -C === MACHINE = BURROUGHS.7700 -C DATA RMACH(1) / O1771000000000000 / -C DATA RMACH(2) / O0777777777777777 / -C DATA RMACH(3) / O1311000000000000 / -C DATA RMACH(4) / O1301000000000000 / -C DATA RMACH(5) / O1157163034761675 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES (NATIVE MODE) -C -C === MACHINE = CONVEX -C DATA RMACH(1) / 2.9387360E-39 / -C DATA RMACH(2) / 1.7014117E+38 / -C DATA RMACH(3) / 5.9604645E-08 / -C DATA RMACH(4) / 1.1920929E-07 / -C DATA RMACH(5) / 3.0102999E-01 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (NATIVE MODE) -C WITH -P8 OPTION -C -C === MACHINE = CONVEX.P8 -C DATA RMACH(1) / 5.562684646268007E-309 / -C DATA RMACH(2) / 8.988465674311577E+307 / -C DATA RMACH(3) / 1.110223024625157E-016 / -C DATA RMACH(4) / 2.220446049250313E-016 / -C DATA RMACH(5) / 3.010299956639812E-001 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (IEEE MODE) -C -C === MACHINE = CONVEX.IEEE -C DATA RMACH(1) / 1.1754945E-38 / -C DATA RMACH(2) / 3.4028234E+38 / -C DATA RMACH(3) / 5.9604645E-08 / -C DATA RMACH(4) / 1.1920929E-07 / -C DATA RMACH(5) / 3.0102999E-01 / -C -C MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 (IEEE MODE) -C WITH -P8 OPTION -C -C === MACHINE = CONVEX.IEEE.P8 -C DATA RMACH(1) / 2.225073858507202E-308 / -C DATA RMACH(2) / 1.797693134862315E+308 / -C DATA RMACH(3) / 1.110223024625157E-016 / -C DATA RMACH(4) / 2.220446049250313E-016 / -C DATA RMACH(5) / 3.010299956639812E-001 / -C -C MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5). -C -C === MACHINE = CYBER.170.NOS -C === MACHINE = CYBER.180.NOS -C DATA RMACH(1) / O"00014000000000000000" / -C DATA RMACH(2) / O"37767777777777777777" / -C DATA RMACH(3) / O"16404000000000000000" / -C DATA RMACH(4) / O"16414000000000000000" / -C DATA RMACH(5) / O"17164642023241175720" / -C -C MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE -C -C === MACHINE = CYBER.180.NOS/VE -C DATA RMACH(1) / Z"3001800000000000" / -C DATA RMACH(2) / Z"4FFEFFFFFFFFFFFE" / -C DATA RMACH(3) / Z"3FD2800000000000" / -C DATA RMACH(4) / Z"3FD3800000000000" / -C DATA RMACH(5) / Z"3FFF9A209A84FBCF" / -C -C MACHINE CONSTANTS FOR THE CYBER 205 -C -C === MACHINE = CYBER.205 -C DATA RMACH(1) / X'9000400000000000' / -C DATA RMACH(2) / X'6FFF7FFFFFFFFFFF' / -C DATA RMACH(3) / X'FFA3400000000000' / -C DATA RMACH(4) / X'FFA4400000000000' / -C DATA RMACH(5) / X'FFD04D104D427DE8' / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. -C -C === MACHINE = CDC.6000 -C === MACHINE = CDC.7000 -C DATA RMACH(1) / 00014000000000000000B / -C DATA RMACH(2) / 37767777777777777777B / -C DATA RMACH(3) / 16404000000000000000B / -C DATA RMACH(4) / 16414000000000000000B / -C DATA RMACH(5) / 17164642023241175720B / -C -C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. -C -C === MACHINE = CRAY.46-BIT-INTEGER -C === MACHINE = CRAY.64-BIT-INTEGER -C DATA RMACH(1) / 200034000000000000000B / -C DATA RMACH(2) / 577767777777777777776B / -C DATA RMACH(3) / 377224000000000000000B / -C DATA RMACH(4) / 377234000000000000000B / -C DATA RMACH(5) / 377774642023241175720B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - -C STATIC RMACH(5) -C -C === MACHINE = DATA_GENERAL.ECLIPSE.S/200 -C DATA SMALL/20K,0/,LARGE/77777K,177777K/ -C DATA RIGHT/35420K,0/,DIVER/36020K,0/ -C DATA LOG10/40423K,42023K/ -C -C ELXSI 6400 -C -C === MACHINE = ELSXI.6400 -C DATA SMALL(1) / '00800000'X / -C DATA LARGE(1) / '7F7FFFFF'X / -C DATA RIGHT(1) / '33800000'X / -C DATA DIVER(1) / '34000000'X / -C DATA LOG10(1) / '3E9A209B'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 -C -C === MACHINE = HARRIS.220 -C === MACHINE = HARRIS.SLASH6 -C === MACHINE = HARRIS.SLASH7 -C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1),LARGE(2) / '37777777, '00000177 / -C DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 / -C DATA DIVER(1),DIVER(2) / '20000000, '00000353 / -C DATA LOG10(1),LOG10(2) / '23210115, '00000377 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. -C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. -C -C === MACHINE = HONEYWELL.600/6000 -C === MACHINE = HONEYWELL.DPS.8/70 -C DATA RMACH(1) / O402400000000 / -C DATA RMACH(2) / O376777777777 / -C DATA RMACH(3) / O714400000000 / -C DATA RMACH(4) / O716400000000 / -C DATA RMACH(5) / O776464202324 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION WITH FTN4 -C -C === MACHINE = HP.2100.3_WORD_DP -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION WITH FTN4 -C -C === MACHINE = HP.2100.4_WORD_DP -C DATA SMALL(1), SMALL(2) / 40000B, 1 / -C DATA LARGE91), LARGE(2) / 77777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / -C DATA DIVER(1), DIVER(2) / 40000B, 327B / -C DATA LOG10(1), LOG10(2) / 46420B, 46777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND -C THE INTERDATA 3230 AND INTERDATA 7/32. -C -C === MACHINE = IBM.360 -C === MACHINE = IBM.370 -C === MACHINE = XEROX.SIGMA.5 -C === MACHINE = XEROX.SIGMA.7 -C === MACHINE = XEROX.SIGMA.9 -C === MACHINE = SEL.85 -C === MACHINE = SEL.86 -C === MACHINE = INTERDATA.3230 -C === MACHINE = INTERDATA.7/32 -C DATA RMACH(1) / Z00100000 / -C DATA RMACH(2) / Z7FFFFFFF / -C DATA RMACH(3) / Z3B100000 / -C DATA RMACH(4) / Z3C100000 / -C DATA RMACH(5) / Z41134413 / -C -C MACHINE CONSTANTS FOR THE INTERDATA 8/32 -C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. -C -C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE -C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. -C -C === MACHINE = INTERDATA.8/32.UNIX -C DATA RMACH(1) / Z'00100000' / -C DATA RMACH(2) / Z'7EFFFFFF' / -C DATA RMACH(3) / Z'3B100000' / -C DATA RMACH(4) / Z'3C100000' / -C DATA RMACH(5) / Z'41134413' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). -C -C === MACHINE = PDP-10.KA -C === MACHINE = PDP-10.KI -C DATA RMACH(1) / "000400000000 / -C DATA RMACH(2) / "377777777777 / -C DATA RMACH(3) / "146400000000 / -C DATA RMACH(4) / "147400000000 / -C DATA RMACH(5) / "177464202324 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C === MACHINE = PDP-11.32-BIT -C DATA SMALL(1) / 8388608 / -C DATA LARGE(1) / 2147483647 / -C DATA RIGHT(1) / 880803840 / -C DATA DIVER(1) / 889192448 / -C DATA LOG10(1) / 1067065499 / -C -C DATA RMACH(1) / O00040000000 / -C DATA RMACH(2) / O17777777777 / -C DATA RMACH(3) / O06440000000 / -C DATA RMACH(4) / O06500000000 / -C DATA RMACH(5) / O07746420233 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C === MACHINE = PDP-11.16-BIT -C DATA SMALL(1),SMALL(2) / 128, 0 / -C DATA LARGE(1),LARGE(2) / 32767, -1 / -C DATA RIGHT(1),RIGHT(2) / 13440, 0 / -C DATA DIVER(1),DIVER(2) / 13568, 0 / -C DATA LOG10(1),LOG10(2) / 16282, 8347 / -C -C DATA SMALL(1),SMALL(2) / O000200, O000000 / -C DATA LARGE(1),LARGE(2) / O077777, O177777 / -C DATA RIGHT(1),RIGHT(2) / O032200, O000000 / -C DATA DIVER(1),DIVER(2) / O032400, O000000 / -C DATA LOG10(1),LOG10(2) / O037632, O020233 / -C -C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. -C -C === MACHINE = SEQUENT.BALANCE.8000 -C DATA SMALL(1) / $00800000 / -C DATA LARGE(1) / $7F7FFFFF / -C DATA RIGHT(1) / $33800000 / -C DATA DIVER(1) / $34000000 / -C DATA LOG10(1) / $3E9A209B / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C === MACHINE = UNIVAC.1100 -C DATA RMACH(1) / O000400000000 / -C DATA RMACH(2) / O377777777777 / -C DATA RMACH(3) / O146400000000 / -C DATA RMACH(4) / O147400000000 / -C DATA RMACH(5) / O177464202324 / -C -C MACHINE CONSTANTS FOR THE VAX 11/780 -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** -C -C === MACHINE = VAX.11/780 -C DATA SMALL(1) / 128 / -C DATA LARGE(1) / -32769 / -C DATA RIGHT(1) / 13440 / -C DATA DIVER(1) / 13568 / -C DATA LOG10(1) / 547045274 / -C -C ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS*** -C -C DATA SMALL(1) / Z00000080 / -C DATA LARGE(1) / ZFFFF7FFF / -C DATA RIGHT(1) / Z00003480 / -C DATA DIVER(1) / Z00003500 / -C DATA LOG10(1) / Z209B3F9A / -C -C -C***FIRST EXECUTABLE STATEMENT R1MACH -C - R1MACH = RMACH(I) - RETURN -C - END //GO.SYSIN DD src/r1mach8.f echo src/makefile.irix 1>&2 sed >src/makefile.irix <<'//GO.SYSIN DD src/makefile.irix' 's/^-//' -SHELL = /bin/sh -# LINPACK and DLINPACK need to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me -DLINPACK = dfix.me - -FFLAGS = -O2 -CFLAGS = -O -F77 = f77 -CC = cc -DOUBLE = -r8 - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: $(DLINPACK) commons makefile mgghat8.o user8.o second8.o \ - gnuplt.o - $(F77) $(FFLAGS) $(DOUBLE) -o mgghat \ - mgghat8.o user8.o second8.o gnuplt.o \ - $(DLINPACK) - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.f - $(F77) $(FFLAGS) -c second.f - -mgghat8.o: commons makefile mgghat.f - $(F77) $(FFLAGS) $(DOUBLE) -c mgghat.f -o mgghat8.o - -user8.o: commons makefile user.f - $(F77) $(FFLAGS) $(DOUBLE) -c user.f -o user8.o - -second8.o: commons makefile second.f - $(F77) $(FFLAGS) $(DOUBLE) -c second.f -o second8.o - -gnuplt.o: commons makefile gnuplt.c - $(CC) $(CFLAGS) -c gnuplt.c - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi - -$(DLINPACK): makefile r1mach8.f - @if [ "$@" = "dfix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c r1mach8.f ; \ - else if [ "$@" = "linpack8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c linpack.f -o linpack8.o; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.irix echo src/makefile.aix 1>&2 sed >src/makefile.aix <<'//GO.SYSIN DD src/makefile.aix' 's/^-//' -SHELL = /bin/sh -# LINPACK and DLINPACK need to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me -DLINPACK = dfix.me - -FFLAGS = -O3 -CFLAGS = -O3 -F77 = xlf -CC = cc -DOUBLE = -qautodbl=dblpad - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: $(DLINPACK) commons makefile mgghat8.o user8.o second8.o \ - gnuplt.o - $(F77) $(FFLAGS) $(DOUBLE) -o mgghat \ - mgghat8.o user8.o second8.o gnuplt.o \ - $(DLINPACK) - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.aix.f - $(F77) $(FFLAGS) -c second.aix.f -o second.o - -mgghat8.o: commons makefile mgghat.f - $(F77) $(FFLAGS) $(DOUBLE) -c mgghat.f -o mgghat8.o - -user8.o: commons makefile user.f - $(F77) $(FFLAGS) $(DOUBLE) -c user.f -o user8.o - -second8.o: commons makefile second.aix.f - $(F77) $(FFLAGS) $(DOUBLE) -c second.aix.f -o second8.o - -gnuplt.o: commons makefile gnuplt.no_.c - $(CC) $(CFLAGS) -c gnuplt.no_.c -o gnuplt.o - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi - -$(DLINPACK): makefile r1mach8.f - @if [ "$@" = "dfix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c r1mach8.f ; \ - else if [ "$@" = "linpack8.o" ] ; then \ - $(F77) $(FFLAGS) $(DOUBLE) -c linpack.f -o linpack8.o; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.aix echo src/user.f.timedep 1>&2 sed >src/user.f.timedep <<'//GO.SYSIN DD src/user.f.timedep' 's/^-//' -c This is an example 'main' program for calling MGGHAT -c -c This example illustrates how to use MGGHAT to solve a time -c dependent problem of the form -c -c du/dt = Lu + F(x,y,t) (x,y) in R, t > t0 -c u = g(x,y,t) (x,y) on boundary of R, t > t0 -c (or natural or mixed conditions) -c u = u0(x,y) (x,y) in closure of R, t = t0 -c -c where R is a 2D region, and L is a linear elliptic operator. -c -c The Crank-Nicolson discretization of the time derivative is -c taken from Section 5.D of "Solving Elliptic Problems Using ELLPACK", -c J.R. Rice and R.F. Boisvert, Springer-Verlag, 1985. -c -c The Crank-Nicolson discretization of du/dt leads to the -c linear elliptic PDE -c -c Lu(x,y,t) - (2/k)u(x,y,t) = -c -(2/k)u(x,y,t-k) - Lu(x,y,t-k) - F(x,y,t) - F(x,y,t-k) -c -c where k is the time step, a.k.a. delta t -c -c This example solves the heat equation on a square plate consisting of -c two materials, insulated on three sides and with a perfect heat sink -c on the fourth side. During time = 0 to time = 1, a spike of heat -c grows and dies out on the heat sink side. One material is -c a much slower conductor of heat. -c -c The equation is dU/dt = c*(Uxx+Uyy) in the unit square where -c c = 1. over most of the square, and c=.1 for .5 1. -c U = sin(pi*t)*exp(-100.*(x-.5)**2) on the bottom for 01 -c - if (ipiece.eq.2) then - itype = 1 - c = 0. - if (curtim .le. 1.) then - g = sin(pi*curtim)*exp(-100.*(x-.5)*(x-.5)) - else - g = 0. - endif -c -c on the other sides, use homogeneous neumann, i.e., insulated -c - else - itype = 2 - c = 0. - g = 0. - endif -c - return - end -c -c the true solution is not known, so set true=truex=truey=0. -c -c -------- true -c - real function true(x,y) - include 'commons' - real x,y - true = 0. - return - end -c -c -------- truex -c - real function truex(x,y) - include 'commons' - real x,y - truex=0. - return - end -c -c -------- truey -c - real function truey(x,y) - include 'commons' - real x,y - truey = 0. - return - end -c -c inittr -- set initial triangulation -c There are no changes in this routine, w.r.t user.f.poisson -c - subroutine inittr - include 'commons' -c -c rectangular domain (ax,bx) X (ay,by) with an ngridx X ngridy grid -c - ax = 0. - bx = 1. - ay = 0. - by = 1. - ngridx = 2 - ngridy = 2 -c - if (outlev.ge.3) write(ioutpt,101) ax,bx,ay,by - 101 format(' begin initializing triangulation'/ - . ' triangulation for rectangle (',f8.2, - . ',',f8.2,') X (',f8.2,',',f8.2,')') -c -c set initial triangulation -c -c this is a user provided routine to define the domain and -c the initial triangulation -c -c the user provides: -c -c nvert - number of vertices -c ntri - number of triangles -c xvert(1..nvert),yvert(1..nvert) - x and y coordinates -c of the vertices -c vertex(1..3,1..ntri) - the 3 vertices of each triangle -c neigh(i,1..ntri) - which piece of the boundary contains the triangle -c side opposite vertex i. Need not be set if -c that side is not on the domain boundary. -c -c the peak of each triangle is the third vertex, i.e., -c peak(triangle)=vertex(3,triangle) -c -c assumptions on the triangulation are: -c -c 1) each vertex is in the same position (first, second, or third) -c in every triangle that contains it, e.g., if vertex 2 is -c the first vertex of triangle 3 (vertex(1,3)=2). vertex 2 must -c also be the first vertex of any other triangle containing it. -c thus we can have vertex(1,4)=2, and cannot have vertex(2,4)=2 -c -c 2) vertices which are first or second vertices can be in at most -c 8 triangles. vertices which are third vertices (peaks) can -c be in at most 4 triangles -c -c This version of the routine triangulates the rectangle (ax,bx)X(ay,by). -c ngridx and ngridy specify the number of intervals in each dimension. -c The boundary pieces (ipiece for subroutine bcond) are: -c 1 - left -c 2 - bottom -c 3 - right -c 4 - top -c -c for the case of a 4X4 grid, the vertex and triangle numbers are: -c -c 5---10---15---20---25 -c |\ | /|\ | /| -c | \ 8|15/ | \24|31/ | -c | 7\ | /16|23\ | /32| -c | \|/ | \|/ | -c 4----9---14---19---24 -c | /|\ | /|\ | -c | 5/ | \14|21/ | \30| -c | /6 |13\ | /22|29\ | -c |/ | \|/ | \| -c 3----8---13---18---23 -c |\ | /|\ | /| -c | \4 |11/ | \20|27/ | -c | 3\ | /12|19\ | /28| -c | \|/ | \|/ | -c 2----7---12---17---22 -c | /|\ | /|\ | -c | 1/ | \10|17/ | \26| -c | /2 | 9\ | /18|25\ | -c |/ | \|/ | \| -c 1----6---11---16---21 -c - dy = by-ay - dx = bx-ax - dy = dy/ngridy - dx = dx/ngridx -c -c set number of triangles and vertices -c - nvert = (ngridx+1)*(ngridy+1) - ntri = 2*ngridx*ngridy -c -c set coordinates of vertices -c - k=0 - do 11 i=1,ngridx+1 - xtemp=ax+(i-1)*dx - if (i.eq.ngridx+1) xtemp=bx - do 10 j=1,ngridy+1 - k=k+1 - xvert(k)=xtemp - yvert(k)=ay+(j-1)*dy - if (j.eq.ngridy+1) yvert(k)=by - 10 continue - 11 continue -c -c set vertices and boundary pieces of triangles -c - do 21 i=1,ngridx,2 - do 20 j=1,ngridy,2 - ivbase=(i-1)*(ngridy+1)+j - itbase=2*((i-1)*ngridy+j)-1 - vertex(1,itbase) = ivbase+ngridy+2 - vertex(2,itbase) = ivbase - vertex(3,itbase) = ivbase+1 - if (i.eq.1) neigh(1,itbase) = -1 - if (j.eq.ngridy) neigh(2,itbase) = -4 - vertex(1,itbase+1) = ivbase+ngridy+2 - vertex(2,itbase+1) = ivbase - vertex(3,itbase+1) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+1) = -2 - if (i.eq.ngridx) neigh(2,itbase+1) = -3 - if (j.ne.ngridy) then - vertex(1,itbase+2) = ivbase+ngridy+2 - vertex(2,itbase+2) = ivbase+2 - vertex(3,itbase+2) = ivbase+1 - if (i.eq.1) neigh(1,itbase+2) = -1 - vertex(1,itbase+3) = ivbase+ngridy+2 - vertex(2,itbase+3) = ivbase+2 - vertex(3,itbase+3) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+3) = -4 - if (i.eq.ngridx) neigh(2,itbase+3) = -3 - endif - if (i.ne.ngridx) then - vertex(1,itbase+2*ngridy) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy) = ivbase+ngridy+1 - if (j.eq.1) neigh(1,itbase+2*ngridy) = -2 - vertex(1,itbase+2*ngridy+1) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+1) = ivbase+2*ngridy+2 - vertex(3,itbase+2*ngridy+1) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+1) = -3 - if (j.eq.ngridy) neigh(2,itbase+2*ngridy+1) = -4 - if (j.ne.ngridy) then - vertex(1,itbase+2*ngridy+2) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+2) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+2) = ivbase+ngridy+3 - if (j.eq.ngridy-1) neigh(1,itbase+2*ngridy+2) = -4 - vertex(1,itbase+2*ngridy+3) = ivbase+ngridy+2 - vertex(2,itbase+2*ngridy+3) = ivbase+2*ngridy+4 - vertex(3,itbase+2*ngridy+3) = ivbase+2*ngridy+3 - if (i.eq.ngridx-1) neigh(1,itbase+2*ngridy+3) = -3 - endif - endif - 20 continue - 21 continue -c - if (outlev.ge.3) then - write(ioutpt,102) ngridx,ngridy,ntri,nvert - 102 format(' grid lines ',i3,'X',i3/ - 1 ' triangles ',i5/ - 2 ' vertices ',i5/ - 3 ' initial triangulation complete') - endif - return - end //GO.SYSIN DD src/user.f.timedep echo src/makefile.linux 1>&2 sed >src/makefile.linux <<'//GO.SYSIN DD src/makefile.linux' 's/^-//' -SHELL = /bin/sh -# LINPACK needs to be properly assigned to the -# linpack and blas library or source code. See the file -# mgghat/doc/install.ascii for instructions. - -LINPACK = fix.me - -FFLAGS = -O3 -CFLAGS = -O -F77 = f77 -CC = gcc -DOUBLE = - -mgghat: $(LINPACK) commons makefile mgghat.o user.o second.o \ - gnuplt.o - $(F77) $(FFLAGS) -o mgghat \ - mgghat.o user.o second.o gnuplt.o \ - $(LINPACK) - -double: - @echo "auto double does not work on linux f77" - -clean: - rm -f core *.trace mgghat *.o gp*.dat - -mgghat.o: commons makefile mgghat.f - $(F77) $(FFLAGS) -c mgghat.f - -user.o: commons makefile user.f - $(F77) $(FFLAGS) -c user.f - -second.o: commons makefile second.c - $(CC) $(CLAGS) -c second.c -o second.o - -gnuplt.o: commons makefile gnuplt.c - $(CC) $(CFLAGS) -c gnuplt.c -o gnuplt.o - -# The following looks rather complicated, but here's what's -# going on. This allows the use of $LINPACK as -l library, -# sources.o, a mixture of the two, or "fix.me" which says the -# user has not corrected the makefile yet. The value of -# $LINPACK becomes a list of targets. For each target, if its -# "fix.me" an error message, in the file need.setup, is printed -# and we stop. If the target is r1mach.o or linpack.o, the -# usual fortran compilation is performed. Otherwise, nothing -# is done (it should be a library specification). - -$(LINPACK): makefile r1mach.f - @if [ "$@" = "fix.me" ] ; then \ - need.setup ; \ - exit 1 ; \ - else if [ "$@" = "r1mach.o" ] ; then \ - $(F77) $(FFLAGS) -c r1mach.f ; \ - else if [ "$@" = "linpack.o" ] ; then \ - $(F77) $(FFLAGS) -c linpack.f ; \ - fi ; fi ; fi //GO.SYSIN DD src/makefile.linux