Rocstar  1.0
Rocstar multiphysics simulation application
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Friends Macros Groups Pages
RFLU_ModRepair3D.F90
Go to the documentation of this file.
1 ! *********************************************************************
2 ! * Rocstar Simulation Suite *
3 ! * Copyright@2015, Illinois Rocstar LLC. All rights reserved. *
4 ! * *
5 ! * Illinois Rocstar LLC *
6 ! * Champaign, IL *
7 ! * www.illinoisrocstar.com *
8 ! * sales@illinoisrocstar.com *
9 ! * *
10 ! * License: See LICENSE file in top level of distribution package or *
11 ! * http://opensource.org/licenses/NCSA *
12 ! *********************************************************************
13 ! *********************************************************************
14 ! * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, *
15 ! * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES *
16 ! * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND *
17 ! * NONINFRINGEMENT. IN NO EVENT SHALL THE CONTRIBUTORS OR *
18 ! * COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *
19 ! * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, *
20 ! * Arising FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE *
21 ! * USE OR OTHER DEALINGS WITH THE SOFTWARE. *
22 ! *********************************************************************
23 !******************************************************************************
24 !
25 ! Purpose: Modify mesh to conform to boundary displacement using routines
26 ! provided by Tim Baker.
27 !
28 ! Description: None.
29 !
30 ! Input:
31 ! pRegion Pointer to region
32 !
33 ! Output: None.
34 !
35 ! Notes:
36 ! 0. Compile this in fixed format, hence use .f extension, otherwise does
37 ! not compile...
38 ! 1. Noteworthy changes from Tim Bakers original routines:
39 ! - Routine SECOND and all calls and associated FORMAT statements
40 ! commented out.
41 ! - In a few places, cleaned out segments of code which Tim commented out.
42 ! 2. Original code assumes implicit typing - AARGH! Changed only routine
43 ! RFLU_Repair3D to use IMPLICIT NONE.
44 ! 3. Current routine RFLU_Repair3D was originally PROGRAM Repair3D.
45 ! 4. All routines are restricted to tetrahedra.
46 !
47 !******************************************************************************
48 !
49 ! $Id: RFLU_ModRepair3D.F90,v 1.4 2008/12/06 08:44:23 mtcampbe Exp $
50 !
51 ! Copyright: (c) 2002 by the University of Illinois
52 !
53 !******************************************************************************
54 
55 MODULE rflu_modrepair3d
56 
57  INTEGER, PARAMETER :: MNODE = 100000, &
58  MCELL = 6*MNODE, &
59  MEDGE = 7*MNODE, &
60  MBPTS = 40000, &
61  MBFACE = 2*MBPTS, &
62  MOCTR = 60000,&
63  MTEST = 50000, &
64  MCAV = 24000, &
65  MRING = 80, &
66  MEDKP = 2*MRING
67 
68  INTEGER :: MXBPTS,MXCAV,MXCELL,MXEDGE,MXFACE,MXNODE,MXOCTR,MXRING,MXTEST
69 
70 ! ****************************************************************************
71 ! Contained subroutines and functions
72 ! ****************************************************************************
73 
74  CONTAINS
75 
76  SUBROUTINE rflu_repair3d(NBPTS,NBFACE,NNODE,NCELL,XI,NFCEI,NDCI, &
77  xbndyi,modflag)
78 
79 ! ******************************************************************
80 ! * *
81 ! * THIS PROGRAM MODIFIES A TETRAHEDRAL MESH TO CONFORM WITH A *
82 ! * DISPLACED BOUNDARY SURFACE. THE RESULTING VOLUME MESH WILL, *
83 ! * IN GENERAL, HAVE A MODIFIED TOPOLOGY. *
84 ! * *
85 ! ******************************************************************
86 !
87 ! ******************************************************************
88 ! * *
89 ! * COPYRIGHT (C) TIM BAKER 2002 *
90 ! * *
91 ! ******************************************************************
92 !
93 ! ******************************************************************
94 ! * *
95 ! * VERSION 1.1 : JULY 2002 *
96 ! * *
97 ! ******************************************************************
98 !
99 ! ******************************************************************
100 
101 
102  IMPLICIT NONE
103 
104 ! --- Arguments
105 
106  INTEGER, INTENT(INOUT) :: nbface,nbpts,ncell,nnode
107  INTEGER, INTENT(INOUT) :: nfcei(3,nbface),ndci(4,ncell)
108  DOUBLE PRECISION, INTENT(INOUT) :: xi(3,nnode),xbndyi(3,nbpts)
109  LOGICAL, INTENT(IN) :: modflag
110 
111 ! --- Locals
112 
113  INTEGER :: ioctr,n,nedge,nfail
114  INTEGER :: idgp(mnode),idone(mnode),iedkp(4,medkp),iflag(mnode), &
115  ikeep(mtest),ipoint(mnode),iprot(mcell),iring(mring), &
116  ishk(mring),hk(mring), &
117  ityp(mnode),kshk(mring),ksrch(mtest),ldel(mtest), &
118  listf(mcell),lnbr(mring),lnkdn(mcell),lnkup(mcell), &
119  mnbr(mring),nacpt(mcell),nbh(4,mcell),nbhkp(3,mring), &
120  ncav(4,mcav),ncavfc(3,mtest),ndc(4,mcell),ndg(2,medge), &
121  ndgp(medge),nedgrm(mtest),newc(mring),newcel(mtest), &
122  newnbh(4,mtest),nfad(3,mring),nfce(3,mbface), &
123  nfill(mtest),nflag(mcell),nlink(mnode),noctr(2,moctr), &
124  nold(mtest),npoint(mcell),npp(mring),nprop(mbface), &
125  nptet(mnode),nref(mnode),nshake(mtest),nsrch(mtest), &
126  ntetkp(mring),ntri(3,mtest),nvcnt(mnode)
127  DOUBLE PRECISION :: rcmx,tolv,volmin
128  DOUBLE PRECISION :: count(mnode),dens(mnode),ds(mring),dx(mring), &
129  dy(mring),dz(mring),fac(mnode),rad(mtest), &
130  rat(mcell),rc(mcell),rcrin(mtest), &
131  resid(mnode),sig1(mcell),sig2(mcell), &
132  sig3(mcell),sv(medge),v(mtest),vlt(medkp), &
133  vol(mcell),xc(mtest),xcen(mcell),xch(3,mnode), &
134  xfar(2),xhold(2,mtest),xkeep(2), &
135  xoctr(2,mtest),yc(mtest),ycen(mcell),yfar(2), &
136  yhold(2,mtest),ykeep(2),yoctr(2,mtest), &
137  zc(mtest),zcen(mcell),zfar(2),zhold(2,mtest), &
138  zoctr(2,mtest),zkeep(2),x(3,mnode), &
139  xbndy(3,mbpts),xnewbn(3,mnode)
140 
141 ! ******************************************************************
142 !
143 ! SET TOLERANCES.
144 !
145  tolv = 1.e-13
146 
147 ! SET PARAMETER LIMITS
148 
149  mxbpts = mbpts
150  mxnode = mnode
151  mxcell = mcell
152  mxface = mbface
153  mxedge = medge
154  mxoctr = moctr
155  mxcav = mcav
156  mxring = mring
157  mxtest = mtest
158 
159 ! --- Copy input data into arrays
160 
161  DO n = 1,nbface
162  nfce(1,n) = nfcei(1,n)
163  nfce(2,n) = nfcei(2,n)
164  nfce(3,n) = nfcei(3,n)
165  END DO ! N
166 
167  DO n = 1,ncell
168  ndc(1,n) = ndci(1,n)
169  ndc(2,n) = ndci(2,n)
170  ndc(3,n) = ndci(3,n)
171  ndc(4,n) = ndci(4,n)
172  END DO ! N
173 
174  DO n = 1,nnode
175  x(1,n) = xi(1,n)
176  x(2,n) = xi(2,n)
177  x(3,n) = xi(3,n)
178  END DO ! N
179 
180  DO n = 1,nbpts
181  xbndy(1,n) = xbndyi(1,n)
182  xbndy(2,n) = xbndyi(2,n)
183  xbndy(3,n) = xbndyi(3,n)
184  END DO ! N
185 
186 ! READ IN SURFACE DATA AND TETRAHEDRAL MESH.
187 !
188 ! With the modifications for the incorporation of Repair3D into Rocflu,
189 ! the function of INPUT has changed. In the original version of Repair3D,
190 ! INPUT read the mesh. In the modified version, it is still called but the
191 ! mesh is passed through the argument lists. NOTE that ITYP and NPROP are
192 ! not passed into RFLU_Repair3D and are still set in INPUT. This will have
193 ! to be changed in the future when the boundary triangulation will also
194 ! change.
195 !
196  5 CALL input(x,nnode,ndc,ncell,nfce,nbpts,nbface, &
197  ityp,nprop,xbndy,xfar,yfar,zfar)
198 !
199 !
200 !
201  CALL struct(x,nnode,ndc,nbh,iprot,ncell,nfce,nbface, &
202  nedge,ndg,idgp,ndgp,ipoint,npoint,nptet, &
203  xcen,ycen,zcen,vol,rc,rat, &
204  xfar,yfar,zfar, &
205  ioctr,nlink,noctr,idone,nref,volmin,rcmx)
206 !
207 ! COMPUTE STATISTICS OF INITIAL MESH.
208 !
209  CALL radrat(x,nnode,ndc,nbh,iprot,ncell,nfce,nbface, &
210  ityp,ipoint,vol,rc,rat)
211 !
212 ! DISPLACE MESH TO CONFORM WITH NEW BOUNDARY POSITION.
213 !
214  CALL tetmv(x,xnewbn,nnode,ndc,nbh,ncell,nfce,nbface,nfail, &
215  ityp,xcen,ycen,zcen,vol,rc,rat, &
216  nedge,ndg,idgp,ndgp,ipoint,count,xch,resid,sv, &
217  sig1,sig2,sig3,xfar,yfar,zfar,tolv)
218 
219  IF (nfail.NE.0) THEN
220  go to 100
221  ENDIF
222 !
223 ! MODIFY MESH TOPOLOGY TO IMPROVE QUALITY OF TETRAHEDRAL
224 !
225  IF ( modflag .EQV. .true. ) THEN
226  CALL tetmod(x,ityp,nnode,ndc,nbh,iprot,ncell, &
227  ndg,idgp,ndgp,nedge,nfce,nbface, &
228  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
229  sig1,sig2,sig3,nvcnt,resid,count,fac, &
230  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
231  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
232  xkeep,ykeep,zkeep,ksrch,nsrch, &
233  ipoint,npoint,iflag,nflag, &
234  dx,dy,dz,ds,vlt,iring,ntetkp,nfad,newc, &
235  nbhkp,iedkp,lnbr,ishk,mnbr,kshk,npp, &
236  nfill,newcel,ntri, &
237  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
238  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
239  listf,volmin,rcmx,tolv)
240 !
241 ! COMPUTE STATISTICS OF NEW MESH.
242 !
243  CALL radrat(x,nnode,ndc,nbh,iprot,ncell,nfce,nbface, &
244  ityp,ipoint,vol,rc,rat)
245  END IF ! modFlag
246 
247  stop
248 !
249 ! ALGORITHM HAS FAILED IN MESH MOVEMENT PHASE. WRITE OUT
250 ! MESH DATA FOR THE CORRUPTED MESH.
251 !
252  100 WRITE (6,610)
253  stop
254  610 FORMAT(//5x,'FAILURE IN MESH MOVEMENT PHASE')
255  620 FORMAT(/5x,'****************************************************'/ &
256  5x,'****************************************************'/ &
257  5x,'*** ***'/ &
258  5x,'** CYCLE ',i3,' OF MESH MODIFICATION IS COMPLETE **'/ &
259  5x,'** PARAMETRIC TIME = ',f8.4,' **'/ &
260  5x,'*** ***'/ &
261  5x,'****************************************************'/ &
262  5x,'****************************************************')
263  630 FORMAT(/5x,'MESH MOVEMENT SCHEME HAS FAILED IN STEP ',i4,' OF A ', &
264  i4,' STAGE CYCLE.'/ &
265  5x,'DOUBLE THE NUMBER OF STAGES AND REPEAT PROCEDURE.'/)
266 
267  END SUBROUTINE rflu_repair3d
268 
269 
270 
271 
272 !
273 ! ******************************************************************
274 !
275  SUBROUTINE input (X,NNODE,NDC,NCELL,NFCE,NBPTS,NBFACE, &
276  ityp,nprop,xbndy,xfar,yfar,zfar)
277 !
278 ! ******************************************************************
279 ! * *
280 ! * READ IN SURFACE AND VOLUME MESHES *
281 ! * *
282 ! ******************************************************************
283 ! ******************************************************************
284 ! * *
285 ! * COPYRIGHT (C) TIM BAKER 1998 *
286 ! * *
287 ! ******************************************************************
288 !
289 !
290  IMPLICIT NONE
291 
292  INTEGER :: nbface,nbpts,ncell,nnode
293  INTEGER :: ndc(4,*)
294  INTEGER :: ityp(*),nprop(*)
295  INTEGER :: nfce(3,*)
296  DOUBLE PRECISION :: x(3,*)
297  DOUBLE PRECISION :: xbndy(3,*)
298  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
299 
300  INTEGER :: j,jamin,jmax,jmin,l,n,n1,n2,n3
301  DOUBLE PRECISION :: angl,angl1,angl2,angl3,angmax,angmin,farea, &
302  fmax,fmin,q,qmax,qmin
303 !
304 ! ******************************************************************
305 !
306 ! IREAD = 5
307 !
308 ! READ IN TETRAHEDRAL MESH
309 !
310 ! READ (IREAD,500)
311 ! READ (IREAD,520) NBPTS,NBFACE,NNODE,NCELL
312 
313 ! --- Check sizes of arrays against parameters
314 
315  IF ( nbpts > mxbpts ) THEN
316  go to 300
317  END IF ! NBPTS
318 
319  IF ( nnode > mxnode ) THEN
320  go to 305
321  END IF ! NNODE
322 
323  IF ( nbface > mxface ) THEN
324  go to 310
325  END IF ! NBFACE
326 
327  IF ( ncell > mxcell ) THEN
328  go to 315
329  END IF ! NCELL
330 
331 ! --- Read coordinates, boundary faces, tetrahedra connectivity
332 
333 ! READ (IREAD,500)
334 ! DO 10 N=1,NNODE
335 ! READ (IREAD,515) X(1,N),X(2,N),X(3,N),ITYP(N)
336 ! 10 CONTINUE
337 ! READ (IREAD,500)
338 ! DO 15 L=1,NBFACE
339 ! READ (IREAD,520) (NFCE(K,L),K=1,3),NPROP(L)
340 ! 15 CONTINUE
341 ! READ (IREAD,500)
342 ! DO 25 L=1,NCELL
343 ! READ (IREAD,520) (NDC(K,L),K=1,4)
344 ! 25 CONTINUE
345 
346 ! --- ITYP and NPROP must be initialized because they are not passed
347 ! into RFLU_Repair3D
348 
349  DO n = 1,nnode
350  ityp(n) = 1
351  END DO ! N
352 
353  DO l = 1,nbface
354  nprop(l) = 1
355  END DO ! L
356 
357  WRITE (6,700) nbface,nnode,ncell
358 
359 ! COMPUTE AREA AND ANGLES OF EACH SURFACE TRIANGLE
360 
361  jmax = 1
362  jmin = 1
363  jamin = 1
364  angmin = 360.
365  angmax = 0.
366  qmin = 1.e15
367  qmax = 1.
368  DO 75 j=1,nbface
369  n1 = nfce(1,j)
370  n2 = nfce(2,j)
371  n3 = nfce(3,j)
372 
373  CALL fangle(j,x,nfce,angl1,angl2,angl3,q)
374 
375  angl = min(angl1,angl2,angl3)
376  IF (angl.GT.angmin) go to 60
377  jamin = j
378  angmin = angl
379  60 angmax = max(angl1,angl2,angl3,angmax)
380  qmin = min(q,qmin)
381  qmax = max(q,qmax)
382  farea = facear(x,n1,n2,n3)
383  IF (j.EQ.1) fmax = farea
384  IF (j.EQ.1) fmin = farea
385  IF (farea.LT.fmax) go to 70
386  jmax = j
387  fmax = farea
388  70 IF (farea.GT.fmin) go to 75
389  jmin = j
390  fmin = farea
391  75 CONTINUE
392  WRITE (6,705) angmin,angmax,qmin,qmax
393  n1 = nfce(1,jamin)
394  n2 = nfce(2,jamin)
395  n3 = nfce(3,jamin)
396  IF (angmin.LT.1.) WRITE (6,706) jamin,n1,x(1,n1),x(2,n1),x(3,n1), &
397  n2,x(1,n2),x(2,n2),x(3,n2), &
398  n3,x(1,n3),x(2,n3),x(3,n3)
399  n1 = nfce(1,jmin)
400  n2 = nfce(2,jmin)
401  n3 = nfce(3,jmin)
402  WRITE (6,707) fmax,fmin,jmin,n1,x(1,n1),x(2,n1),x(3,n1), &
403  n2,x(1,n2),x(2,n2),x(3,n2), &
404  n3,x(1,n3),x(2,n3),x(3,n3)
405 
406 ! DETERMINE MINIMUM AND MAXIMUM EXTENT OF GEOMETRY
407 
408  xfar(1) = x(1,1)
409  xfar(2) = x(1,1)
410  yfar(1) = x(2,1)
411  yfar(2) = x(2,1)
412  zfar(1) = x(3,1)
413  zfar(2) = x(3,1)
414  DO 90 n=2,nnode
415  xfar(1) = min(xfar(1),x(1,n))
416  xfar(2) = max(xfar(2),x(1,n))
417  yfar(1) = min(yfar(1),x(2,n))
418  yfar(2) = max(yfar(2),x(2,n))
419  zfar(1) = min(zfar(1),x(3,n))
420  zfar(2) = max(zfar(2),x(3,n))
421  90 CONTINUE
422  WRITE (6,920) xfar(1),xfar(2),yfar(1),yfar(2),zfar(1),zfar(2)
423  920 FORMAT('XFAR ',f10.2,1x,f10.2,' YFAR ',f10.2,1x,f10.2, &
424  ' ZFAR ',f10.2,1x,f10.2)
425 !
426 ! READ IN COORDINATES OF NEW SURFACE POINT POSITIONS
427 !
428 ! IDATA = 10
429 ! READ (IDATA,500)
430 ! READ (IDATA,510) NBPTS
431 ! READ (IDATA,500)
432 ! DO 100 N=1,NBPTS
433 ! READ (IDATA,525) XBNDY(1,N),XBNDY(2,N),XBNDY(3,N)
434 ! 100 CONTINUE
435 
436 ! TIM = SECOND (0)
437 ! WRITE (6,710) TIM
438 
439  RETURN
440  300 WRITE (6,600) nbpts
441  stop
442  305 WRITE (6,605) nnode
443  stop
444  310 WRITE (6,610) nbface
445  stop
446  315 WRITE (6,615) ncell
447  stop
448  500 FORMAT(1x)
449  510 FORMAT(i10)
450 ! 515 FORMAT(3F12.5,I10)
451 ! 515 FORMAT(3F13.5,I10)
452 ! 515 FORMAT(3F10.4,I10)
453  515 FORMAT(3e13.5,i10)
454  520 FORMAT(6i10)
455  525 FORMAT(3e13.5)
456  600 FORMAT(///5x,'NUMBER OF SURFACE POINTS ',i7/ &
457  5x,'EXCEEDS MAXIMUM ALLOWED. INCREASE SIZE OF MBPTS'/ &
458  5x,'PROGRAM STOPPED IN ROUTINE INPUT')
459  605 FORMAT(///5x,'TOTAL NUMBER OF MESH POINTS ',i7/ &
460  5x,'EXCEEDS MAXIMUM ALLOWED. INCREASE SIZE OF MNODE'/ &
461  5x,'PROGRAM STOPPED IN ROUTINE INPUT')
462  610 FORMAT(///5x,'NUMBER OF SURFACE FACES ',i7/ &
463  5x,'EXCEEDS MAXIMUM ALLOWED. INCREASE SIZE OF MBPTS'/ &
464  5x,'PROGRAM STOPPED IN ROUTINE INPUT')
465  615 FORMAT(///5x,'TOTAL NUMBER OF MESH CELLS ',i7/ &
466  5x,'EXCEEDS MAXIMUM ALLOWED. INCREASE SIZE OF MCELL'/ &
467  5x,'PROGRAM STOPPED IN ROUTINE INPUT')
468  700 FORMAT(/5x,'SURFACE AND VOLUME MESH READ'// &
469  5x,'NUMBER OF BOUNDARY SURFACE TRIANGLES = ',i7/ &
470  5x,'TOTAL NUMBER OF MESH POINTS = ',i7/ &
471  5x,'TOTAL NUMBER OF MESH CELLS = ',i7)
472  705 FORMAT(/5x,'MINIMUM BOUNDARY FACE ANGLE = ',f6.2/ &
473  5x,'MAXIMUM BOUNDARY FACE ANGLE = ',f6.2/ &
474  5x,'MINIMUM BOUNDARY RADIUS RATIO = ',f6.2/ &
475  5x,'MAXIMUM BOUNDARY RADIUS RATIO = ',f6.2)
476  706 FORMAT(/5x,'WARNING ! MINIMUM FACE ANGLE IS LESS THAN 1 DEGREE'/ &
477  5x,'FACE ADDRESS ',i6/ &
478  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4/ &
479  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4/ &
480  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4)
481  707 FORMAT(/5x,'MAX BOUNDARY FACE AREA = ',e13.5/ &
482  5x,'MIN BOUNDARY FACE AREA = ',e13.5/ &
483  5x,'ADDRESS OF BOUNDARY FACE WITH MINIMUM AREA',i6/ &
484  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4/ &
485  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4/ &
486  5x,'VERTEX ',i6,' X = ',f12.4,' Y = ',f12.4,' Z = ',f12.4/)
487  END SUBROUTINE input
488 
489 
490 
491 
492 
493 !
494 ! ******************************************************************
495 !
496  SUBROUTINE struct (X,NNODE,NDC,NBH,IPROT,NCELL,NFCE,NBFACE, &
497  nedge,ndg,idgp,ndgp,ipoint,npoint,nptet, &
498  xcen,ycen,zcen,vol,rc,rat, &
499  xfar,yfar,zfar, &
500  ioctr,nlink,noctr,idone,nref,volmin,rcmx)
501 !
502 ! ******************************************************************
503 ! * *
504 ! * CREATE DATA STRUCTURE FOR USE IN VOLUME MESH *
505 ! * RECONSTRUCTION BASED ON DELAUNAY REFINEMENT *
506 ! * *
507 ! ******************************************************************
508 ! ******************************************************************
509 ! * *
510 ! * COPYRIGHT (C) TIM BAKER 1998 *
511 ! * *
512 ! ******************************************************************
513 !
514  IMPLICIT NONE
515 
516  INTEGER :: ioctr,nbface,ncell,nedge,nnode
517  INTEGER :: ndc(4,*),ndg(2,*),idgp(*),ndgp(*)
518  INTEGER :: nbh(4,*),iprot(*),nptet(*),npoint(*),ipoint(*)
519  INTEGER :: nfce(3,*)
520  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
521  DOUBLE PRECISION :: volmin,rcmx
522  DOUBLE PRECISION :: x(3,*)
523  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
524  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
525 
526  INTEGER :: i,iedg,j,k,kk,l,lk,lm,ln,l1,l2,mm,m1,m2,m3,m4,n,ncelm, &
527  nchg,ncnt,nend,ninc,nlook,nn,nold,n1,n2,n3,n4
528  DOUBLE PRECISION :: area,c5,c6,c9,fac,h1,h2,h3,h4,rnx,rny,rnz,tol, &
529  vcell,vmax,vmin,vrat,vsep,xshf,yshf,zshf
530  DOUBLE PRECISION :: v(4),ar(4)
531 !
532 ! ******************************************************************
533 !
534  tol = 1.0e-9
535 !
536 ! INITIALIZE NPTET AND IPOINT ARRAY
537 !
538  DO 10 n=1,nnode
539  ipoint(n) = 0
540  nptet(n) = 0
541  10 CONTINUE
542 !
543 ! COMPUTE VOLUME, CIRCUMRADIUS AND RADIUS RATIO
544 !
545  DO 40 l=1,ncell
546  n1 = ndc(1,l)
547  n2 = ndc(2,l)
548  n3 = ndc(3,l)
549  n4 = ndc(4,l)
550  nend = n4
551  ncnt = 0
552  15 ncnt = ncnt +1
553  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
554  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
555  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
556 !
557 ! COMPUTE VOLUME OF TETRAHEDRON AND AREAS ALL FOUR FACES
558 !
559  v(ncnt) = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
560  +rnz*(x(3,n4) -x(3,n1))
561  ar(ncnt) = sqrt(rnx*rnx +rny*rny +rnz*rnz)
562  IF (n1.EQ.nend) go to 20
563  n = n1
564  n1 = n2
565  n2 = n3
566  n3 = n4
567  n4 = n
568  go to 15
569  20 vol(l) = .25*(abs(v(1)) +abs(v(2)) +abs(v(3)) +abs(v(4)))
570  area = ar(1) +ar(2) +ar(3) +ar(4)
571 !
572 ! COMPUTE CIRCUMCENTER COORDINATES
573 !
574  rc(l) = 0.
575  rat(l) = 1.e10
576  IF (vol(l).LT.tol) go to 30
577  fac = .5/v(4)
578  xshf = .5*(x(1,n1) +x(1,n2) +x(1,n3) +x(1,n4))
579  yshf = .5*(x(2,n1) +x(2,n2) +x(2,n3) +x(2,n4))
580  zshf = .5*(x(3,n1) +x(3,n2) +x(3,n3) +x(3,n4))
581  h1 = (x(1,n4) -x(1,n1))*(x(1,n4) -xshf +x(1,n1)) &
582  +(x(2,n4) -x(2,n1))*(x(2,n4) -yshf +x(2,n1)) &
583  +(x(3,n4) -x(3,n1))*(x(3,n4) -zshf +x(3,n1))
584  h2 = (x(1,n3) -x(1,n1))*(x(1,n3) -xshf +x(1,n1)) &
585  +(x(2,n3) -x(2,n1))*(x(2,n3) -yshf +x(2,n1)) &
586  +(x(3,n3) -x(3,n1))*(x(3,n3) -zshf +x(3,n1))
587  h3 = (x(1,n2) -x(1,n1))*(x(1,n2) -xshf +x(1,n1)) &
588  +(x(2,n2) -x(2,n1))*(x(2,n2) -yshf +x(2,n1)) &
589  +(x(3,n2) -x(3,n1))*(x(3,n2) -zshf +x(3,n1))
590  c5 = h2*(x(3,n2) -x(3,n1)) -h3*(x(3,n3) -x(3,n1))
591  c6 = h2*(x(2,n2) -x(2,n1)) -h3*(x(2,n3) -x(2,n1))
592  c9 = h3*(x(1,n3) -x(1,n1)) -h2*(x(1,n2) -x(1,n1))
593  xcen(l) = .5*xshf +(h1*rnx +(x(2,n4) -x(2,n1))*c5 &
594  -(x(3,n4) -x(3,n1))*c6)*fac
595  ycen(l) = .5*yshf +(-(x(1,n4) -x(1,n1))*c5 +h1*rny &
596  -(x(3,n4) -x(3,n1))*c9)*fac
597  zcen(l) = .5*zshf +((x(1,n4) -x(1,n1))*c6 &
598  +(x(2,n4) -x(2,n1))*c9 +h1*rnz)*fac
599  rc(l) = sqrt((x(1,n1) -xcen(l))**2 +(x(2,n1) -ycen(l))**2 &
600  +(x(3,n1) -zcen(l))**2)
601  rat(l) = rc(l)*area/vol(l)
602  vmin = min(abs(v(1)),abs(v(2)),abs(v(3)),abs(v(4)))
603  vmax = max(abs(v(1)),abs(v(2)),abs(v(3)),abs(v(4)))
604  vsep = vmax -vmin
605  vrat = vsep/vol(l)
606 ! IF (VSEP.GT.TOL) WRITE (6,610) VSEP,VOL(L),VRAT
607  IF (l.EQ.1) volmin = vol(1)
608  IF (l.EQ.1) rcmx = rc(1)
609  volmin = min(volmin,vol(l))
610  rcmx = max(rcmx,rc(l))
611  go to 40
612  30 vcell = vol(l)/6.
613  WRITE (6,600) vcell
614  40 CONTINUE
615 !
616 ! SET UP GHOST CELLS BEHIND BOUNDARY FACES
617 !
618  ncelm = ncell
619  DO 50 j=1,nbface
620  ncell = ncell +1
621  ndc(1,ncell) = nfce(1,j)
622  ndc(2,ncell) = nfce(2,j)
623  ndc(3,ncell) = nfce(3,j)
624  ndc(4,ncell) = -1
625  50 CONTINUE
626 !
627 ! INITIALIZE NPOINT AND SET STARTING VALUES FOR NPTET AND IPROT
628 !
629  DO 55 l=1,ncell
630  npoint(l) = 0
631  iprot(l) = l
632  DO 55 k=1,4
633  n = ndc(k,l)
634  IF (n.LT.0) go to 55
635  IF (nptet(n).GT.0) go to 55
636  nptet(n) = l
637  55 CONTINUE
638 !
639 ! CREATE NBH ARRAY CONTAINING ADDRESSES OF NEIGHBORING TETRAHEDRA
640 !
641  nlook = ncell
642  60 DO 120 lk=1,nlook
643  l = iprot(lk)
644  IF (npoint(l).EQ.4) go to 120
645  n1 = ndc(1,l)
646  n2 = ndc(2,l)
647  n3 = ndc(3,l)
648  n4 = ndc(4,l)
649  IF (n1.LT.0) go to 100
650  65 j = nptet(n1)
651  IF (j.EQ.0.OR.j.EQ.l) go to 100
652  m1 = ndc(1,j)
653  m2 = ndc(2,j)
654  m3 = ndc(3,j)
655  m4 = ndc(4,j)
656  70 IF (m1.EQ.n1) go to 75
657  mm = m1
658  m1 = m2
659  m2 = m3
660  m3 = m4
661  m4 = mm
662  go to 70
663  75 ninc = 0
664  IF (n2.EQ.m2.OR.n2.EQ.m3.OR.n2.EQ.m4) ninc = ninc +1
665  IF (n3.EQ.m2.OR.n3.EQ.m3.OR.n3.EQ.m4) ninc = ninc +1
666  IF (n4.EQ.m2.OR.n4.EQ.m3.OR.n4.EQ.m4) ninc = ninc +1
667  IF (ninc.LT.2) go to 100
668  80 IF (npoint(l).EQ.0) go to 90
669  DO 85 k=1,npoint(l)
670  ln = nbh(k,l)
671  IF (ln.EQ.j) go to 100
672  85 CONTINUE
673  90 npoint(l) = npoint(l) +1
674  nbh(npoint(l),l) = j
675  npoint(j) = npoint(j) +1
676  nbh(npoint(j),j) = l
677  100 IF (n1.EQ.ndc(4,l)) go to 120
678  nn = n1
679  n1 = n2
680  n2 = n3
681  n3 = n4
682  n4 = nn
683  IF (n1.LT.0) go to 100
684  go to 65
685  120 CONTINUE
686 !
687 ! RESET IPROT AND NPTET PRIOR TO REPEAT SEARCH FOR CELL NEIGHBORS
688 !
689  nchg = 0
690  DO 125 lk=1,nlook
691  l = iprot(lk)
692  IF (npoint(l).EQ.4) go to 125
693  nchg = nchg +1
694  iprot(nchg) = l
695  125 CONTINUE
696  IF (nchg.EQ.0) go to 140
697  nlook = nchg
698  DO 130 lk=1,nlook
699  l = iprot(lk)
700  DO 130 k=1,4
701  n = ndc(k,l)
702  IF (n.GT.0) nptet(n) = 0
703  130 CONTINUE
704  DO 135 lk=1,nlook
705  l = iprot(lk)
706  DO 135 k=1,4
707  n = ndc(k,l)
708  IF (n.LT.0) go to 135
709  IF (nptet(n).EQ.0) nptet(n) = l
710  135 CONTINUE
711  go to 60
712 !
713 ! ALL CELL NEIGHBORS HAVE BEEN FOUND. CHECK WHETHER EVERY CELL HAS
714 ! EXACTLY FOUR NEIGHBORS. THEN RE-INITIALIZE NPOINT ARRAY AND SET
715 ! VALUES OF IPROT FOR USE BY THE MESH RECONSTRUCTION ALGORITHM
716 !
717  140 DO 155 l=1,ncell
718  IF (npoint(l).NE.4) go to 320
719  npoint(l) = 0
720  iprot(l) = 1
721  IF (l.GT.ncelm) go to 155
722  iprot(l) = 0
723  DO 150 k=1,4
724  n = ndc(k,l)
725  IF (n.GT.0) nptet(n) = l
726  150 CONTINUE
727  155 CONTINUE
728 !
729 ! INITIALIZE OCTREE STRUCTURE
730 !
731  ioctr = 1
732  nlink(1) = 0
733  noctr(1,1) = 1
734  noctr(2,1) = 0
735  idone(1) = 1
736  nref(1) = 1
737  ipoint(1) = 0
738  DO 170 n=2,nnode
739 
740  CALL octfil(n,x,noctr,ioctr,nlink,nref,xfar,yfar,zfar)
741 
742  idone(n) = 1
743  ipoint(n) = 0
744  170 CONTINUE
745 !
746 ! CREATE EDGE DATA STRUCTURE FOR MESH
747 !
748  DO 175 n=1,nnode
749  idgp(n) = 0
750  175 CONTINUE
751  nedge = 0
752  DO 200 j=1,ncell
753  IF (ndc(4,j).EQ.-1) go to 200
754  i = 1
755  180 i = i +1
756  IF (i.EQ.5) go to 200
757  n1 = ndc(i,j)
758  k = 0
759  185 k = k +1
760  IF (k.EQ.i) go to 180
761  n2 = ndc(k,j)
762  l1 = min(n1,n2)
763  l2 = max(n1,n2)
764  nold = idgp(l1)
765  190 IF (nold.EQ.0) go to 195
766  IF (l2.EQ.max(ndg(1,nold),ndg(2,nold))) go to 185
767  iedg = nold
768  nold = ndgp(nold)
769  go to 190
770  195 nedge = nedge +1
771  ndg(1,nedge) = l1
772  ndg(2,nedge) = l2
773  ndgp(nedge) = 0
774  IF (idgp(l1).NE.0) ndgp(iedg) = nedge
775  IF (idgp(l1).EQ.0) idgp(l1) = nedge
776  go to 185
777  200 CONTINUE
778  RETURN
779  320 WRITE (6,620) l,(ndc(kk,l),kk=1,4),npoint(l)
780  stop
781  600 FORMAT(//5x,'TETRAHEDRON WITH AN EXTREMELY SMALL VOLUME FOUND'// &
782  ' IN ROUTINE STRUCT'//5x,'VOLUME = ',e13.5/)
783  610 FORMAT(5x,'IMPRECISE ESTIMATE OF TETRAHEDRON VOLUME', &
784  5x,'VSEP = ',e13.5,' VOLUME = ',e13.5, &
785  ' VSEP/VOLUME = ',e13.5)
786  620 FORMAT(//5x,'NPOINT IS NOT EQUAL TO FOUR FOR TETRAHEDRON ',i7, &
787  5x,'TETRAHEDRON VERTICES ARE ',4i6,' AND NPOINT = ',i2, &
788  5x,'PROGRAM STOPPED IN ROUTINE STRUCT')
789  END SUBROUTINE struct
790 
791 
792 
793 !
794 ! ******************************************************************
795 !
796  SUBROUTINE tetmv (X,XNEWBN,NNODE,NDC,NBH,NCELL,NFCE,NBFACE,NFAIL, &
797  ityp,xcen,ycen,zcen,vol,rc,rat, &
798  nedge,ndg,idgp,ndgp,ipoint,fcount,xc,resid,sv, &
799  sig1,sig2,sig3,xfar,yfar,zfar,tolv)
800 
801 ! ******************************************************************
802 ! * *
803 ! * LAPLACIAN SOLVER TO RELAX A TETRAHEDRAL MESH TO CONFORM *
804 ! * WITH A NEW BOUNDARY SURFACE POSITION. *
805 ! * THE LAPLACIAN APPROXIMATION IS BASED ON THE ACCUMMULATION *
806 ! * OF EDGE DIFFERENCES AND WILL IN GENERAL FAIL TO GIVE ZERO *
807 ! * FOR A LINEAR VARIATION IN DISPLACEMENT. THIS ROUTINE WILL *
808 ! * THEREFORE ONLY BE EFFECTIVE FOR SMALL PERTURBATIONS OF THE *
809 ! * BOUNDARY SURFACE. *
810 ! * *
811 ! ******************************************************************
812 ! ******************************************************************
813 ! * *
814 ! * COPYRIGHT (C) TIM BAKER 1999 *
815 ! * *
816 ! ******************************************************************
817 
818 
819 ! ******************************************************************
820 ! * *
821 ! * DIMENSION CONTROL PARAMETERS *
822 ! * *
823 ! ******************************************************************
824 
825  IMPLICIT NONE
826 
827  INTEGER :: nbface,ncell,nedge,nfail,nnode
828  INTEGER :: ndc(4,*),nbh(4,*),ityp(*),nfce(3,*)
829  INTEGER :: ndg(2,*),idgp(*),ndgp(*),ipoint(*)
830  DOUBLE PRECISION :: tolv
831  DOUBLE PRECISION :: x(3,*),xnewbn(3,*)
832  DOUBLE PRECISION :: xcen(*),ycen(*),zcen(*),vol(*),rc(*),rat(*)
833  DOUBLE PRECISION :: fcount(*),xc(3,*),resid(*),sv(*), &
834  sig1(*),sig2(*),sig3(*)
835  DOUBLE PRECISION :: rmax(3),itmax(3)
836  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
837  DOUBLE PRECISION :: xcn,ycn,zcn,vl,radc
838  DOUBLE PRECISION :: vmin,vmax
839 
840  INTEGER :: i,ibig,iedg,ismall,it,j,k,kp1,kp2,kp3,l,loop,lsub, &
841  l1,l2,n,nneg,nold,npass,n1,n2,n3,n4
842  DOUBLE PRECISION :: area,cndmax,cndmin,difx,eps,fac,rbig,resm, &
843  rmax1,rnx,rny,rnz,sigmx,sigmn,strmax,strmin, &
844  strtet,third,vtet,vtet1,vtet2,xbar,ybar,zbar
845 !
846 ! ******************************************************************
847 !
848  nfail = 0
849  third = 1./3.
850  eps = 1.
851 !
852 ! SUB-ITERATE TO MOVE MESH IN LSUB STEPS
853 !
854  lsub = 1
855  fac = 1./float(lsub)
856  DO 150 l=1,lsub
857 !
858 ! INITIALIZE VERTEX EDGE COUNT, IPOINT AND IDGP ARRAY
859 !
860  DO 10 n=1,nnode
861  fcount(n) = 0.
862  ipoint(n) = 0
863  idgp(n) = 0
864  10 CONTINUE
865 !
866 ! COMPUTE VOLUME OF EACH TETRAHEDRON
867 !
868  DO 22 j=1,ncell
869  IF (nbh(1,j).EQ.0) go to 22
870  IF (ndc(4,j).EQ.-1) go to 22
871  vol(j) = 0.
872  DO 20 k=1,4
873  kp1 = mod(k,4) +1
874  kp2 = mod(kp1,4) +1
875  kp3 = mod(kp2,4) +1
876  n1 = ndc(k,j)
877  n2 = ndc(kp1,j)
878  n3 = ndc(kp2,j)
879  n4 = ndc(kp3,j)
880  xbar = third*(x(1,n1) +x(1,n2) +x(1,n3))
881  ybar = third*(x(2,n1) +x(2,n2) +x(2,n3))
882  zbar = third*(x(3,n1) +x(3,n2) +x(3,n3))
883  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
884  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
885  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
886  vtet = (x(1,n4) -xbar)*rnx +(x(2,n4) -ybar)*rny &
887  +(x(3,n4) -zbar)*rnz
888  vol(j) = vol(j) +abs(vtet)
889  20 CONTINUE
890  22 CONTINUE
891  npass = 0
892  DO 25 j=1,ncell
893  IF (nbh(1,j).EQ.0) go to 25
894  IF (ndc(4,j).EQ.-1) go to 25
895  IF (npass.EQ.0) THEN
896  npass = 1
897  vmin = vol(j)
898  vmax = vol(j)
899  ELSE
900  vmin = min(vmin,vol(j))
901  vmax = max(vmax,vol(j))
902  ENDIF
903  25 CONTINUE
904  DO 30 j=1,ncell
905  IF (nbh(1,j).EQ.0) go to 30
906  IF (ndc(4,j).EQ.-1) go to 30
907  vol(j) = 1. +(vmax -vmin)/vol(j)
908  30 CONTINUE
909  WRITE (6,940) vmin,vmax
910  940 FORMAT(/'VMIN = ',e13.5,' VMAX = ',e13.5/)
911 !
912 ! CREATE EDGE DATA STRUCTURE FOR MESH
913 !
914  nedge = 0
915  DO 70 j=1,ncell
916  IF (nbh(1,j).EQ.0) go to 70
917  IF (ndc(4,j).EQ.-1) go to 70
918  i = 1
919  50 i = i +1
920  IF (i.EQ.5) go to 70
921  n1 = ndc(i,j)
922  k = 0
923  55 k = k +1
924  IF (k.EQ.i) go to 50
925  n2 = ndc(k,j)
926  l1 = min(n1,n2)
927  l2 = max(n1,n2)
928  nold = idgp(l1)
929  60 IF (nold.EQ.0) go to 65
930  IF (l2.EQ.max(ndg(1,nold),ndg(2,nold))) THEN
931  sv(nold) = sv(nold) +vol(j)
932  go to 55
933  ENDIF
934  iedg = nold
935  nold = ndgp(nold)
936  go to 60
937  65 nedge = nedge +1
938  ndg(1,nedge) = l1
939  ndg(2,nedge) = l2
940  ndgp(nedge) = 0
941  IF (idgp(l1).NE.0) ndgp(iedg) = nedge
942  IF (idgp(l1).EQ.0) idgp(l1) = nedge
943  sv(nedge) = vol(j)
944  go to 55
945  70 CONTINUE
946 !
947 ! LOOP OVER X, Y AND Z COMPONENTS OF MESH DISPLACEMENT
948 !
949  loop = 0
950  80 loop = loop +1
951  it = 0
952 !
953 ! INITIALIZE POINT DISPLACEMENTS
954 !
955  DO 85 n=1,nnode
956  ipoint(n) = 0
957  IF (ityp(n).LT.0) go to 85
958  xc(loop,n) = 0.
959  85 CONTINUE
960 !
961 ! COMPUTE BOUNDARY POINT DISPLACEMENTS
962 !
963  DO 90 i=1,nbface
964  DO 90 k=1,3
965  n = nfce(k,i)
966  IF (n.LT.0) go to 90
967  IF (ityp(n).LT.0) go to 90
968  IF (ipoint(n).GT.0) go to 90
969  ipoint(n) = 1
970  xc(loop,n) = (xnewbn(loop,n) -x(loop,n))*l*fac
971  90 CONTINUE
972  IF (loop.GT.1) go to 105
973 !
974 ! COMPUTE VERTEX DEGREE AND ITS RECIPROCAL AT EACH NODE
975 !
976  DO 95 i=1,nedge
977  n1 = ndg(1,i)
978  n2 = ndg(2,i)
979  IF (n1.LE.0.OR.n2.LE.0) go to 95
980  IF (ityp(n1).LT.0.OR.ityp(n2).LT.0) go to 95
981  fcount(n1) = fcount(n1) +sv(i)
982  fcount(n2) = fcount(n2) +sv(i)
983  95 CONTINUE
984  DO 100 n=1,nnode
985  IF (ityp(n).LT.0) go to 100
986  fcount(n) = 1./fcount(n)
987  100 CONTINUE
988 !
989 ! START OF ITERATIVE CYCLE
990 !
991  105 it = it +1
992 !
993 ! SET INITIAL RESIDUALS TO ZERO
994 !
995  DO 110 n=1,nnode
996  resid(n) = 0.
997  110 CONTINUE
998 !
999 ! ACCUMMULATE EDGE DIFFERENCES OF DISPLACEMENT COMPONENT FOR ALL
1000 ! EDGES INCIDENT TO EACH POINT
1001 !
1002  DO 115 i=1,nedge
1003  n1 = ndg(1,i)
1004  n2 = ndg(2,i)
1005  IF (n1.LE.0.OR.n2.LE.0) go to 115
1006  IF (ityp(n1).LT.0.OR.ityp(n2).LT.0) go to 115
1007  difx = (xc(loop,n1) -xc(loop,n2))*sv(i)
1008  resid(n1) = resid(n1) -difx
1009  resid(n2) = resid(n2) +difx
1010  115 CONTINUE
1011 !
1012 ! UPDATE DISPLACEMENT COMPONENT AT EACH NON-BOUNDARY POINT
1013 !
1014  rmax(loop) = 0.
1015  DO 120 n=1,nnode
1016  IF (ityp(n).LT.0) go to 120
1017  IF (ipoint(n).EQ.0) THEN
1018  xc(loop,n) = xc(loop,n) +eps*fcount(n)*resid(n)
1019  resm = abs(resid(n))
1020  rmax(loop) = max(rmax(loop),fcount(n)*resm)
1021  ENDIF
1022  120 CONTINUE
1023 
1024 ! IF (IT.EQ.1.OR.MOD(IT,40).EQ.0) WRITE (6,900) IT,RMAX(LOOP)
1025 ! 900 FORMAT('IN TETMV..., IT = ',I4,' RMAX = ',F10.6)
1026 
1027  IF (it.EQ.1) rmax1 = rmax(loop)
1028  IF (rmax(loop).GT.max(0.0001*rmax1,1.0d0-9).AND.it.LT.2000) &
1029  go to 105
1030  itmax(loop) = it
1031  IF (loop.LT.3) go to 80
1032  rbig = max(rmax(1),rmax(2),rmax(3))
1033  ibig = max(itmax(1),itmax(2),itmax(3))
1034  WRITE (6,600) rbig,ibig
1035 !
1036 ! ITERATIVE CYCLE IS COMPLETE. CHECK FOR SIGN CHANGE IN THE VOLUME
1037 ! OF ANY TETRAHEDRON
1038 !
1039  strmax = 0.
1040  strmin = 1.e6
1041  nneg = 0
1042  DO 130 j=1,ncell
1043  IF (nbh(1,j).EQ.0) go to 130
1044  IF (ndc(4,j).EQ.-1) go to 130
1045  n1 = ndc(1,j)
1046  n2 = ndc(2,j)
1047  n3 = ndc(3,j)
1048  n4 = ndc(4,j)
1049  xbar = third*(x(1,n1) +x(1,n2) +x(1,n3))
1050  ybar = third*(x(2,n1) +x(2,n2) +x(2,n3))
1051  zbar = third*(x(3,n1) +x(3,n2) +x(3,n3))
1052  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
1053  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
1054  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
1055  vtet1 = rnx*(x(1,n4) -xbar) +rny*(x(2,n4) -ybar) &
1056  +rnz*(x(3,n4) -zbar)
1057  xbar = xbar +third*(xc(1,n1) +xc(1,n2) +xc(1,n3))
1058  ybar = ybar +third*(xc(2,n1) +xc(2,n2) +xc(2,n3))
1059  zbar = zbar +third*(xc(3,n1) +xc(3,n2) +xc(3,n3))
1060  rnx = cofact(x(2,n1)+xc(2,n1),x(2,n2)+xc(2,n2),x(2,n3)+xc(2,n3), &
1061  x(3,n1)+xc(3,n1),x(3,n2)+xc(3,n2),x(3,n3)+xc(3,n3))
1062  rny = cofact(x(3,n1)+xc(3,n1),x(3,n2)+xc(3,n2),x(3,n3)+xc(3,n3), &
1063  x(1,n1)+xc(1,n1),x(1,n2)+xc(1,n2),x(1,n3)+xc(1,n3))
1064  rnz = cofact(x(1,n1)+xc(1,n1),x(1,n2)+xc(1,n2),x(1,n3)+xc(1,n3), &
1065  x(2,n1)+xc(2,n1),x(2,n2)+xc(2,n2),x(2,n3)+xc(2,n3))
1066  vtet2 = rnx*(x(1,n4) +xc(1,n4) -xbar) &
1067  +rny*(x(2,n4) +xc(2,n4) -ybar) &
1068  +rnz*(x(3,n4) +xc(3,n4) -zbar)
1069  strtet = abs(vtet2/vtet1)
1070  strmax = max(strmax,strtet)
1071  strmin = min(strmin,strtet)
1072  IF (vtet1*vtet2.LE.0.) nneg = nneg +1
1073  130 CONTINUE
1074 !
1075  CALL snglar(nnode,x,xc,ncell,ndc,nbh,sigmn,sigmx, &
1076  sig1,sig2,sig3,cndmin,cndmax)
1077 !
1078  WRITE (6,700) strmax,strmin,sigmx,sigmn,cndmax,cndmin
1079  IF (nneg.GT.0) WRITE (6,705) nneg
1080  IF (nneg.GT.0) THEN
1081  nfail = 1
1082  RETURN
1083  ENDIF
1084 !
1085 !
1086 ! ADD COMPUTED DISPLACEMENTS TO THE OLD POINT POSITIONS
1087 !
1088  DO 140 n=1,nnode
1089  IF (ityp(n).LT.0) go to 140
1090  ipoint(n) = 0
1091  x(1,n) = x(1,n) +xc(1,n)
1092  x(2,n) = x(2,n) +xc(2,n)
1093  x(3,n) = x(3,n) +xc(3,n)
1094  140 CONTINUE
1095  WRITE (6,920) l
1096  920 FORMAT(/'SUB-ITERATION ',i3,' IS COMPLETE'/)
1097  150 CONTINUE
1098 !
1099 ! DETERMINE MINIMUM AND MAXIMUM EXTENT OF NEW GEOMETRY
1100 !
1101  npass = 0
1102  DO 155 n=1,nnode
1103  IF (ityp(n).LT.0) go to 155
1104  IF (npass.EQ.0) THEN
1105  npass = 1
1106  xfar(1) = x(1,n)
1107  xfar(2) = x(1,n)
1108  yfar(1) = x(2,n)
1109  yfar(2) = x(2,n)
1110  zfar(1) = x(3,n)
1111  zfar(2) = x(3,n)
1112  ELSE
1113  xfar(1) = min(xfar(1),x(1,n))
1114  xfar(2) = max(xfar(2),x(1,n))
1115  yfar(1) = min(yfar(1),x(2,n))
1116  yfar(2) = max(yfar(2),x(2,n))
1117  zfar(1) = min(zfar(1),x(3,n))
1118  zfar(2) = max(zfar(2),x(3,n))
1119  ENDIF
1120  155 CONTINUE
1121  WRITE (6,925) xfar(1),xfar(2),yfar(1),yfar(2),zfar(1),zfar(2)
1122  925 FORMAT('XFAR ',f10.2,1x,f10.2,' YFAR ',f10.2,1x,f10.2, &
1123  ' ZFAR ',f10.2,1x,f10.2)
1124 !
1125 ! COMPUTE VOLUME, CIRCUMCENTER AND CIRCUMRADIUS
1126 ! FOR DEFORMED TETRAHEDRA
1127 !
1128  DO 160 j=1,ncell
1129  IF (nbh(1,j).EQ.0) go to 160
1130  n1 = ndc(1,j)
1131  n2 = ndc(2,j)
1132  n3 = ndc(3,j)
1133  n4 = ndc(4,j)
1134  IF (n4.EQ.-1) go to 160
1135 
1136  CALL circum(x,n1,n2,n3,n4,xcn,ycn,zcn,vl,radc,ismall,tolv)
1137 
1138  IF (ismall.EQ.1) go to 310
1139  xcen(j) = xcn
1140  ycen(j) = ycn
1141  zcen(j) = zcn
1142  vol(j) = vl
1143  rc(j) = radc
1144  area = tetar(j,x,ndc)
1145  rat(j) = rc(j)*area/vol(j)
1146  160 CONTINUE
1147 ! TIM = SECOND (0)
1148 ! WRITE (6,710) TIM
1149  RETURN
1150  310 WRITE (6,610)
1151  stop
1152  600 FORMAT(/5x,'MAXIMUM RESIDUAL IS ',f10.6, &
1153  ' MAXIMUM ITERATIONS = ',i5)
1154  610 FORMAT(///5x,'AT LEAST ONE NEW TETRAHEDRON HAS TOO SMALL A VOLUME' &
1155  /5x,'PROGRAM STOPPED IN TETMV')
1156  700 FORMAT(/5x,'****************************************************'/ &
1157  5x,'** **'/ &
1158  5x,'** MAXIMUM CELL STRETCHING IS ',f10.4,' **'/ &
1159  5x,'** MAXIMUM CELL COMPRESSION IS ',f10.4,' **'/ &
1160  5x,'** **'/ &
1161  5x,'** MAXIMUM SINGULAR VALUE IS ',f10.4,' **'/ &
1162  5x,'** MINIMUM SINGULAR VALUE IS ',f10.4,' **'/ &
1163  5x,'** **'/ &
1164  5x,'** MAXIMUM CONDITION NUMBER ',f10.4,' **'/ &
1165  5x,'** MINIMUM CONDITION NUMBER ',f10.4,' **'/ &
1166  5x,'** **'/ &
1167  5x,'****************************************************'/)
1168  705 FORMAT(/5x,'THERE ARE ',i6,' CELLS THAT HAVE BEEN INVERTED.'/ &
1169  5x,'THE NEW MESH IS THEREFORE INVALID.')
1170 ! 710 FORMAT(/5X,'TIME = ',F7.1,' SECONDS'/)
1171  END SUBROUTINE tetmv
1172 
1173 
1174 
1175 
1176 
1177 !
1178 ! ******************************************************************
1179 !
1180  SUBROUTINE tetmod (X,ITYP,NNODE,NDC,NBH,IPROT,NCELL, &
1181  ndg,idgp,ndgp,nedge,nfce,nbface, &
1182  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
1183  sig1,sig2,sig3,nvcnt,resid,count,fac, &
1184  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
1185  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
1186  xkeep,ykeep,zkeep,ksrch,nsrch, &
1187  ipoint,npoint,iflag,nflag, &
1188  dx,dy,dz,ds,vlt,iring,ntetkp,nfad,newc, &
1189  nbhkp,iedkp,lnbr,ishk,mnbr,kshk,npp, &
1190  nfill,newcel,ntri, &
1191  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
1192  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
1193  listf,volmin,rcmx,tolv)
1194 !
1195 ! ******************************************************************
1196 ! * *
1197 ! * MODIFY THE MESH TOPOLOGY BY COARSENING AND ENRICHMENT IN *
1198 ! * ORDER TO IMPROVE THE QUALITY OF THE TETRAHEDRAL ELEMENTS. *
1199 ! * *
1200 ! ******************************************************************
1201 ! ******************************************************************
1202 ! * *
1203 ! * COPYRIGHT (C) TIM BAKER 2002 *
1204 ! * *
1205 ! ******************************************************************
1206 !
1207  IMPLICIT NONE
1208 
1209  INTEGER :: ioctr,nbface,ncell,nedge,nnode
1210  INTEGER :: lnkup(*),lnkdn(*)
1211  INTEGER :: nsrch(*),ksrch(*)
1212  INTEGER :: nvcnt(*)
1213  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
1214  INTEGER :: ityp(*),nptet(*),listf(*),nacpt(*)
1215  INTEGER :: npoint(*),ipoint(*)
1216  INTEGER :: iflag(*),nflag(*)
1217  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),idgp(*),ndgp(*)
1218  INTEGER :: nfce(3,*)
1219  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*),newcel(*), &
1220  nshake(*),ncav(4,*),nedgrm(*)
1221  INTEGER :: ldel(*),ncavfc(3,*),ikeep(*)
1222  INTEGER :: iring(*),ntetkp(*),nfad(3,*),newc(*), &
1223  nbhkp(3,*),iedkp(4,*),npp(*), &
1224  lnbr(*),ishk(*),mnbr(*),kshk(*)
1225  DOUBLE PRECISION :: volmin,tolv,rcmx
1226  DOUBLE PRECISION :: x(3,*),dens(*)
1227  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
1228  DOUBLE PRECISION :: sig1(*),sig2(*),sig3(*)
1229  DOUBLE PRECISION :: resid(*),count(*),fac(*)
1230  DOUBLE PRECISION :: xoctr(2,*),yoctr(2,*),zoctr(2,*), &
1231  xhold(2,*),yhold(2,*),zhold(2,*), &
1232  xfar(2),yfar(2),zfar(2),xkeep(2), &
1233  ykeep(2),zkeep(2)
1234  DOUBLE PRECISION :: xc(*),yc(*),zc(*),v(*),rad(*),rcrin(*)
1235  DOUBLE PRECISION :: dx(*),dy(*),dz(*),ds(*),vlt(*)
1236 
1237  INTEGER :: jfirst,jlast,lc,nbpts,ntrack
1238 !
1239 ! ******************************************************************
1240 !
1241 ! COMPUTE DENSITY FUNCTION AT EACH MESH POINT.
1242 !
1243  CALL densfn(x,nnode,nfce,nbface,nedge,ndg,dens,resid,count)
1244 !
1245 ! COMPUTE EDGE VALENCE OF EACH MESH POINT.
1246 !
1247  CALL edglen(x,nnode,ityp,nedge,ndg,dens,nvcnt)
1248 !
1249 ! COARSEN MESH BY EDGE COLLAPSE.
1250 !
1251  DO 25 lc=1,3
1252 !
1253  CALL coarsn(lc,x,nnode,ndc,nbh,iprot,ncell, &
1254  ityp,xcen,ycen,zcen,vol,rc,rat, &
1255  nvcnt,dens,iflag,nflag,nptet, &
1256  nedge,ndg,idgp,ndgp, &
1257  noctr,ioctr,nlink,xfar,yfar,zfar,idone,nref, &
1258  fac,sig1,sig2,sig3, &
1259  ksrch,nsrch,iring,ntetkp, &
1260  lnbr,ishk,mnbr,kshk,tolv)
1261 !
1262 ! OPTIMIZE MESH QUALITY BY FACE/EDGE SWAPPING.
1263 !
1264  CALL smooth(x,ityp,nnode,ndc,nbh,iprot,ncell, &
1265  ndg,idgp,ndgp,nedge, &
1266  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
1267  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
1268  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
1269  xkeep,ykeep,zkeep,ksrch,nsrch, &
1270  ipoint,npoint,iflag,nflag, &
1271  dx,dy,dz,ds,vlt,iring,ntetkp,nfad,newc, &
1272  nbhkp,iedkp,lnbr,ishk,mnbr,kshk,npp, &
1273  nfill,newcel,ntri, &
1274  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
1275  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
1276  listf,volmin,rcmx,tolv)
1277 !
1278 ! RE-COMPUTE EDGE VALENCE OF EACH MESH POINT.
1279 !
1280  CALL edglen(x,nnode,ityp,nedge,ndg,dens,nvcnt)
1281 
1282  25 CONTINUE
1283 !
1284 ! RE-COMPUTE DENSITY FUNCTION AT EACH MESH POINT.
1285 !
1286  CALL densfn(x,nnode,nfce,nbface,nedge,ndg,dens,resid,count)
1287 !
1288 ! ENRICH MESH INTERIOR BASED ON A COMPARISON BETWEEN THE
1289 ! ACTUAL POINT DENSITY AND THE VALUE OF THE POINT
1290 ! DENSITY FUNCTION.
1291 !
1292  CALL volput(x,ityp,nbpts,nnode,ndc,nbh,iprot,ncell, &
1293  ndg,idgp,ndgp,nedge, &
1294  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
1295  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
1296  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
1297  xkeep,ykeep,zkeep,ksrch,nsrch, &
1298  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
1299  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
1300  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
1301  jlast,jfirst,ntrack,volmin,rcmx,tolv)
1302 !
1303 ! OPTIMIZE MESH QUALITY BY FACE/EDGE SWAPPING.
1304 !
1305  CALL smooth(x,ityp,nnode,ndc,nbh,iprot,ncell, &
1306  ndg,idgp,ndgp,nedge, &
1307  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
1308  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
1309  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
1310  xkeep,ykeep,zkeep,ksrch,nsrch, &
1311  ipoint,npoint,iflag,nflag, &
1312  dx,dy,dz,ds,vlt,iring,ntetkp,nfad,newc, &
1313  nbhkp,iedkp,lnbr,ishk,mnbr,kshk,npp, &
1314  nfill,newcel,ntri, &
1315  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
1316  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
1317  listf,volmin,rcmx,tolv)
1318 !
1319 ! RE-COMPUTE EDGE VALENCE OF EACH MESH POINT.
1320 !
1321  CALL edglen(x,nnode,ityp,nedge,ndg,dens,nvcnt)
1322 
1323  RETURN
1324  END SUBROUTINE tetmod
1325 
1326 
1327 
1328 
1329 
1330 !
1331 ! ******************************************************************
1332 !
1333  SUBROUTINE octfil (N,X,NOCTR,IOCTR,NLINK,NREF,XFAR,YFAR,ZFAR)
1334 !
1335 ! ******************************************************************
1336 ! * *
1337 ! * INSERT POINT N INTO OCTREE STRUCTURE *
1338 ! * *
1339 ! ******************************************************************
1340 ! ******************************************************************
1341 ! * *
1342 ! * COPYRIGHT (C) TIM BAKER 1994 *
1343 ! * *
1344 ! ******************************************************************
1345 !
1346 !
1347  IMPLICIT NONE
1348 
1349  INTEGER :: ioctr,n
1350  INTEGER :: nref(*),nlink(*),noctr(2,*)
1351  DOUBLE PRECISION :: x(3,*)
1352  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
1353  DOUBLE PRECISION :: xroot(2),yroot(2),zroot(2)
1354 
1355  INTEGER :: i,iroot,j,k,l,ltest,next,ntest,nxsgn,nysgn,nzsgn
1356  INTEGER :: jj(8),nstore(8)
1357  DOUBLE PRECISION :: tol,tolpt, &
1358  xhalf,xhigh,xlow,xsgn,xshift,xsize, &
1359  yhalf,yhigh,ylow,ysgn,yshift,ysize, &
1360  zhalf,zhigh,zlow,zsgn,zshift,zsize
1361 !
1362 ! ******************************************************************
1363 !
1364  tolpt = 1.e-6
1365  tol = 1.000001
1366  IF (x(1,n).LT.xfar(1)-tolpt.OR.x(1,n).GT.xfar(2)+tolpt) go to 200
1367  IF (x(2,n).LT.yfar(1)-tolpt.OR.x(2,n).GT.yfar(2)+tolpt) go to 200
1368  IF (x(3,n).LT.zfar(1)-tolpt.OR.x(3,n).GT.zfar(2)+tolpt) go to 200
1369  5 i = 1
1370  xlow = xfar(1)
1371  xhigh = xfar(2)
1372  ylow = yfar(1)
1373  yhigh = yfar(2)
1374  zlow = zfar(1)
1375  zhigh = zfar(2)
1376  IF (noctr(1,i).LT.0) go to 80
1377  l = 0
1378  next = noctr(1,i)
1379  6 next = nlink(next)
1380  l = l +1
1381  IF (next.NE.0) go to 6
1382  10 iroot = i
1383  xroot(1) = xlow
1384  xroot(2) = xhigh
1385  yroot(1) = ylow
1386  yroot(2) = yhigh
1387  zroot(1) = zlow
1388  zroot(2) = zhigh
1389  IF (l.EQ.8) go to 30
1390  l = l +1
1391  nlink(n) = 0
1392  nref(n) = i
1393  IF (l.GT.1) go to 15
1394  noctr(1,i) = n
1395  RETURN
1396  15 next = noctr(1,i)
1397  20 ntest = nlink(next)
1398  IF (ntest.EQ.0) go to 25
1399  next = ntest
1400  go to 20
1401  25 nlink(next) = n
1402  RETURN
1403 !
1404 ! OCTANT NOW CONTAINS NINE POINTS. FORM EIGHT NEW OCTANTS
1405 ! AND AMEND TREE STRUCTURE.
1406 !
1407  30 DO 35 k=1,8
1408  ioctr = ioctr +1
1409  IF (ioctr.GT.mxoctr) go to 210
1410  noctr(2,ioctr) = i
1411  35 noctr(1,ioctr) = 0
1412 !
1413 ! ASSIGN POINTS TO NEW OCTANTS
1414 !
1415  next = noctr(1,i)
1416  DO 40 l=1,8
1417  nstore(l) = next
1418  next = nlink(next)
1419  40 jj(l) = 0
1420  DO 45 k=1,8
1421  j = nstore(k)
1422  xshift = x(1,j) -.5*(xlow +xhigh)
1423  xsize = max(1.0d0-9,abs(xshift))
1424  nxsgn = (int(REAL(tol*xshift/xsize)) +1)/2*2
1425 ! NXSGN = (IFIX(REAL(TOL*XSHIFT/XSIZE)) +1)/2*2
1426  yshift = x(2,j) -.5*(ylow +yhigh)
1427  ysize = max(1.0d0-9,abs(yshift))
1428  nysgn = (int(REAL(tol*yshift/ysize)) +1)/2*2
1429 ! NYSGN = (IFIX(REAL(TOL*YSHIFT/YSIZE)) +1)/2*2
1430  zshift = x(3,j) -.5*(zlow +zhigh)
1431  zsize = max(1.0d0-9,abs(zshift))
1432  nzsgn = (int(REAL(tol*zshift/zsize)) +1)/2*2
1433 ! NZSGN = (IFIX(REAL(TOL*ZSHIFT/ZSIZE)) +1)/2*2
1434  l = 1 +nxsgn/2 +nysgn +2*nzsgn
1435  jj(l) = jj(l) +1
1436  nlink(j) = 0
1437  nref(j) = ioctr -8 +l
1438  IF (jj(l).GT.1) go to 41
1439  noctr(1,ioctr-8+l) = j
1440  go to 45
1441  41 next = noctr(1,ioctr-8+l)
1442  42 ntest = nlink(next)
1443  IF (ntest.EQ.0) go to 43
1444  next = ntest
1445  go to 42
1446  43 nlink(next) = j
1447  45 CONTINUE
1448 !
1449 ! CHECK WHETHER ALL EIGHT POINTS LIE IN ONE OCTANT
1450 !
1451  noctr(1,i) = 7 -ioctr
1452  ltest = 0
1453  DO 60 l=1,8
1454  IF (jj(l).EQ.8) ltest = l
1455  60 CONTINUE
1456  IF (ltest.EQ.0) go to 70
1457  i = ioctr -8 +ltest
1458  xhalf = .5*(xlow +xhigh)
1459  xsgn = mod(ltest,2)
1460  xlow = xsgn*xlow +(1. -xsgn)*xhalf
1461  xhigh = xsgn*xhalf +(1. -xsgn)*xhigh
1462  yhalf = .5*(ylow +yhigh)
1463  ysgn = isign(1,2*mod(ltest-1,4)-3)
1464  ylow = .5*((1. -ysgn)*ylow +(1. +ysgn)*yhalf)
1465  yhigh = .5*((1. -ysgn)*yhalf +(1. +ysgn)*yhigh)
1466  zhalf = .5*(zlow +zhigh)
1467  zsgn = isign(1,2*ltest-9)
1468  zlow = .5*((1. -zsgn)*zlow +(1. +zsgn)*zhalf)
1469  zhigh = .5*((1. -zsgn)*zhalf +(1. +zsgn)*zhigh)
1470  go to 30
1471 !
1472 ! LOCATE SUB-OCTANT IN WHICH POINT LIES
1473 !
1474  70 i = iroot
1475  xlow = xroot(1)
1476  xhigh = xroot(2)
1477  ylow = yroot(1)
1478  yhigh = yroot(2)
1479  zlow = zroot(1)
1480  zhigh = zroot(2)
1481  80 xhalf = .5*(xlow +xhigh)
1482  yhalf = .5*(ylow +yhigh)
1483  zhalf = .5*(zlow +zhigh)
1484  xshift = x(1,n) -xhalf
1485  xsize = max(1.0d0-9,abs(xshift))
1486  nxsgn = (int(REAL(tol*xshift/xsize)) +1)/2*2
1487 ! NXSGN = (IFIX(REAL(TOL*XSHIFT/XSIZE)) +1)/2*2
1488  yshift = x(2,n) -yhalf
1489  ysize = max(1.0d0-9,abs(yshift))
1490  nysgn = (int(REAL(tol*yshift/ysize)) +1)/2*2
1491 ! NYSGN = (IFIX(REAL(TOL*YSHIFT/YSIZE)) +1)/2*2
1492  zshift = x(3,n) -zhalf
1493  zsize = max(1.0d0-9,abs(zshift))
1494  nzsgn = (int(REAL(tol*zshift/zsize)) +1)/2*2
1495 ! NZSGN = (IFIX(REAL(TOL*ZSHIFT/ZSIZE)) +1)/2*2
1496  l = 1 +nxsgn/2 +nysgn +2*nzsgn
1497  i = -noctr(1,i) +l -1
1498  xsgn = mod(l,2)
1499  xlow = xsgn*xlow +(1. -xsgn)*xhalf
1500  xhigh = xsgn*xhalf +(1. -xsgn)*xhigh
1501  ysgn = isign(1,2*mod(l-1,4)-3)
1502  ylow = .5*((1. -ysgn)*ylow +(1. +ysgn)*yhalf)
1503  yhigh = .5*((1. -ysgn)*yhalf +(1. +ysgn)*yhigh)
1504  zsgn = isign(1,2*l-9)
1505  zlow = .5*((1. -zsgn)*zlow +(1. +zsgn)*zhalf)
1506  zhigh = .5*((1. -zsgn)*zhalf +(1. +zsgn)*zhigh)
1507  IF (noctr(1,i).LT.0) go to 80
1508  l = 0
1509  IF (noctr(1,i).EQ.0) go to 10
1510  next = noctr(1,i)
1511  85 next = nlink(next)
1512  l = l +1
1513  IF (next.NE.0) go to 85
1514  go to 10
1515  200 WRITE (6,600) n
1516 
1517  WRITE (6,900) n,x(1,n),x(2,n),x(3,n), &
1518  xfar(1),xfar(2),yfar(1),yfar(2),zfar(1),zfar(2)
1519  900 FORMAT('N ',i4,' X ',f8.3,' Y ',f8.3,' Z ',f8.3/ &
1520  'XFAR',2(1x,f8.3),' YFAR',2(1x,f8.3),' ZFAR',2(1x,f8.3))
1521 
1522  stop
1523  210 WRITE (6,610)
1524  stop
1525  600 FORMAT(5x,'POINT N= ',i6,' LIES OUTSIDE CONVEX HULL')
1526  610 FORMAT(5x,'DIMENSION OF NOCTR ARRAY EXCEEDED'/ &
1527  5x,'INCREASE SIZE OF MOCTR')
1528  END SUBROUTINE octfil
1529 
1530 
1531 
1532 
1533 
1534 !
1535 ! ******************************************************************
1536 !
1537  SUBROUTINE octfnd (NCODE,NCLOSE,XPT,YPT,ZPT,N1,N2,N3,DISMIN, &
1538  x,noctr,nlink,xfar,yfar,zfar,idone, &
1539  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
1540  xkeep,ykeep,zkeep,ksrch,nsrch)
1541 !
1542 ! ******************************************************************
1543 ! * *
1544 ! * FIND NEAREST POINT NCLOSE IN OCTREE TO (XPT,YPT,ZPT) *
1545 ! * THAT LIES IN FRONT OF TRIANGLE (N1,N2,N3)
1546 ! * *
1547 ! ******************************************************************
1548 ! ******************************************************************
1549 ! * *
1550 ! * COPYRIGHT (C) TIM BAKER 1994 *
1551 ! * *
1552 ! ******************************************************************
1553 !
1554 !
1555  IMPLICIT NONE
1556 
1557  INTEGER :: ncode,nclose,n1,n2,n3
1558  INTEGER :: idone(*),nlink(*),noctr(2,*)
1559  INTEGER :: nsrch(*),ksrch(*)
1560  DOUBLE PRECISION :: dismin,xpt,ypt,zpt
1561  DOUBLE PRECISION :: x(3,*)
1562  DOUBLE PRECISION :: xoctr(2,*),yoctr(2,*),zoctr(2,*), &
1563  xhold(2,*),yhold(2,*),zhold(2,*), &
1564  xkeep(2),ykeep(2),zkeep(2),xfar(2), &
1565  yfar(2),zfar(2)
1566 
1567  INTEGER :: i,ic,iflag,ii,itry,j,jj,k,kc,l,lflag,next,nxsgn, &
1568  nysgn,nzsgn
1569  DOUBLE PRECISION :: c1,c2,c3,det,dist,dmin,tol,tolpt, &
1570  xhalf,xhigh,xl,xlow,xshift,xsize,xsgn,xu, &
1571  yhalf,yhigh,yl,ylow,yshift,ysize,ysgn,yu, &
1572  zhalf,zhigh,zl,zlow,zshift,zsize,zsgn,zu
1573 !
1574 ! ******************************************************************
1575 !
1576  tolpt = 1.e-6
1577  tol = 1.000001
1578  IF (xpt.LT.xfar(1)-tolpt.OR.xpt.GT.xfar(2)+tolpt) go to 200
1579  IF (ypt.LT.yfar(1)-tolpt.OR.ypt.GT.yfar(2)+tolpt) go to 200
1580  IF (zpt.LT.zfar(1)-tolpt.OR.zpt.GT.zfar(2)+tolpt) go to 200
1581  IF (n1.EQ.0) go to 5
1582 !
1583 ! FORM INWARD POINTING NORMAL FOR TRIANGLE (N1,N2,N3)
1584 !
1585  c1 = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
1586  c2 = cofact(x(1,n1),x(1,n2),x(1,n3),x(3,n1),x(3,n2),x(3,n3))
1587  c3 = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
1588 !
1589 ! FIRST FIND OCTANT WHICH CONTAINS POINT (XPT,YPT,ZPT)
1590 !
1591  5 i = 1
1592  xlow = xfar(1)
1593  xhigh = xfar(2)
1594  ylow = yfar(1)
1595  yhigh = yfar(2)
1596  zlow = zfar(1)
1597  zhigh = zfar(2)
1598  IF (noctr(1,i).LT.0) go to 20
1599  next = noctr(1,i)
1600  10 next = nlink(next)
1601  IF (next.NE.0) go to 10
1602  go to 50
1603 !
1604 ! LOCATE SUB-OCTANT IN WHICH POINT LIES
1605 !
1606  20 xhalf = .5*(xlow +xhigh)
1607  yhalf = .5*(ylow +yhigh)
1608  zhalf = .5*(zlow +zhigh)
1609  xshift = xpt -xhalf
1610  xsize = max(1.0d0-9,abs(xshift))
1611  nxsgn = (int(REAL(tol*xshift/xsize)) +1)/2*2
1612 ! NXSGN = (IFIX(REAL(TOL*XSHIFT/XSIZE)) +1)/2*2
1613  yshift = ypt -yhalf
1614  ysize = max(1.0d0-9,abs(yshift))
1615  nysgn = (int(REAL(tol*yshift/ysize)) +1)/2*2
1616 ! NYSGN = (IFIX(REAL(TOL*YSHIFT/YSIZE)) +1)/2*2
1617  zshift = zpt -zhalf
1618  zsize = max(1.0d0-9,abs(zshift))
1619  nzsgn = (int(REAL(tol*zshift/zsize)) +1)/2*2
1620 ! NZSGN = (IFIX(REAL(TOL*ZSHIFT/ZSIZE)) +1)/2*2
1621  l = 1 +nxsgn/2 +nysgn +2*nzsgn
1622  i = -noctr(1,i) +l -1
1623  xsgn = mod(l,2)
1624  xlow = xsgn*xlow +(1. -xsgn)*xhalf
1625  xhigh = xsgn*xhalf +(1. -xsgn)*xhigh
1626  ysgn = isign(1,2*mod(l-1,4)-3)
1627  ylow = .5*((1. -ysgn)*ylow +(1. +ysgn)*yhalf)
1628  yhigh = .5*((1. -ysgn)*yhalf +(1. +ysgn)*yhigh)
1629  zsgn = isign(1,2*l-9)
1630  zlow = .5*((1. -zsgn)*zlow +(1. +zsgn)*zhalf)
1631  zhigh = .5*((1. -zsgn)*zhalf +(1. +zsgn)*zhigh)
1632  IF (noctr(1,i).LT.0) go to 20
1633  IF (noctr(1,i).EQ.0) go to 50
1634  next = noctr(1,i)
1635  25 next = nlink(next)
1636  IF (next.NE.0) go to 25
1637 !
1638 ! SEARCH FOR POINT NCLOSE THAT IS NEAREST TO (XPT,YPT,ZPT)
1639 !
1640  50 nclose = 1
1641  dismin = (xfar(2) -xfar(1))**2 +(yfar(2) -yfar(1))**2 &
1642  +(zfar(2) -zfar(1))**2
1643  IF (noctr(1,i).EQ.0) go to 65
1644  j = noctr(1,i)
1645  58 IF (idone(j).EQ.0.AND.ncode.EQ.0) go to 60
1646  IF (idone(j).EQ.2) go to 60
1647  IF (n1.EQ.0) go to 59
1648  det = c1*(x(1,j) -xpt) -c2*(x(2,j) -ypt) &
1649  +c3*(x(3,j) -zpt)
1650  IF (det.LT.tolpt) go to 60
1651  59 dist = (xpt -x(1,j))**2 +(ypt -x(2,j))**2 &
1652  +(zpt -x(3,j))**2
1653  IF (dist.GE.dismin) go to 60
1654  nclose = j
1655  dismin = dist
1656  60 j = nlink(j)
1657  IF (j.NE.0) go to 58
1658  65 dmin = sqrt(dismin)
1659  xl = xpt -dmin
1660  xu = xpt +dmin
1661  yl = ypt -dmin
1662  yu = ypt +dmin
1663  zl = zpt -dmin
1664  zu = zpt +dmin
1665  70 IF (xl.GT.xlow.AND.xu.LT.xhigh.AND. &
1666  yl.GT.ylow.AND.yu.LT.yhigh.AND. &
1667  zl.GT.zlow.AND.zu.LT.zhigh) RETURN
1668  IF (i.EQ.1) RETURN
1669  iflag = i
1670  i = noctr(2,i)
1671  lflag = iflag +noctr(1,i) +1
1672  xsgn = mod(lflag,2)
1673  xoctr(1,1) = (2. -xsgn)*xlow -(1. -xsgn)*xhigh
1674  xoctr(2,1) = (1. +xsgn)*xhigh -xsgn*xlow
1675  ysgn = isign(1,2*mod(lflag-1,4)-3)
1676  yoctr(1,1) = .5*((3. +ysgn)*ylow -(1. +ysgn)*yhigh)
1677  yoctr(2,1) = .5*((3. -ysgn)*yhigh -(1. -ysgn)*ylow)
1678  zsgn = isign(1,2*lflag-9)
1679  zoctr(1,1) = .5*((3. +zsgn)*zlow -(1. +zsgn)*zhigh)
1680  zoctr(2,1) = .5*((3. -zsgn)*zhigh -(1. -zsgn)*zlow)
1681  xkeep(1) = xoctr(1,1)
1682  xkeep(2) = xoctr(2,1)
1683  ykeep(1) = yoctr(1,1)
1684  ykeep(2) = yoctr(2,1)
1685  zkeep(1) = zoctr(1,1)
1686  zkeep(2) = zoctr(2,1)
1687 !
1688 ! EXAMINE PARENT OF OCTANT AND ALL ITS OFFSPRING
1689 !
1690  kc = 1
1691  ksrch(1) = i
1692  75 ic = 0
1693  DO 90 j=1,kc
1694  ii = ksrch(j)
1695  DO 90 k=1,8
1696  itry = -noctr(1,ii) +k -1
1697  IF (itry.EQ.iflag) go to 90
1698  xhalf = .5*(xoctr(1,j) +xoctr(2,j))
1699  xsgn = mod(k,2)
1700  xlow = xsgn*xoctr(1,j) +(1. -xsgn)*xhalf
1701  xhigh = xsgn*xhalf +(1. -xsgn)*xoctr(2,j)
1702  yhalf = .5*(yoctr(1,j) +yoctr(2,j))
1703  ysgn = isign(1,2*mod(k-1,4)-3)
1704  ylow = .5*((1. -ysgn)*yoctr(1,j) +(1. +ysgn)*yhalf)
1705  yhigh = .5*((1. -ysgn)*yhalf +(1. +ysgn)*yoctr(2,j))
1706  zhalf = .5*(zoctr(1,j) +zoctr(2,j))
1707  zsgn = isign(1,2*k-9)
1708  zlow = .5*((1. -zsgn)*zoctr(1,j) +(1. +zsgn)*zhalf)
1709  zhigh = .5*((1. -zsgn)*zhalf +(1. +zsgn)*zoctr(2,j))
1710  IF (xl.GT.xhigh.OR.xu.LT.xlow.OR. &
1711  yl.GT.yhigh.OR.yu.LT.ylow.OR. &
1712  zl.GT.zhigh.OR.zu.LT.zlow) go to 90
1713  IF (noctr(1,itry).GE.0) go to 80
1714  ic = ic +1
1715  IF (ic.GT.mxtest) go to 210
1716  xhold(1,ic) = xlow
1717  xhold(2,ic) = xhigh
1718  yhold(1,ic) = ylow
1719  yhold(2,ic) = yhigh
1720  zhold(1,ic) = zlow
1721  zhold(2,ic) = zhigh
1722  nsrch(ic) = itry
1723  go to 90
1724  80 IF (noctr(1,itry).EQ.0) go to 90
1725  jj = noctr(1,itry)
1726  82 IF (idone(jj).EQ.0.AND.ncode.EQ.0) go to 85
1727  IF (idone(jj).EQ.2) go to 85
1728  IF (n1.EQ.0) go to 83
1729  det = c1*(x(1,jj) -xpt) -c2*(x(2,jj) -ypt) &
1730  +c3*(x(3,jj) -zpt)
1731  IF (det.LT.tolpt) go to 85
1732  83 dist = (xpt -x(1,jj))**2 +(ypt -x(2,jj))**2 &
1733  +(zpt -x(3,jj))**2
1734  IF (dist.GE.dismin) go to 85
1735  nclose = jj
1736  dismin = dist
1737  85 jj = nlink(jj)
1738  IF (jj.NE.0) go to 82
1739  dmin = sqrt(dismin)
1740  xl = xpt -dmin
1741  xu = xpt +dmin
1742  yl = ypt -dmin
1743  yu = ypt +dmin
1744  zl = zpt -dmin
1745  zu = zpt +dmin
1746  90 CONTINUE
1747  IF (ic.GT.0) go to 92
1748  xlow = xkeep(1)
1749  xhigh = xkeep(2)
1750  ylow = ykeep(1)
1751  yhigh = ykeep(2)
1752  zlow = zkeep(1)
1753  zhigh = zkeep(2)
1754  go to 70
1755  92 kc = ic
1756  DO 95 j=1,kc
1757  ksrch(j) = nsrch(j)
1758  xoctr(1,j) = xhold(1,j)
1759  xoctr(2,j) = xhold(2,j)
1760  yoctr(1,j) = yhold(1,j)
1761  yoctr(2,j) = yhold(2,j)
1762  zoctr(1,j) = zhold(1,j)
1763  zoctr(2,j) = zhold(2,j)
1764  95 CONTINUE
1765  go to 75
1766  200 WRITE (6,600) xpt,ypt,zpt
1767  stop
1768  210 WRITE (6,610)
1769  stop
1770  600 FORMAT(5x,'POINT XPT = ',f12.4,' YPT = ',f12.4,' ZPT = ',f12.4/ &
1771  5x,'LIES OUTSIDE CONVEX HULL')
1772  610 FORMAT(5x,'DIMENSION OF NSRCH AND KSRCH ARRAYS EXCEEDED'/ &
1773  5x,'IN ROUTINE OCTFND. INCREASE SIZE OF MTEST')
1774  END SUBROUTINE octfnd
1775 
1776 
1777 
1778 
1779 !
1780 ! ******************************************************************
1781 !
1782  SUBROUTINE octrmv (N,X,NOCTR,NLINK,IDONE,NREF)
1783 !
1784 ! ******************************************************************
1785 ! * *
1786 ! * REMOVE POINT N FROM OCTREE DATA STRUCTURE *
1787 ! * *
1788 ! ******************************************************************
1789 ! ******************************************************************
1790 ! * *
1791 ! * COPYRIGHT (C) TIM BAKER 1998 *
1792 ! * *
1793 ! ******************************************************************
1794 !
1795  IMPLICIT NONE
1796 
1797  INTEGER :: n
1798  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
1799  DOUBLE PRECISION :: x(3,*)
1800 
1801  INTEGER :: i,next,npre
1802 !
1803 ! ******************************************************************
1804 !
1805  i = nref(n)
1806  nref(n) = 0
1807  IF (i.EQ.0) go to 200
1808  next = noctr(1,i)
1809  IF (next.NE.n) go to 10
1810  next = nlink(n)
1811  noctr(1,i) = next
1812  nlink(n) = 0
1813  idone(n) = 0
1814  RETURN
1815  10 IF (next.EQ.0) go to 210
1816  npre = next
1817  next = nlink(next)
1818  IF (next.NE.n) go to 10
1819  nlink(npre) = nlink(n)
1820  nlink(n) = 0
1821  idone(n) = 0
1822  RETURN
1823  200 WRITE (6,600) n,x(1,n),x(2,n),x(3,n)
1824  stop
1825  210 WRITE (6,610) n,x(1,n),x(2,n),x(3,n)
1826  stop
1827  600 FORMAT(5x,'POINT ',i6,' HAS AN NREF VALUE OF ZERO'/ &
1828  5x,'X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4)
1829  610 FORMAT(5x,'UNABLE TO FIND POINT WITH ADDRESS ',i6,' IN OCTREE'/ &
1830  5x,'X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4)
1831  END SUBROUTINE octrmv
1832 
1833 
1834 
1835 
1836 !
1837 ! ******************************************************************
1838 !
1839  SUBROUTINE edgerm (NEDG,NDG,IDGP,NDGP)
1840 !
1841 ! ******************************************************************
1842 ! * *
1843 ! * REMOVE EDGE NEDG FROM LINKED LIST OF EDGES *
1844 ! * *
1845 ! ******************************************************************
1846 ! ******************************************************************
1847 ! * *
1848 ! * COPYRIGHT (C) TIM BAKER 1994 *
1849 ! * *
1850 ! ******************************************************************
1851 !
1852  IMPLICIT NONE
1853 
1854  INTEGER :: nedg
1855  INTEGER :: ndg(2,*),idgp(*),ndgp(*)
1856 
1857  INTEGER :: i,iedg,n1
1858 !
1859 ! ******************************************************************
1860 !
1861  IF (nedg.EQ.0) go to 200
1862  n1 = min(ndg(1,nedg),ndg(2,nedg))
1863  ndg(1,nedg) = -1
1864  ndg(2,nedg) = -1
1865  i = idgp(n1)
1866  IF (i.NE.nedg) go to 10
1867  i = ndgp(i)
1868  idgp(n1) = i
1869  IF (i.EQ.0) RETURN
1870  iedg = i
1871  go to 20
1872  10 iedg = i
1873  i = ndgp(i)
1874  IF (i.EQ.0) go to 210
1875  IF (i.NE.nedg) go to 10
1876  20 i = ndgp(i)
1877  ndgp(iedg) = i
1878  IF (i.EQ.0) RETURN
1879  iedg = i
1880  go to 20
1881  200 WRITE (6,600)
1882  stop
1883  210 WRITE (6,610)
1884  stop
1885  600 FORMAT(//5x,'EDGE REQUESTED HAS ADDRESS ZERO'/ &
1886  5x,'PROGRAM STOPPED IN EDGERM')
1887  610 FORMAT(//5x,'UNABLE TO FIND EDGE IN LINKED LIST'/ &
1888  5x,'PROGRAM STOPPED IN EDGERM')
1889  END SUBROUTINE edgerm
1890 
1891 
1892 
1893 
1894 !
1895 ! ******************************************************************
1896 !
1897  SUBROUTINE tree (PROP,NLEFT,NRIGHT,NBACK,LISTF,NACPT,NTOT, &
1898  nbh,iprot,ncell)
1899 !
1900 ! ******************************************************************
1901 ! * *
1902 ! * CREATE A BINARY TREE AND ASSEMBLE AN ORDERED LIST WITH *
1903 ! * RESPECT TO THE SIZE OF THE SCALAR PROPERTY PROP *
1904 ! * *
1905 ! ******************************************************************
1906 ! ******************************************************************
1907 ! * *
1908 ! * COPYRIGHT (C) TIM BAKER 1994 *
1909 ! * *
1910 ! ******************************************************************
1911 !
1912  IMPLICIT NONE
1913 
1914  INTEGER :: ncell,ntot
1915  INTEGER :: nbh(4,*),iprot(*)
1916  INTEGER :: nleft(*),nright(*),nback(*),listf(*),nacpt(*)
1917  DOUBLE PRECISION :: prop(*)
1918 
1919  INTEGER :: j,jback,jj,jnext,jprobe,jstart,l,ncnt,nj
1920  DOUBLE PRECISION :: tol
1921 !
1922 ! ******************************************************************
1923 !
1924  tol = 1.e-12
1925 !
1926 ! CREATE BINARY TREE
1927 !
1928  ntot = 0
1929  j = 0
1930  10 j = j +1
1931  IF (j.GT.ncell) go to 90
1932  IF (iprot(j).EQ.1) go to 10
1933  IF (nbh(1,j).EQ.0) go to 10
1934  jstart = j
1935  nback(j) = 0
1936  nleft(j) = 0
1937  nright(j) = 0
1938  ntot = 1
1939  20 j = j +1
1940  IF (j.GT.ncell) go to 90
1941  IF (iprot(j).EQ.1) go to 20
1942  IF (nbh(1,j).EQ.0) go to 20
1943  jj = jstart
1944  30 jnext = nleft(jj)
1945  IF (prop(j).GT.prop(jj)) jnext = nright(jj)
1946  IF (jnext.EQ.0) go to 40
1947  jj = jnext
1948  go to 30
1949  40 IF (prop(j).GT.prop(jj)) go to 50
1950  nleft(jj) = j
1951  nback(j) = -jj
1952  go to 60
1953  50 nright(jj) = j
1954  nback(j) = jj
1955  60 nleft(j) = 0
1956  nright(j) = 0
1957  ntot = ntot +1
1958  go to 20
1959 !
1960 ! ASSEMBLE ORDERED LIST
1961 !
1962  90 IF (ntot.EQ.0) RETURN
1963  ncnt = 0
1964  jprobe = jstart
1965  100 j = nright(jprobe)
1966  IF (j.EQ.0) go to 110
1967  jprobe = j
1968  go to 100
1969  110 j = jprobe
1970  ncnt = ncnt +1
1971  listf(ncnt) = j
1972  nacpt(j) = 0
1973  go to 120
1974  115 ncnt = ncnt +1
1975  listf(ncnt) = j
1976  nacpt(j) = 0
1977  120 jprobe = nleft(j)
1978  IF (jprobe.GT.0) go to 100
1979  125 jback = nback(j)
1980  IF (jback.EQ.0) go to 140
1981  nj = isign(1,jback)
1982  j = iabs(jback)
1983  IF (nj.GT.0) go to 115
1984  go to 125
1985  140 DO 150 l=1,ncell
1986  nback(l) = 0
1987  150 CONTINUE
1988  RETURN
1989  END SUBROUTINE tree
1990 
1991 
1992 
1993 
1994 
1995 !
1996 ! ******************************************************************
1997 !
1998  SUBROUTINE snglar (NNODE,X,XD,NCELL,NDC,NBH,SIGMN,SIGMX, &
1999  sig1,sig2,sig3,cndmin,cndmax)
2000 !
2001 ! ******************************************************************
2002 ! * *
2003 ! * DETERMINE THE SINGULAR VALUES SIG1(L), SIG2(L), SIG3(L) OF *
2004 ! * THE MATRIX ASSOCIATED WITH THE DEFORMATION OF EACH *
2005 ! * TETRAHEDRON L IN THE DISPLACED MESH. *
2006 ! * *
2007 ! ******************************************************************
2008 ! ******************************************************************
2009 ! * *
2010 ! * X(3,N) contains the original x, y, z coordinates of the *
2011 ! * Nth point in the mesh. *
2012 ! * *
2013 ! * XD(3,N) contains the x, y, z displacements of the Nth point *
2014 ! * in the mesh. *
2015 ! * *
2016 ! * NDC(4,L) contains the vertex addresses of the 4 vertices *
2017 ! * of tetrahedron L. *
2018 ! * *
2019 ! * NBH(4,L) contains the addresses of the 4 tetrahedra that *
2020 ! * are neighbors to tetrahedron L. *
2021 ! * (NBH is required if SNGLAR is called from the *
2022 ! * mesh modification routines. If SNGLAR is called *
2023 ! * from CRUNCH then NBH is not needed and the IF *
2024 ! * statement, in which NBH appears, can be commented *
2025 ! * out.) *
2026 ! * *
2027 ! * NNODE is the total number of mesh points. *
2028 ! * *
2029 ! * NCELL is the total number of mesh tetrahedra. *
2030 ! * *
2031 ! * SIGMN and SIGMX are scalar values returned by SNGLAR which *
2032 ! * which give the minimum and maximum, over the whole mesh, of *
2033 ! * the singular values of the deformation matrices. *
2034 ! * *
2035 ! * SIG1,SIG2,SIG3 are vector quantities returned by SNGLAR *
2036 ! * which contain the singular values of the deformation matrix *
2037 ! * for each tetrahedron in the mesh. SIG1,SIG2 and SIG3 should *
2038 ! * each be given dimension MCELL. *
2039 ! * If, for any given tetrahedron, SIG1 = 1, SIG2 = 1 and *
2040 ! * SIG3 = 1 then the tetrahedron has not changed shape, *
2041 ! * although it may have undergone a rotation or an isotropic *
2042 ! * expansion or compression. *
2043 ! * If any of the singular values is close to zero then the *
2044 ! * tetrahedron has become highly compressed. *
2045 ! * *
2046 ! ******************************************************************
2047 ! ******************************************************************
2048 ! * *
2049 ! * COPYRIGHT (C) TIM BAKER 2001 *
2050 ! * *
2051 ! ******************************************************************
2052 !
2053  IMPLICIT NONE
2054 
2055  INTEGER :: ncell,nnode
2056  INTEGER ndc(4,*),nbh(4,*)
2057  DOUBLE PRECISION :: cndmax,cndmin,sigmn,sigmx
2058  DOUBLE PRECISION :: x(3,*),xd(3,*),sig1(*),sig2(*),sig3(*)
2059 
2060  INTEGER :: l,lmax,lmin,npass,n1,n2,n3,n4
2061  DOUBLE PRECISION :: a0,a1,a11,a12,a13,a2,a21,a22,a23,a31,a32,a33, &
2062  b1,b2,b3,b4,b4sq,b5,b5sq,b6,b6sq,cond,ct, &
2063  d,delx1,delx2,delx3,dely1,dely2,dely3, &
2064  delz1,delz2,delz3,det,dsq,dx1,dx2,dx3, &
2065  dy1,dy2,dy3,dz1,dz2,dz3,fac,p1,p2,q,qa, &
2066  qroot,r,s,siglow,siglrg,slide,slidcb,slidsq, &
2067  st,s1x,s1y,s1z,s2x,s2y,s2z,s3x,s3y,s3z, &
2068  theta,third,tol
2069 !
2070 ! ******************************************************************
2071 !
2072  tol = 1.e-12
2073  third = 1./3.
2074  npass = 0
2075  DO 100 l=1,ncell
2076  IF (nbh(1,l).EQ.0) go to 100
2077  IF (ndc(4,l).LE.0) go to 100
2078  n1 = ndc(1,l)
2079  n2 = ndc(2,l)
2080  n3 = ndc(3,l)
2081  n4 = ndc(4,l)
2082 !
2083 ! COMPUTE ENTRIES, COFACTORS AND DETERMINANT
2084 ! OF THE ORIGINAL EDGE MATRIX T
2085 !
2086  dx1 = x(1,n2) -x(1,n1)
2087  dy1 = x(2,n2) -x(2,n1)
2088  dz1 = x(3,n2) -x(3,n1)
2089  dx2 = x(1,n3) -x(1,n1)
2090  dy2 = x(2,n3) -x(2,n1)
2091  dz2 = x(3,n3) -x(3,n1)
2092  dx3 = x(1,n4) -x(1,n1)
2093  dy3 = x(2,n4) -x(2,n1)
2094  dz3 = x(3,n4) -x(3,n1)
2095  s1x = dy2*dz3 -dy3*dz2
2096  s1y = dz2*dx3 -dz3*dx2
2097  s1z = dx2*dy3 -dx3*dy2
2098  s2x = dy3*dz1 -dy1*dz3
2099  s2y = dz3*dx1 -dz1*dx3
2100  s2z = dx3*dy1 -dx1*dy3
2101  s3x = dy1*dz2 -dy2*dz1
2102  s3y = dz1*dx2 -dz2*dx1
2103  s3z = dx1*dy2 -dx2*dy1
2104  det = dx1*s1x +dy1*s1y +dz1*s1z
2105  IF (abs(det).LT.tol) go to 300
2106  fac = 1./det
2107 !
2108 ! COMPUTE EDGE DISPLACEMENTS AND ENTRIES
2109 ! FOR THE DEFORMATION MATRIX A = Tnew * T^(-1)
2110 !
2111  delx1 = xd(1,n2) -xd(1,n1)
2112  dely1 = xd(2,n2) -xd(2,n1)
2113  delz1 = xd(3,n2) -xd(3,n1)
2114  delx2 = xd(1,n3) -xd(1,n1)
2115  dely2 = xd(2,n3) -xd(2,n1)
2116  delz2 = xd(3,n3) -xd(3,n1)
2117  delx3 = xd(1,n4) -xd(1,n1)
2118  dely3 = xd(2,n4) -xd(2,n1)
2119  delz3 = xd(3,n4) -xd(3,n1)
2120  a11 = (delx1*s1x +delx2*s2x +delx3*s3x)*fac
2121  a12 = (delx1*s1y +delx2*s2y +delx3*s3y)*fac
2122  a13 = (delx1*s1z +delx2*s2z +delx3*s3z)*fac
2123  a21 = (dely1*s1x +dely2*s2x +dely3*s3x)*fac
2124  a22 = (dely1*s1y +dely2*s2y +dely3*s3y)*fac
2125  a23 = (dely1*s1z +dely2*s2z +dely3*s3z)*fac
2126  a31 = (delz1*s1x +delz2*s2x +delz3*s3x)*fac
2127  a32 = (delz1*s1y +delz2*s2y +delz3*s3y)*fac
2128  a33 = (delz1*s1z +delz2*s2z +delz3*s3z)*fac
2129 !
2130 ! COMPUTE THE ENTRIES FOR THE POSITIVE DEFINITE MATRIX A^T * A
2131 !
2132  b1 = (1. +a11)**2 +a21*a21 +a31*a31
2133  b2 = a12*a12 +(1. +a22)**2 +a32*a32
2134  b3 = a13*a13 +a23*a23 +(1. +a33)**2
2135  b4 = a12*(1. +a11) +a21*(1. +a22) +a31*a32
2136  b5 = a13*(1. +a11) +a21*a23 +a31*(1. +a33)
2137  b6 = a12*a13 +a23*(1. +a22) +a32*(1. +a33)
2138 !
2139 ! COMPUTE THE COEFFICIENTS OF CHARACTERISTIC POLYNOMIAL
2140 ! LAMBDA^3 + A2*LAMBDA^2 + A1*LAMBDA + A0 = 0
2141 !
2142  b4sq = b4*b4
2143  b5sq = b5*b5
2144  b6sq = b6*b6
2145  a0 = b1*b6sq +b2*b5sq +b3*b4sq -b1*b2*b3 -2.*b4*b5*b6
2146  a1 = b1*b2 +b1*b3 +b2*b3 -b4sq -b5sq -b6sq
2147  a2 = -b1 -b2 -b3
2148 !
2149 ! COMPUTE THE THREE EIGENVALUES GIVEN BY THE ROOTS OF THE
2150 ! CUBIC POLYNOMIAL. THESE EIGENVALUES SHOULD ALL BE REAL AND
2151 ! POSITIVE. THE SINGULAR VALUES ARE GIVEN BY THE SQUARE ROOTS
2152 ! OF THE EIGENVALUES.
2153 !
2154  slide = a2*third
2155  slidsq = slide*slide
2156  slidcb = slidsq*slide
2157  q = a1*third -slidsq
2158  r = .5*third*(a1*a2 -3.*a0) -slidcb
2159  dsq = -q**3 -r*r
2160  IF (dsq+tol.LT.0.) WRITE (6,900) a0,a1,a2,r,q,dsq
2161  dsq = abs(dsq)
2162  IF (dsq.LT.tol) THEN
2163  IF (r.LT.tol) THEN
2164  s = 0.
2165  ELSE
2166  s = r**third
2167  ENDIF
2168  sig1(l) = 2.*s -slide
2169  sig2(l) = -s -slide
2170  sig3(l) = sig2(l)
2171  ELSE
2172  d = sqrt(dsq)
2173  theta = atan2(d,r)
2174  ct = cos(theta*third)
2175  st = sin(theta*third)
2176  qa = max(0.0d0,-q)
2177  qroot = sqrt(qa)
2178  p1 = qroot*ct
2179  p2 = qroot*st*sqrt(3.0d0)
2180  sig1(l) = 2.*p1 -slide
2181  sig2(l) = -p1 -p2 -slide
2182  sig3(l) = -p1 +p2 -slide
2183  ENDIF
2184  IF (min(sig1(l),sig2(l),sig3(l)).LT.0.) THEN
2185  IF (min(sig1(l),sig2(l),sig3(l))+tol.LT.0.) THEN
2186  go to 320
2187  ELSE
2188  sig1(l) = max(0.0d0,sig1(l))
2189  sig2(l) = max(0.0d0,sig2(l))
2190  sig3(l) = max(0.0d0,sig3(l))
2191  ENDIF
2192  ENDIF
2193  sig1(l) = max(tol,sig1(l))
2194  sig2(l) = max(tol,sig2(l))
2195  sig3(l) = max(tol,sig3(l))
2196  sig1(l) = sqrt(sig1(l))
2197  sig2(l) = sqrt(sig2(l))
2198  sig3(l) = sqrt(sig3(l))
2199  siglrg = max(sig1(l),sig2(l),sig3(l))
2200  siglow = min(sig1(l),sig2(l),sig3(l))
2201  IF (siglow.GT.1.e-8) THEN
2202  cond = siglrg/siglow
2203  ELSE
2204  cond = 0.
2205  ENDIF
2206  IF (npass.EQ.0) THEN
2207  npass = 1
2208  cndmin = cond
2209  cndmax = cond
2210  sigmn = siglow
2211  sigmx = siglrg
2212  lmin = l
2213  lmax = l
2214  ELSE
2215  IF (siglow.LT.sigmn) lmin = l
2216  IF (siglrg.GT.sigmx) lmax = l
2217  sigmn = min(sigmn,siglow)
2218  sigmx = max(sigmx,siglrg)
2219  cndmin = min(cndmin,cond)
2220  cndmax = max(cndmax,cond)
2221  ENDIF
2222  100 CONTINUE
2223  RETURN
2224  300 WRITE (6,600) n1,n2,n3,n4
2225  stop
2226  310 WRITE (6,610)
2227  WRITE (6,900) a0,a1,a2,r,q,dsq
2228  stop
2229  320 WRITE (6,620) l,sig1(l),sig2(l),sig3(l)
2230  stop
2231  600 FORMAT(//5x,'A ZERO VOLUME TETRAHEDRON HAS BEEN FOUND IN THE '// &
2232  'UNDEFORMED MESH'//5x,'THE VERTICES OF THE ELEMENT '// &
2233  'ARE ',i7,' , ',i7,' , ',i7,' AND ',i7// &
2234  5x,'PROGRAM STOPPED IN ROUTINE SNGLAR.')
2235  610 FORMAT(//5x,'THE DISCRIMINANT ASSOCIATED WITH THE SOLUTION OF', &
2236  5x,'CUBIC EQUATION FOR THE SINGULAR VALUES OF THE', &
2237  5x,'DEFORMATION MATRIX IS POSITIVE, THUS INDICATING', &
2238  5x,'ONLY ONE REAL ROOT. THERE APPEARS TO BE AN ERROR IN', &
2239  5x,'THE CODING FOR THE COMPUTATION OF SINGULAR VALUES.', &
2240  5x,'PROGRAM STOPPED IN ROUTINE SNGLAR.')
2241  620 FORMAT(//5x,'AT LEAST ONE OF THE SINGULAR VALUES SQUARED IS', &
2242  5x,'NEGATIVE. THERE THUS APPEARS TO BE AN ERROR IN', &
2243  5x,'THE CODING FOR THE COMPUTATION OF SINGULAR VALUES.', &
2244  5x,'PROGRAM STOPPED IN ROUTINE SNGLAR.'//5x,'CELL ',i7, &
2245  ' SIG1 = ',e13.5,' SIG2 = ',e13.5,' SIG3 = ',e13.5)
2246  900 FORMAT(/5x,'A POSITIVE DISCRIMINANT HAS BEEN COMPUTED WHEN', &
2247  5x,'SOLVING THE CUBIC EQUATION FOR THE SINGULAR VALUES', &
2248  5x,'OF THE DEFORMATION MATRIX, THUS INDICATING ONLY', &
2249  5x,'ONE REAL ROOT.'// 5x,'COEFFICIENTS ARE ', &
2250  'A0 = ',f10.4,' A1 = ',f10.4,' A2 = ',f10.4, &
2251  5x,'R = ',e13.5,' Q = ',e13.5,' DSQ = ',e13.5)
2252  END SUBROUTINE snglar
2253 
2254 
2255 
2256 
2257 !
2258 ! ******************************************************************
2259 !
2260  SUBROUTINE densfn (X,NNODE,NFCE,NBFACE,NEDGE,NDG,DENS,RESID,FVCNT)
2261 !
2262 ! ******************************************************************
2263 ! * *
2264 ! * EVALUATE DENSITY FUNCTION FOR ALL MESH POINTS *
2265 ! * *
2266 ! ******************************************************************
2267 ! ******************************************************************
2268 ! * *
2269 ! * COPYRIGHT (C) TIM BAKER 1998 *
2270 ! * *
2271 ! ******************************************************************
2272 !
2273  IMPLICIT NONE
2274 
2275  INTEGER :: nbface,nedge,nnode
2276  INTEGER :: ndg(2,*),nfce(3,*)
2277  DOUBLE PRECISION :: x(3,*),dens(*)
2278  DOUBLE PRECISION :: fvcnt(*),resid(*)
2279 
2280  INTEGER :: i,it,j,k,n,n1,n2
2281  DOUBLE PRECISION :: difden,dist,eps,rmax,rmax1
2282 !
2283 ! ******************************************************************
2284 !
2285  eps = 1.
2286 !
2287 ! SET INITIAL DENSITY FUNCTION TO ZERO
2288 !
2289  DO 10 n=1,nnode
2290  fvcnt(n) = 0.
2291  dens(n) = 0.
2292  10 CONTINUE
2293 !
2294 ! INITIALIZE FVCNT TO -1 FOR BOUNDARY POINTS
2295 !
2296  DO 15 j=1,nbface
2297  DO 15 k=1,3
2298  n = nfce(k,j)
2299  IF (n.GT.0) THEN
2300  fvcnt(n) = -1.
2301  ENDIF
2302  15 CONTINUE
2303 !
2304 ! ESTABLISH INITIAL GUESS FOR DENSITY FUNCTION FOR ALL MESH POINTS
2305 !
2306  DO 20 i=1,nedge
2307  n1 = ndg(1,i)
2308  n2 = ndg(2,i)
2309  IF (n1.LE.0.OR.n2.LE.0) go to 20
2310  dist = sqrt((x(1,n1) -x(1,n2))**2 +(x(2,n1) -x(2,n2))**2 &
2311  +(x(3,n1) -x(3,n2))**2)
2312  IF (fvcnt(n1).GE.0.) THEN
2313  fvcnt(n1) = fvcnt(n1) +1.
2314  dens(n1) = dens(n1) +dist
2315  ELSE
2316  IF (fvcnt(n2).LT.0.) THEN
2317  fvcnt(n1) = fvcnt(n1) -1.
2318  dens(n1) = dens(n1) +dist
2319  fvcnt(n2) = fvcnt(n2) -1.
2320  dens(n2) = dens(n2) +dist
2321  ENDIF
2322  ENDIF
2323  IF (fvcnt(n2).GE.0.) THEN
2324  fvcnt(n2) = fvcnt(n2) +1.
2325  dens(n2) = dens(n2) +dist
2326  ENDIF
2327  20 CONTINUE
2328 !
2329 ! NORMALIZE DENSITY FUNCTION BY NUMBER OF EDGES MEETING AT A VERTEX
2330 !
2331  DO 30 n=1,nnode
2332  IF (fvcnt(n).LT.0.) fvcnt(n) = fvcnt(n) +1.
2333  IF (abs(fvcnt(n)).LT.1.) go to 30
2334  fvcnt(n) = 1./fvcnt(n)
2335  dens(n) = abs(fvcnt(n))*dens(n)
2336  30 CONTINUE
2337 !
2338 ! START OF ITERATIVE CYCLE
2339 !
2340  it = 0
2341  65 it = it +1
2342 !
2343 ! SET INITIAL RESIDUALS TO ZERO
2344 !
2345  DO 70 n=1,nnode
2346  resid(n) = 0.
2347  70 CONTINUE
2348 !
2349 ! ACCUMMULATE EDGE DIFFERENCES OF DENSITY FUNCTION FOR ALL
2350 ! EDGES INCIDENT TO EACH POINT
2351 !
2352  DO 75 i=1,nedge
2353  n1 = ndg(1,i)
2354  n2 = ndg(2,i)
2355  IF (n1.LE.0.OR.n2.LE.0) go to 75
2356  difden = dens(n1) -dens(n2)
2357  resid(n1) = resid(n1) -difden
2358  resid(n2) = resid(n2) +difden
2359  75 CONTINUE
2360 !
2361 ! UPDATE DENSITY FUNCTION AT EACH NON-BOUNDARY POINT
2362 !
2363  rmax = 0.
2364  DO 80 n=1,nnode
2365  IF (fvcnt(n).LT.0.) go to 80
2366  dens(n) = dens(n) +eps*fvcnt(n)*resid(n)
2367  rmax = max(rmax,abs(resid(n)))
2368  80 CONTINUE
2369 
2370 ! WRITE (6,900) IT,RMAX
2371 
2372  IF (it.EQ.1) rmax1 = rmax
2373  IF (rmax.GT.max(0.0001*rmax1,1.0d0-9).AND.it.LT.1000) go to 65
2374  WRITE (6,900) it,rmax
2375  900 FORMAT('IN DENSFN..., IT = ',i4,' RMAX = ',f10.6)
2376 !
2377 ! ITERATIVE CYCLE IS COMPLETE
2378 !
2379 ! TIM = SECOND (0)
2380 ! WRITE (6,700) TIM
2381 ! 700 FORMAT(/'TIME = ',F7.1,' SECONDS'/)
2382  RETURN
2383  END SUBROUTINE densfn
2384 
2385 
2386 
2387 
2388 
2389 !
2390 ! ******************************************************************
2391 !
2392  SUBROUTINE edglen (X,NNODE,ITYP,NEDGE,NDG,DENS,NVCNT)
2393 !
2394 ! ******************************************************************
2395 ! * *
2396 ! * COMPARE EDGE LENGTHS WITH DENSITY FUNCTION. *
2397 ! * *
2398 ! ******************************************************************
2399 ! ******************************************************************
2400 ! * *
2401 ! * COPYRIGHT (C) TIM BAKER 2001 *
2402 ! * *
2403 ! ******************************************************************
2404 !
2405  IMPLICIT NONE
2406 
2407  INTEGER :: nedge,nnode
2408  INTEGER :: ndg(2,*),ityp(*),nvcnt(*)
2409  DOUBLE PRECISION :: x(3,*),dens(*)
2410 
2411  INTEGER :: i,n,nhigh,nlow,nmid,npass,ntot,nvmax,nvmin,n1,n2
2412  DOUBLE PRECISION :: densav,dsqav
2413 !
2414 ! ******************************************************************
2415 !
2416  nlow = 0
2417  nmid = 0
2418  nhigh = 0
2419 !
2420 ! COMPUTE EDGE VALENCE OF EACH MESH POINT
2421 !
2422  DO 10 n=1,nnode
2423  nvcnt(n) = 0
2424  10 CONTINUE
2425  DO 20 i=1,nedge
2426  n1 = ndg(1,i)
2427  n2 = ndg(2,i)
2428  IF (n1.LE.0.OR.n2.LE.0) go to 20
2429  nvcnt(n1) = nvcnt(n1) +1
2430  nvcnt(n2) = nvcnt(n2) +1
2431  densav = .5*(dens(n1) +dens(n2))
2432  dsqav = sqrt((x(1,n1) -x(1,n2))**2 +(x(2,n1) -x(2,n2))**2 &
2433  +(x(3,n1) -x(3,n2))**2)
2434  IF (dsqav.LT.0.5*densav) nlow = nlow +1
2435  IF (dsqav.GT.1.5*densav) nhigh = nhigh +1
2436  IF (dsqav.GE.0.5*densav.AND.dsqav.LE.1.5*densav) nmid = nmid +1
2437  20 CONTINUE
2438  ntot = nlow +nmid +nhigh
2439  WRITE (6,600) nlow,nmid,nhigh,ntot
2440  nvmax = 0
2441  nvmin = 0
2442  npass = 0
2443  DO 25 n=1,nnode
2444  IF (ityp(n).GE.0) THEN
2445  IF (npass.EQ.0) THEN
2446  npass = 1
2447  nvmax = nvcnt(n)
2448  nvmin = nvcnt(n)
2449  ELSE
2450  nvmax = max(nvmax,nvcnt(n))
2451  nvmin = min(nvmin,nvcnt(n))
2452  ENDIF
2453 ! ELSE
2454 ! WRITE (6,920) N,ITYP(N)
2455 ! 920 FORMAT('pt ',I5,' ITYP ',I3)
2456  ENDIF
2457  25 CONTINUE
2458  WRITE (6,610) nvmin,nvmax
2459  RETURN
2460  600 FORMAT(/5x,'NLOW = ',i6,' NMID = ',i6,' NHIGH = ',i6, &
2461  ' NTOT = ',i6)
2462  610 FORMAT(/5x,'MIN EDGE VALENCE = ',i3,' MAX EDGE VALENCE = ',i3)
2463  END SUBROUTINE edglen
2464 
2465 
2466 
2467 
2468 
2469 !
2470 ! ******************************************************************
2471 !
2472  SUBROUTINE coarsn (LC,X,NNODE,NDC,NBH,IPROT,NCELL, &
2473  ityp,xcen,ycen,zcen,vol,rc,rat, &
2474  nvcnt,dens,iflag,nflag,nptet, &
2475  nedge,ndg,idgp,ndgp, &
2476  noctr,ioctr,nlink,xfar,yfar,zfar,idone,nref, &
2477  fac,sig1,sig2,sig3, &
2478  ksrch,nsrch,iring,ntetkp, &
2479  lnbr,ishk,mnbr,kshk,tolv)
2480 !
2481 ! ******************************************************************
2482 ! * *
2483 ! * CALL ROUTINE COLAPS TO MERGE POINTS ASSOCIATED WITH SELECTED *
2484 ! * EDGES *
2485 ! * *
2486 ! ******************************************************************
2487 ! ******************************************************************
2488 ! * *
2489 ! * COPYRIGHT (C) TIM BAKER 1998 *
2490 ! * *
2491 ! ******************************************************************
2492 !
2493  IMPLICIT NONE
2494 
2495  INTEGER :: ioctr,lc,ncell,nedge,nnode
2496  INTEGER :: ityp(*),ndc(4,*),nbh(4,*),iprot(*),ndg(2,*)
2497  INTEGER :: idgp(*),ndgp(*),nvcnt(*),nptet(*)
2498  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
2499  INTEGER :: iflag(*),nflag(*),nsrch(*),ksrch(*)
2500  INTEGER :: iring(*),ntetkp(*),lnbr(*),ishk(*),mnbr(*),kshk(*)
2501  DOUBLE PRECISION :: tolv
2502  DOUBLE PRECISION :: x(3,*),dens(*),fac(*)
2503  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
2504  DOUBLE PRECISION :: sig1(*),sig2(*),sig3(*)
2505  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
2506 
2507  INTEGER :: i,j,l,n,ncol,nfail,npts,ntest,ntet,n1,n2,n3,n4
2508  DOUBLE PRECISION :: densav,dist,sigmax,sigmin,excess,expand
2509 !
2510 ! ******************************************************************
2511 !
2512 !
2513 ! COMPUTE EDGE VALENCE OF EACH MESH POINT
2514 !
2515  DO 10 n=1,nnode
2516  nvcnt(n) = 0
2517  fac(n) = 0.
2518  10 CONTINUE
2519  DO 20 i=1,nedge
2520  n1 = ndg(1,i)
2521  n2 = ndg(2,i)
2522  IF (n1.LE.0.OR.n2.LE.0) go to 20
2523  nvcnt(n1) = nvcnt(n1) +1
2524  nvcnt(n2) = nvcnt(n2) +1
2525  20 CONTINUE
2526 !
2527 ! SELECT TETRAHEDRA TO BE REMOVED
2528 !
2529  ncol = 0
2530  DO 30 j=1,ncell
2531  IF (nbh(1,j).LE.0) go to 30
2532  IF (ndc(4,j).EQ.-1) go to 30
2533  IF (lc.EQ.1) THEN
2534  sigmax = max(sig1(j),sig2(j),sig3(j))
2535  sigmin = min(sig1(j),sig2(j),sig3(j))
2536  expand = min(1.0d0,sigmax/sigmin -1.)
2537  ELSE
2538  excess = max(0.0d0,rat(j)-20.)
2539  expand = min(1.0d0,excess/100.)
2540  ENDIF
2541  n1 = ndc(1,j)
2542  n2 = ndc(2,j)
2543  n3 = ndc(3,j)
2544  n4 = ndc(4,j)
2545  fac(n1) = fac(n1) +expand
2546  fac(n2) = fac(n2) +expand
2547  fac(n3) = fac(n3) +expand
2548  fac(n4) = fac(n4) +expand
2549  30 CONTINUE
2550  DO 35 n=1,nnode
2551  IF (ityp(n).GE.0) THEN
2552  dens(n) = dens(n)*(1. +fac(n)/float(nvcnt(n)))
2553  ENDIF
2554  35 CONTINUE
2555 !
2556 ! COLLAPSE EDGES THAT ARE TOO SHORT COMPARED WITH THE LENGTH
2557 ! DENSITY FUNCTION.
2558 !
2559  DO 40 i=1,nedge
2560  n1 = ndg(1,i)
2561  n2 = ndg(2,i)
2562  IF (n1.LE.0.OR.n2.LE.0) go to 40
2563  densav = .5*(dens(n1) +dens(n2))
2564  dist = sqrt((x(1,n1) -x(1,n2))**2 +(x(2,n1) -x(2,n2))**2 &
2565  +(x(3,n1) -x(3,n2))**2)
2566  IF (dist.GE.0.4*densav) go to 40
2567 
2568  CALL colaps(n1,n2,ncol,ntest,nfail, &
2569  x,ndc,nbh,iprot, &
2570  ityp,xcen,ycen,zcen,vol,rc,rat, &
2571  nvcnt,iflag,nflag,nptet, &
2572  ndg,idgp,ndgp, &
2573  noctr,ioctr,nlink,xfar,yfar,zfar,idone,nref, &
2574  ksrch,nsrch,iring,ntetkp, &
2575  lnbr,ishk,mnbr,kshk,tolv)
2576 
2577  40 CONTINUE
2578 !
2579 ! WRITE OUT NUMBER OF MESH POINTS AND TRIANGLES
2580 !
2581  npts = 0
2582  DO 50 n=1,nnode
2583  IF (ityp(n).LT.0) go to 50
2584  npts = npts +1
2585  50 CONTINUE
2586  ntet = 0
2587  DO 60 l=1,ncell
2588  IF (nbh(1,l).EQ.0) go to 60
2589  IF (ndc(4,l).EQ.-1) go to 60
2590  ntet = ntet +1
2591  60 CONTINUE
2592  WRITE (6,730) npts,ncol,ntet
2593  RETURN
2594  730 FORMAT(/'MESH COARSENING COMPLETE'/ &
2595  5x,i7,' TOTAL MESH POINTS'/ &
2596  5x,i7,' FIELD POINTS REMOVED'/ &
2597  5x,i7,' MESH CELLS'/)
2598  END SUBROUTINE coarsn
2599 
2600 
2601 
2602 
2603 
2604 
2605 
2606 !
2607 ! ******************************************************************
2608 !
2609  SUBROUTINE radrat (X,NNODE,NDC,NBH,IPROT,NCELL,NFCE,NBFACE, &
2610  ityp,ipoint,vol,rc,rat)
2611 !
2612 ! ******************************************************************
2613 ! * *
2614 ! * DETERMINE MINIMUM AND MAXIMUM VOLUMES AND STATISTICS ON THE *
2615 ! * RATIO OF CIRCUMRADIUS TO IN-RADIUS FOR ALL TETRAHEDRA *
2616 ! * *
2617 ! ******************************************************************
2618 ! ******************************************************************
2619 ! * *
2620 ! * COPYRIGHT (C) TIM BAKER 1994 *
2621 ! * *
2622 ! ******************************************************************
2623 !
2624  IMPLICIT NONE
2625 
2626  INTEGER :: nbface,ncell,nnode
2627  INTEGER :: nbh(4,*),iprot(*),ityp(*),ipoint(*)
2628  INTEGER :: nfce(3,*),ndc(4,*)
2629  DOUBLE PRECISION :: x(3,*)
2630  DOUBLE PRECISION :: vol(*),rc(*),rat(*)
2631 !
2632  INTEGER :: j,jamin,jmax,jmin,k,l,n,nbfc,ncnt,nsurpt,nvolpt, &
2633  n1,n2,n3
2634  DOUBLE PRECISION :: v(4),ar(4)
2635  DOUBLE PRECISION :: angl,angl1,angl2,angl3,angmax,angmin,dismin, &
2636  farea,fmax,fmin,q,qmax,qmin,vmax,vmin, &
2637  ratavr,ratmax,ratmin,rcmax,rcmin,sigma,sigsq
2638 !
2639 ! ******************************************************************
2640 !
2641  ratavr = 0.
2642  ncnt = 0
2643  DO 20 l=1,ncell
2644  IF (iprot(l).EQ.1) go to 20
2645  IF (nbh(1,l).EQ.0) go to 20
2646  IF (ndc(4,l).LE.0) go to 20
2647  ncnt = ncnt +1
2648  ratavr = ratavr +rat(l)
2649  IF (ncnt.GT.1) go to 10
2650  vmin = vol(l)
2651  vmax = vol(l)
2652  rcmin = rc(l)
2653  rcmax = rc(l)
2654  ratmin = rat(l)
2655  ratmax = rat(l)
2656  go to 20
2657  10 vmin = min(vol(l),vmin)
2658  vmax = max(vol(l),vmax)
2659  rcmin = min(rcmin,rc(l))
2660  rcmax = max(rcmax,rc(l))
2661  ratmin = min(ratmin,rat(l))
2662  ratmax = max(ratmax,rat(l))
2663  20 CONTINUE
2664  ratavr = ratavr/float(ncnt)
2665  vmin = vmin/6.0d0
2666  vmax = vmax/6.0d0
2667 !
2668 ! COMPUTE STANDARD DEVIATION OF CIRCUMRADIUS TO IN-RADIUS
2669 ! RATIO
2670 !
2671  sigsq = 0.
2672  DO 30 l=1,ncell
2673  IF (iprot(l).EQ.1) go to 30
2674  IF (nbh(1,l).EQ.0) go to 30
2675  IF (ndc(4,l).LE.0) go to 30
2676  sigsq = sigsq +(rat(l) -ratavr)**2
2677  30 CONTINUE
2678  sigma = sqrt(sigsq)/float(ncnt)
2679  WRITE (6,600) vmin,vmax,rcmin,rcmax,ratmin,ratmax,ratavr,sigma
2680 
2681  CALL tetang(x,ndc,nbh,iprot,ncell)
2682 !
2683 ! COMPUTE AREA AND ANGLES OF EACH SURFACE TRIANGLE
2684 !
2685  jmax = 1
2686  jmin = 1
2687  jamin = 1
2688  angmin = 360.
2689  angmax = 0.
2690  qmin = 1.e15
2691  qmax = 1.
2692  fmax = -1.
2693  fmin = -1.
2694  nbfc = 0
2695  DO 75 j=1,nbface
2696  n1 = nfce(1,j)
2697  n2 = nfce(2,j)
2698  n3 = nfce(3,j)
2699  IF (n1.LT.0) go to 75
2700  nbfc = nbfc +1
2701 
2702  CALL fangle(j,x,nfce,angl1,angl2,angl3,q)
2703 
2704  angl = min(angl1,angl2,angl3)
2705  IF (angl.GT.angmin) go to 60
2706  jamin = j
2707  angmin = angl
2708  60 angmax = max(angl1,angl2,angl3,angmax)
2709  qmin = min(q,qmin)
2710  qmax = max(q,qmax)
2711  farea = facear(x,n1,n2,n3)
2712  IF (fmax.LT.0.) fmax = farea
2713  IF (fmin.LT.0.) fmin = farea
2714  IF (farea.LT.fmax) go to 70
2715  jmax = j
2716  fmax = farea
2717  70 IF (farea.GT.fmin) go to 75
2718  jmin = j
2719  fmin = farea
2720  75 CONTINUE
2721  WRITE (6,610) angmin,angmax,qmin,qmax
2722 !
2723 ! COUNT NUMBER OF POINTS IN THE MESH AND ON THE BOUNDARY SURFACE
2724 !
2725  nvolpt = 0
2726  nsurpt = 0
2727  DO 80 n=1,nnode
2728  ipoint(n) = 0
2729  IF (ityp(n).GE.0) nvolpt = nvolpt +1
2730  80 CONTINUE
2731  DO 85 j=1,nbface
2732  DO 85 k=1,3
2733  n = nfce(k,j)
2734  IF (ipoint(n).EQ.0) THEN
2735  ipoint(n) = 1
2736  nsurpt = nsurpt +1
2737  ENDIF
2738  85 CONTINUE
2739  DO 90 n=1,nnode
2740  ipoint(n) = 0
2741  90 CONTINUE
2742  WRITE (6,620) nsurpt,nbfc,nvolpt,ncnt
2743  RETURN
2744  600 FORMAT(//5x,'*************************************************'/ &
2745  5x,'* *'/ &
2746  5x,'* STATISTICS OF MESH TETRAHEDRA *'/ &
2747  5x,'* *'/ &
2748  5x,'* MINIMUM VOLUME = ',e13.5,' *'/ &
2749  5x,'* MAXIMUM VOLUME = ',e13.5,' *'/ &
2750  5x,'* *'/ &
2751  5x,'* MINIMUM CIRCUMRADIUS = ',e13.5,' *'/ &
2752  5x,'* MAXIMUM CIRCUMRADIUS = ',e13.5,' *'/ &
2753  5x,'* *'/ &
2754  5x,'* MINIMUM RADIUS RATIO = ',e13.5,' *'/ &
2755  5x,'* MAXIMUM RADIUS RATIO = ',e13.5,' *'/ &
2756  5x,'* AVERAGE RADIUS RATIO = ',e13.5,' *'/ &
2757  5x,'* STANDARD DEVIATION = ',e13.5,' *'/ &
2758  5x,'* *'/ &
2759  5x,'*************************************************')
2760  610 FORMAT( 5x,'*************************************************'/ &
2761  5x,'* *'/ &
2762  5x,'* STATISTICS OF BOUNDARY SURFACE TRIANGLES *'/ &
2763  5x,'* *'/ &
2764  5x,'* MINIMUM BOUNDARY FACE ANGLE = ',f6.2,' *'/ &
2765  5x,'* MAXIMUM BOUNDARY FACE ANGLE = ',f6.2,' *'/ &
2766  5x,'* MINIMUM BOUNDARY RADIUS RATIO = ',f6.2,' *'/ &
2767  5x,'* MAXIMUM BOUNDARY RADIUS RATIO = ',f6.2,' *'/ &
2768  5x,'* *'/ &
2769  5x,'*************************************************')
2770  620 FORMAT( 5x,'*************************************************'/ &
2771  5x,'* *'/ &
2772  5x,'* TOTAL NUMBER OF SURFACE POINTS = ',i6,' *'/ &
2773  5x,'* TOTAL NUMBER OF SURFACE FACES = ',i6,' *'/ &
2774  5x,'* TOTAL NUMBER OF MESH POINTS = ',i6,' *'/ &
2775  5x,'* TOTAL NUMBER OF TETRAHEDRA = ',i6,' *'/ &
2776  5x,'* *'/ &
2777  5x,'*************************************************')
2778  END SUBROUTINE radrat
2779 
2780 
2781 
2782 
2783 
2784 
2785 !
2786 ! ******************************************************************
2787 !
2788  SUBROUTINE volput (X,ITYP,NBPTS,NNODE,NDC,NBH,IPROT,NCELL, &
2789  ndg,idgp,ndgp,nedge, &
2790  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
2791  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
2792  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
2793  xkeep,ykeep,zkeep,ksrch,nsrch, &
2794  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
2795  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
2796  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
2797  jlast,jfirst,ntrack,volmin,rcmx,tolv)
2798 !
2799 ! ******************************************************************
2800 ! * *
2801 ! * INSERTION OF FIELD POINTS INTO DELAUNAY TRIANGULATION *
2802 ! * *
2803 ! ******************************************************************
2804 ! ******************************************************************
2805 ! * *
2806 ! * COPYRIGHT (C) TIM BAKER 1994 *
2807 ! * *
2808 ! ******************************************************************
2809 !
2810  IMPLICIT NONE
2811 
2812  INTEGER :: ioctr,jfirst,jlast,nbpts,ncell,nedge,nnode,ntrack
2813  INTEGER :: ndc(4,*),ndg(2,*),nbh(4,*),iprot(*),idgp(*),ndgp(*)
2814  INTEGER :: ityp(*),nptet(*),nacpt(*)
2815  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
2816  INTEGER :: npoint(*),ipoint(*)
2817  INTEGER :: iflag(*),nflag(*)
2818  INTEGER :: lnkup(*),lnkdn(*)
2819  INTEGER :: nsrch(*),ksrch(*)
2820  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*), &
2821  newcel(*),nshake(*),ncav(4,*)
2822  INTEGER :: nedgrm(*)
2823  INTEGER :: ldel(*),ncavfc(3,*),ikeep(*)
2824  DOUBLE PRECISION :: volmin,rcmx,tolv
2825  DOUBLE PRECISION :: x(3,*),dens(*)
2826  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
2827  DOUBLE PRECISION :: xoctr(2,*),yoctr(2,*),zoctr(2,*), &
2828  xhold(2,*),yhold(2,*),zhold(2,*), &
2829  xkeep(2),ykeep(2),zkeep(2),xfar(2), &
2830  yfar(2),zfar(2)
2831  DOUBLE PRECISION :: xc(*),yc(*),zc(*),v(*),rad(*),rcrin(*)
2832 
2833  INTEGER :: j,jpast,jpre,k,k1,k2,l,lbrk,lnbh,n,nclose,ncyc,ndiff, &
2834  nfail,ninp,npass,npts,nsrfpt,nstart,ntet,n1,n2,n3,n4,n5
2835  DOUBLE PRECISION :: dent,dismin,rnx,rny,rnz,scldis,vtet1,vtet2, &
2836  xpt,ypt,zpt
2837 !
2838 ! ******************************************************************
2839 !
2840 ! SET INTERIOR DISTANCE SCALING
2841 !
2842  scldis = .75
2843 !
2844 ! INITIALIZE INTEGER VARIABLES
2845 !
2846  nsrfpt = nbpts +8
2847  nstart = nnode
2848  ncyc = 0
2849  ninp = 0
2850 !
2851 ! SET UP LINKED LIST OF CELLS
2852 !
2853  jlast = 0
2854  jfirst = 0
2855  ntrack = 0
2856  j = 0
2857  10 j = j +1
2858  IF (j.GT.ncell) go to 15
2859  IF (iprot(j).EQ.1) go to 10
2860  IF (nbh(1,j).LE.0) go to 10
2861  nacpt(j) = 0
2862  n1 = ndc(1,j)
2863  n2 = ndc(2,j)
2864  n3 = ndc(3,j)
2865  n4 = ndc(4,j)
2866  dent = dens(n1) +dens(n2) +dens(n3) +dens(n4)
2867  IF (rc(j).LT.0.22*dent) go to 10
2868  nacpt(j) = 1
2869  ntrack = ntrack +1
2870  IF (jlast.NE.0) lnkdn(jlast) = j
2871  lnkdn(j) = 0
2872  lnkup(j) = jlast
2873  jlast = j
2874  IF (jfirst.NE.0) go to 10
2875  jfirst = j
2876  go to 10
2877  15 WRITE (6,910) ntrack
2878  910 FORMAT('IN VOLPUT, NTRACK = ',i6)
2879  IF (ntrack.EQ.0) go to 70
2880 !
2881 ! START OF ITERATIVE LOOP FOR POINT INSERTION
2882 !
2883  30 ncyc = ncyc +1
2884  j = jfirst
2885  IF (nacpt(j).EQ.0) go to 215
2886  IF (iprot(j).EQ.1) go to 200
2887  xpt = xcen(j)
2888  ypt = ycen(j)
2889  zpt = zcen(j)
2890  IF (xpt.LT.xfar(1).OR.xpt.GT.xfar(2)) go to 45
2891  IF (ypt.LT.yfar(1).OR.ypt.GT.yfar(2)) go to 45
2892  IF (zpt.LT.zfar(1).OR.zpt.GT.zfar(2)) go to 45
2893  DO 32 k=1,4
2894  lnbh = nbh(k,j)
2895  IF (iprot(lnbh).EQ.0) go to 32
2896 
2897  CALL lock(j,lnbh,n1,n2,n3,n4,n5,k1,k2,ndc,nbh)
2898 
2899  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
2900  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
2901  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
2902  vtet1 = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
2903  +rnz*(x(3,n4) -x(3,n1))
2904  vtet2 = rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
2905  +rnz*(zpt -x(3,n1))
2906  IF (vtet1*vtet2.LT.0.) go to 45
2907  32 CONTINUE
2908  nnode = nnode +1
2909  IF (nnode.GT.mxnode) go to 230
2910  npass = 0
2911  n = nnode
2912  x(1,n) = xpt
2913  x(2,n) = ypt
2914  x(3,n) = zpt
2915  34 ityp(n) = 8
2916  idone(n) = 0
2917  ipoint(n) = 0
2918 
2919  CALL octfnd(0,nclose,x(1,n),x(2,n),x(3,n),0,0,0,dismin, &
2920  x,noctr,nlink,xfar,yfar,zfar,idone, &
2921  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
2922  xkeep,ykeep,zkeep,ksrch,nsrch)
2923 
2924  IF (dismin.LT.1.e-15) go to 40
2925  IF (nclose.LE.nsrfpt) go to 35
2926  IF (nclose.LE.nstart) go to 35
2927  IF (sqrt(dismin).LT.scldis*dens(nclose)) go to 40
2928  35 idone(n) = 1
2929  lbrk = nptet(nclose)
2930 
2931  CALL insert(n,nclose,lbrk,j,nfail, &
2932  x,ndc,nbh,iprot,ncell,ndg,idgp,ndgp,nedge, &
2933  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
2934  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
2935  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
2936  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
2937  jlast,jfirst,ntrack,volmin,rcmx,tolv)
2938 
2939  IF (nfail.EQ.5.AND.npass.EQ.0) THEN
2940  n1 = ndc(1,j)
2941  n2 = ndc(2,j)
2942  n3 = ndc(3,j)
2943  n4 = ndc(4,j)
2944  xpt = .25*(x(1,n1) +x(1,n2) +x(1,n3) +x(1,n4))
2945  ypt = .25*(x(2,n1) +x(2,n2) +x(2,n3) +x(2,n4))
2946  zpt = .25*(x(3,n1) +x(3,n2) +x(3,n3) +x(3,n4))
2947  npass = 1
2948  go to 34
2949  ENDIF
2950  IF (nfail.GE.1) go to 40
2951 !
2952 ! POINT ACCEPTED AND INSERTED INTO MESH
2953 !
2954 
2955 !C WRITE (6,880) N,X(1,N),X(2,N),X(3,N),DENS(N)
2956 !C 880 FORMAT('+++ N ',I6,' X,Y,Z ',3(2X,F8.3),' DENS ',F8.3)
2957 
2958  ninp = ninp +1
2959 
2960  CALL octfil(n,x,noctr,ioctr,nlink,nref,xfar,yfar,zfar)
2961 
2962  go to 50
2963 !
2964 ! POINT NOT ACCEPTED FOR INSERTION
2965 !
2966  40 nnode = nnode -1
2967  45 nacpt(j) = 0
2968  jpre = lnkup(j)
2969  jpast = lnkdn(j)
2970  IF (jpre.NE.0) lnkdn(jpre) = jpast
2971  IF (jpast.NE.0) lnkup(jpast) = jpre
2972  IF (jpre.EQ.0) jfirst = jpast
2973  IF (jpast.EQ.0) jlast = jpre
2974  ntrack = ntrack -1
2975  50 IF (mod(ncyc,10000).EQ.0) WRITE (6,710) ncyc,ninp,ntrack
2976  IF (jfirst.NE.0) go to 30
2977 !
2978 ! ITERATIVE INSERTION OF POINTS IS COMPLETE
2979 !
2980  70 WRITE (6,710) ncyc,ninp,ntrack
2981  npts = 0
2982  DO 75 n=1,nnode
2983  IF (n.GT.0) THEN
2984  IF (ityp(n).GE.0) npts = npts +1
2985  ENDIF
2986  75 CONTINUE
2987  ndiff = nnode -nstart
2988  ntet = 0
2989  DO 80 l=1,ncell
2990  IF (iprot(l).EQ.1) go to 80
2991  IF (nbh(1,l).EQ.0) go to 80
2992  ntet = ntet +1
2993  80 CONTINUE
2994  WRITE (6,720) npts,ndiff,ntet
2995  RETURN
2996  200 WRITE (6,600)
2997  stop
2998  210 WRITE (6,610) nfail,n,x(1,n),x(2,n),x(3,n)
2999  stop
3000  215 WRITE (6,615)
3001  stop
3002  230 WRITE (6,630)
3003  stop
3004  710 FORMAT(/' NCYC = ',i7,' POINTS INSERTED = ',i7,' NTRACK = ',i7)
3005  720 FORMAT(/'ADAPTIVE REFINEMENT COMPLETE'/ &
3006  5x,i7,' TOTAL MESH POINTS'/ &
3007  5x,i7,' FIELD POINTS INSERTED'/ &
3008  5x,i7,' MESH CELLS'/)
3009  600 FORMAT(//'A PROTECTED TETRAHEDRON IS AMONG THOSE TO BE REFINED')
3010  610 FORMAT(//5x,'NFAIL = ',i6,' N ',i6,' X,Y,Z ',3(2x,f6.2)/ &
3011  5x,'PROGRAM STOPPED IN VOLPUT')
3012  615 FORMAT(//5x,'LABEL NACPT IS ZERO FOR CELL FROM ACTIVE LIST'/ &
3013  5x,'PROGRAM STOPPED IN VOLPUT')
3014  630 FORMAT(//'NUMBER OF POINTS INSERTED EXCEEDS DIMENSION OF ARRAY X'/ &
3015  'INCREASE SIZE OF MNODE.'/ &
3016  'PROGRAM STOPPED IN ROUTINE VOLPUT.')
3017  END SUBROUTINE volput
3018 
3019 
3020 
3021 
3022 
3023 !
3024 ! ******************************************************************
3025 !
3026  SUBROUTINE putpnt (J,NFAIL, &
3027  x,ityp,nnode,ndc,nbh,iprot,ncell, &
3028  ndg,idgp,ndgp,nedge, &
3029  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
3030  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
3031  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
3032  xkeep,ykeep,zkeep,ksrch,nsrch, &
3033  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
3034  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
3035  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
3036  volmin,rcmx,tolv)
3037 !
3038 ! ******************************************************************
3039 ! * *
3040 ! * INSERTION OF A POINT INTO DELAUNAY TRIANGULATION TO ELIMINATE *
3041 ! * A SLIVER LIKE TETRAHEDRON. *
3042 ! * *
3043 ! ******************************************************************
3044 ! ******************************************************************
3045 ! * *
3046 ! * COPYRIGHT (C) TIM BAKER 2001 *
3047 ! * *
3048 ! ******************************************************************
3049 !
3050  IMPLICIT NONE
3051 
3052  INTEGER :: ioctr,j,ncell,nedge,nfail,nnode
3053  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),idgp(*),ndgp(*)
3054  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*),newcel(*), &
3055  nshake(*),ncav(4,*)
3056  INTEGER :: nedgrm(*),ldel(*),ncavfc(3,*),ikeep(*)
3057  INTEGER :: ityp(*),nptet(*),nacpt(*)
3058  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
3059  INTEGER :: npoint(*),ipoint(*)
3060  INTEGER :: iflag(*),nflag(*)
3061  INTEGER :: lnkup(*),lnkdn(*)
3062  INTEGER :: nsrch(*),ksrch(*)
3063  DOUBLE PRECISION :: volmin,rcmx,tolv
3064  DOUBLE PRECISION :: x(3,*),dens(*)
3065  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
3066  DOUBLE PRECISION :: xoctr(2,*),yoctr(2,*),zoctr(2,*), &
3067  xhold(2,*),yhold(2,*),zhold(2,*), &
3068  xfar(2),yfar(2),zfar(2),xkeep(2), &
3069  ykeep(2),zkeep(2)
3070  DOUBLE PRECISION :: xc(*),yc(*),zc(*),v(*),rad(*),rcrin(*)
3071 
3072  INTEGER :: jfirst,jlast,k,k1,k2,lbrk,lnbh,n,nclose,npass,ntrack, &
3073  n1,n2,n3,n4,n5
3074  DOUBLE PRECISION :: dismin,rnx,rny,rnz,vtet1,vtet2,xpt,ypt,zpt
3075 !
3076 ! ******************************************************************
3077 !
3078  nfail = 0
3079  xpt = xcen(j)
3080  ypt = ycen(j)
3081  zpt = zcen(j)
3082  IF (xpt.LT.xfar(1).OR.xpt.GT.xfar(2)) go to 50
3083  IF (ypt.LT.yfar(1).OR.ypt.GT.yfar(2)) go to 50
3084  IF (zpt.LT.zfar(1).OR.zpt.GT.zfar(2)) go to 50
3085  DO 32 k=1,4
3086  lnbh = nbh(k,j)
3087  IF (iprot(lnbh).EQ.0) go to 32
3088 
3089  CALL lock(j,lnbh,n1,n2,n3,n4,n5,k1,k2,ndc,nbh)
3090 
3091  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
3092  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
3093  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
3094  vtet1 = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
3095  +rnz*(x(3,n4) -x(3,n1))
3096  vtet2 = rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
3097  +rnz*(zpt -x(3,n1))
3098  IF (vtet1*vtet2.LT.0.) go to 50
3099  32 CONTINUE
3100  nnode = nnode +1
3101  IF (nnode.GT.mxnode) go to 200
3102  npass = 0
3103  n = nnode
3104  34 x(1,n) = xpt
3105  x(2,n) = ypt
3106  x(3,n) = zpt
3107  ityp(n) = 8
3108  idone(n) = 0
3109  ipoint(n) = 0
3110 
3111  CALL octfnd(0,nclose,x(1,n),x(2,n),x(3,n),0,0,0,dismin, &
3112  x,noctr,nlink,xfar,yfar,zfar,idone, &
3113  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
3114  xkeep,ykeep,zkeep,ksrch,nsrch)
3115 
3116  IF (dismin.LT.1.e-15) go to 40
3117  35 idone(n) = 1
3118  lbrk = nptet(nclose)
3119  ntrack = 0
3120  jfirst = 0
3121  jlast = 0
3122 
3123  CALL insert(n,nclose,lbrk,j,nfail, &
3124  x,ndc,nbh,iprot,ncell,ndg,idgp,ndgp,nedge, &
3125  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
3126  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
3127  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
3128  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
3129  jlast,jfirst,ntrack,volmin,rcmx,tolv)
3130 
3131  IF (nfail.EQ.5.AND.npass.EQ.0) THEN
3132  n1 = ndc(1,j)
3133  n2 = ndc(2,j)
3134  n3 = ndc(3,j)
3135  n4 = ndc(4,j)
3136  xpt = .25*(x(1,n1) +x(1,n2) +x(1,n3) +x(1,n4))
3137  ypt = .25*(x(2,n1) +x(2,n2) +x(2,n3) +x(2,n4))
3138  zpt = .25*(x(3,n1) +x(3,n2) +x(3,n3) +x(3,n4))
3139  npass = 1
3140  go to 34
3141  ENDIF
3142  IF (nfail.GE.1) THEN
3143  nnode = nnode -1
3144  RETURN
3145  ENDIF
3146 !
3147 ! POINT ACCEPTED AND INSERTED INTO MESH
3148 !
3149  CALL octfil(n,x,noctr,ioctr,nlink,nref,xfar,yfar,zfar)
3150 
3151  RETURN
3152 !
3153 ! POINT NOT ACCEPTED FOR INSERTION
3154 !
3155  40 nnode = nnode -1
3156  50 nfail = 1
3157  RETURN
3158  200 WRITE (6,600)
3159  stop
3160  600 FORMAT(//'NUMBER OF POINTS INSERTED EXCEEDS DIMENSION OF ARRAY X'/ &
3161  'INCREASE SIZE OF MNODE.'/ &
3162  'PROGRAM STOPPED IN ROUTINE PUTPNT.')
3163  END SUBROUTINE putpnt
3164 
3165 
3166 
3167 
3168 
3169 
3170 !
3171 ! ******************************************************************
3172 !
3173  SUBROUTINE insert (NP,NCLOSE,LBRK,JCONT,NFAIL, &
3174  x,ndc,nbh,iprot,ncell,ndg,idgp,ndgp,nedge, &
3175  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
3176  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
3177  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
3178  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
3179  jlast,jfirst,ntrack,volmin,rcmx,tolv)
3180 !
3181 ! ******************************************************************
3182 ! * *
3183 ! * POINT (X(1,NP),X(2,NP),X(3,NP)) LIES INSIDE CIRCUMSPHERE OF *
3184 ! * TETRAHEDRON LBRK. FIND THE DELAUNAY CAVITY THAT CONTAINS *
3185 ! * THIS POINT AND GENERATE THE DELAUNAY MODIFICATION OF THE *
3186 ! * CAVITY TO INCLUDE THE NEW POINT IN THE MESH. *
3187 ! * *
3188 ! ******************************************************************
3189 ! ******************************************************************
3190 ! * *
3191 ! * COPYRIGHT (C) TIM BAKER 1994 *
3192 ! * *
3193 ! ******************************************************************
3194 !
3195  IMPLICIT NONE
3196 
3197  INTEGER :: jcont,jfirst,jlast,lbrk,ncell,nclose,nedge,nfail,np, &
3198  ntrack
3199  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),idgp(*),ndgp(*)
3200  INTEGER :: nptet(*),nacpt(*)
3201  INTEGER :: npoint(*),ipoint(*),iflag(*),nflag(*)
3202  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*), &
3203  newcel(*),nshake(*),ncav(4,*)
3204  INTEGER :: nedgrm(*)
3205  INTEGER :: lnkup(*),lnkdn(*)
3206  INTEGER :: ldel(*),ncavfc(3,*),ikeep(*)
3207  DOUBLE PRECISION :: volmin,rcmx,tolv
3208  DOUBLE PRECISION :: x(3,*),dens(*)
3209  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
3210  DOUBLE PRECISION :: xc(*),yc(*),zc(*),v(*),rad(*),rcrin(*)
3211 
3212  INTEGER :: i,iedgrm,ismall,j,jpast,jpre,k,l,lcont,m,mm,nchk, &
3213  ncnt,ncpnt,ndel,nedg,ntot1,ntot2,n1,n2,n3,n4
3214  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,dent, &
3215  radmax,ratmax,sum1,sum2,vdiff,xpt,ypt,zpt
3216 !
3217 ! ******************************************************************
3218 !
3219  nfail = 0
3220  xpt = x(1,np)
3221  ypt = x(2,np)
3222  zpt = x(3,np)
3223 !
3224 ! FIND TETRAHEDRON LCONT THAT CONTAINS POINT NP
3225 !
3226  CALL tetloc(np,nclose,lbrk,lcont,nfail, &
3227  x,ndc,nbh,iprot,dens,vol, &
3228  iflag,nflag,nfill,newcel,tolv)
3229 
3230  IF (nfail.NE.0) RETURN
3231 !
3232 ! FIND COMPLETE CAVITY OF TETRAHEDRA WHOSE CIRCUMSPHERES CONTAIN
3233 ! THE POINT NP
3234 !
3235  CALL cavity(np,lcont,ndel,ldel, &
3236  x,ndc,nbh,iprot,iflag,nflag, &
3237  xcen,ycen,zcen,rc,nfill,newcel,tolv)
3238 !
3239 ! DETERMINE FACES ON BOUNDARY OF CAVITY AND GENERATE LIST OF NEW
3240 ! TETRAHEDRA
3241 !
3242  CALL cavbnd(np,lcont,ndel,ldel,ncnt, &
3243  x,ndc,nbh,vol,iflag,nflag, &
3244  nfill,newcel,ntri,newnbh,nold,tolv)
3245 !
3246 ! COMPUTE MAXIMUM CIRCUMRADIUS FOR THE CAVITY TETRAHEDRA
3247 !
3248  radmax = 0.
3249  ratmax = 0.
3250  nchk = 0
3251  DO 10 k=1,ndel
3252  radmax = max(radmax,rc(ldel(k)))
3253  ratmax = max(ratmax,rat(ldel(k)))
3254  IF (ldel(k).EQ.jcont) nchk = 1
3255  10 CONTINUE
3256  IF (nchk.EQ.0) go to 295
3257 !
3258 ! COMPUTE VOLUME, CIRCUMCENTER COORDINATES AND CIRCUMRADIUS OF
3259 ! EACH NEW TETRAHEDRON
3260 !
3261  sum1 = 0.
3262  DO 20 k=1,ncnt
3263  n1 = np
3264  n2 = ntri(1,k)
3265  n3 = ntri(2,k)
3266  n4 = ntri(3,k)
3267 !
3268  CALL circum(x,n1,n2,n3,n4,xc(k),yc(k),zc(k),v(k),rad(k), &
3269  ismall,tolv)
3270 !
3271  IF (ismall.EQ.1) go to 300
3272  IF (v(k).LT.tolv) go to 310
3273  IF (rad(k).GT.radmax) go to 305
3274  area = tetar2(n1,n2,n3,n4,x)
3275  rcrin(k) = rad(k)*area/v(k)
3276  IF (rcrin(k).GT.ratmax) go to 305
3277  sum1 = sum1 +v(k)
3278  20 CONTINUE
3279 !
3280 ! CHECK PROXIMITY OF POINT TO BOUNDARY SURFACE
3281 !
3282 !! DO 25 K=1,NCNT
3283 !! LNBH = NEWNBH(1,K)
3284 !! IF (IPROT(LNBH).EQ.0) GO TO 25
3285 !! N1 = NTRI(1,K)
3286 !! N2 = NTRI(2,K)
3287 !! N3 = NTRI(3,K)
3288 !! RNX = COFACT (X(2,N1),X(2,N2),X(2,N3),X(3,N1),X(3,N2),X(3,N3))
3289 !! RNY = COFACT (X(3,N1),X(3,N2),X(3,N3),X(1,N1),X(1,N2),X(1,N3))
3290 !! RNZ = COFACT (X(1,N1),X(1,N2),X(1,N3),X(2,N1),X(2,N2),X(2,N3))
3291 !! FAC = 1./SQRT(RNX*RNX +RNY*RNY +RNZ*RNZ)
3292 !! RNX = FAC*RNX
3293 !! RNY = FAC*RNY
3294 !! RNZ = FAC*RNZ
3295 !! PROJ1 = RNX*(X(1,NP) -X(1,N1)) +RNY*(X(2,NP) -X(2,N1))
3296 !! . +RNZ*(X(3,NP) -X(3,N1))
3297 !! PROJ2 = RNX*(XC(K) -X(1,N1)) +RNY*(YC(K) -X(2,N1))
3298 !! . +RNZ*(ZC(K) -X(3,N1))
3299 !! PROJ1 = ABS(PROJ1)
3300 !! IF (6.*PROJ1.LT.(DENS(N1)+DENS(N2)+DENS(N3))) GO TO 320
3301 !! 25 CONTINUE
3302 !
3303 ! CHECK CAVITY VOLUME FOR VISIBILITY
3304 !
3305  sum2 = 0.
3306  DO 30 k=1,ndel
3307  sum2 = sum2 +vol(ldel(k))
3308  30 CONTINUE
3309  IF (sum1.GT.sum2*(1.+tolv)) go to 350
3310 !
3311 ! UPDATE DATA STRUCTURE FOR FACE AND EDGE LISTS
3312 !
3313  CALL recon(ldel,ndel,ncnt, &
3314  ndc,nbh,iprot,ndg,idgp,ndgp,nflag, &
3315  ntri,ncavfc,ikeep,nedgrm,iedgrm)
3316 !
3317 ! NUMBER NEW TETRAHEDRA REPLACING DELETED TETRAHEDRA WHERE
3318 ! APPROPRIATE
3319 !
3320  DO 40 k=1,ncnt
3321  IF (k.GT.ndel) go to 35
3322  newcel(k) = ldel(k)
3323  go to 40
3324  35 ncell = ncell +1
3325  IF (ncell.GT.mxcell) go to 370
3326  newcel(k) = ncell
3327  nflag(ncell) = 0
3328  40 CONTINUE
3329 !
3330 ! CHECK WHETHER A CAVITY BOUNDARY POINT IS BURIED IN THE CAVITY
3331 !
3332  ntot1 = 0
3333  DO 44 l=1,ndel
3334  j = ldel(l)
3335  DO 44 i=1,4
3336  ncpnt = ndc(i,j)
3337  IF (nflag(ncpnt).EQ.1) go to 44
3338  ntot1 = ntot1 +1
3339  iflag(ntot1) = ncpnt
3340  nflag(ncpnt) = 1
3341  44 CONTINUE
3342  DO 46 k=1,ntot1
3343  nflag(iflag(k)) = 0
3344  46 CONTINUE
3345  ntot2 = 0
3346  DO 48 k=1,ncnt
3347  DO 48 i=1,3
3348  ncpnt = ntri(i,k)
3349  IF (nflag(ncpnt).EQ.1) go to 48
3350  ntot2 = ntot2 +1
3351  iflag(ntot2) = ncpnt
3352  nflag(ncpnt) = 1
3353  48 CONTINUE
3354  DO 50 k=1,ntot2
3355  nflag(iflag(k)) = 0
3356  50 CONTINUE
3357  IF (ntot1.NE.ntot2) go to 390
3358 !
3359 ! UPDATE NEIGHBORING TETRAHEDRON INFORMATION FOR UNDELETED
3360 ! TETRAHEDRA
3361 !
3362  DO 60 k=1,ncnt
3363  l = newnbh(1,k)
3364  DO 55 m=1,4
3365  mm = m
3366  IF (nbh(m,l).EQ.nold(k)) go to 60
3367  55 CONTINUE
3368  go to 380
3369  60 nshake(k) = mm
3370 !
3371 ! GENERATE LIST OF CAVITY EDGES AND CONSTRUCT ARRAY NCAV
3372 !
3373  CALL cavedg(ncnt,nedg,ipoint,npoint, &
3374  ntri,ncav,newnbh,newcel)
3375 !
3376 ! UPDATE FACE TO CELL POINTER FOR CAVITY FACES
3377 !
3378  CALL datsrf(np,ncnt,nedg,ndg,idgp,ndgp,nedge, &
3379  ipoint,ncav,nedgrm,iedgrm)
3380 !
3381 ! SET NBH ARRAY TO ZERO FOR THE DELETED TETRAHEDRA PRIOR TO
3382 ! OVERWRITING WITH THE NEW TETRAHEDRON LIST
3383 !
3384  DO 70 j=1,ndel
3385  DO 70 i=1,4
3386  70 nbh(i,ldel(j)) = 0
3387  DO 80 i=1,nedg
3388  n1 = ncav(1,i)
3389  n2 = ncav(2,i)
3390  ipoint(n1) = 0
3391  ipoint(n2) = 0
3392  80 CONTINUE
3393 !
3394 ! COPY NEW TETRAHEDRON VERTEX AND NEIGHBOR INFORMATION INTO THE
3395 ! ARRAYS NDC AND NBH
3396 !
3397  DO 90 k=1,ncnt
3398  nbh(nshake(k),newnbh(1,k)) = newcel(k)
3399  90 CONTINUE
3400  DO 100 k=1,ncnt
3401  DO 95 i=1,4
3402  nbh(i,newcel(k)) = newnbh(i,k)
3403  95 CONTINUE
3404  ndc(4,newcel(k)) = np
3405  ndc(1,newcel(k)) = min(ntri(1,k),ntri(2,k),ntri(3,k))
3406  ndc(2,newcel(k)) = max(ntri(1,k),ntri(2,k),ntri(3,k))
3407  ndc(3,newcel(k)) = ntri(1,k) +ntri(2,k) +ntri(3,k) &
3408  -ndc(1,newcel(k)) -ndc(2,newcel(k))
3409  nptet(ntri(1,k)) = newcel(k)
3410  nptet(ntri(2,k)) = newcel(k)
3411  nptet(ntri(3,k)) = newcel(k)
3412  xcen(newcel(k)) = xc(k)
3413  ycen(newcel(k)) = yc(k)
3414  zcen(newcel(k)) = zc(k)
3415  vol(newcel(k)) = v(k)
3416  rc(newcel(k)) = rad(k)
3417  rat(newcel(k)) = rcrin(k)
3418  volmin = min(volmin,v(k))
3419  rcmx = max(rcmx,rad(k))
3420  100 CONTINUE
3421  nptet(np) = newcel(1)
3422 !
3423 ! COMPUTE CIRCUMRADIUS TO IN-RADIUS RATIO FOR NEW TETRAHEDRA
3424 !
3425  DO 140 j=1,ndel
3426  IF (nacpt(ldel(j)).EQ.0) go to 140
3427  jpre = lnkup(ldel(j))
3428  jpast = lnkdn(ldel(j))
3429  IF (jpre.NE.0) lnkdn(jpre) = jpast
3430  IF (jpast.NE.0) lnkup(jpast) = jpre
3431  IF (jpre.EQ.0) jfirst = jpast
3432  IF (jpast.EQ.0) jlast = jpre
3433  nacpt(ldel(j)) = 0
3434  ntrack = ntrack -1
3435  140 CONTINUE
3436  DO 150 k=1,ncnt
3437  n1 = ndc(1,newcel(k))
3438  n2 = ndc(2,newcel(k))
3439  n3 = ndc(3,newcel(k))
3440  n4 = ndc(4,newcel(k))
3441  nacpt(newcel(k)) = 0
3442  dent = dens(n1) +dens(n2) +dens(n3) +dens(n4)
3443  IF (rc(newcel(k)).LT.0.22*dent) go to 150
3444  nacpt(newcel(k)) = 1
3445  ntrack = ntrack +1
3446  IF (jlast.NE.0) lnkdn(jlast) = newcel(k)
3447  lnkdn(newcel(k)) = 0
3448  lnkup(newcel(k)) = jlast
3449  jlast = newcel(k)
3450  IF (jfirst.EQ.0) jfirst = newcel(k)
3451  150 CONTINUE
3452  RETURN
3453  295 CONTINUE
3454 ! WRITE (6,595)
3455  DO 297 k=1,ndel
3456  nflag(ldel(k)) = 0
3457  297 CONTINUE
3458  nfail = 5
3459  RETURN
3460  300 CONTINUE
3461  WRITE (6,600) np
3462  WRITE (6,888) n1,x(1,n1),x(2,n1),x(3,n1), &
3463  n2,x(1,n2),x(2,n2),x(3,n2), &
3464  n3,x(1,n3),x(2,n3),x(3,n3), &
3465  n4,x(1,n4),x(2,n4),x(3,n4),v(k),tolv
3466  888 FORMAT('N1 ',i5,' X = ',f8.4,' Y = ',f8.4,' Z = ',f8.4/ &
3467  'N2 ',i5,' X = ',f8.4,' Y = ',f8.4,' Z = ',f8.4/ &
3468  'N3 ',i5,' X = ',f8.4,' Y = ',f8.4,' Z = ',f8.4/ &
3469  'N4 ',i5,' X = ',f8.4,' Y = ',f8.4,' Z = ',f8.4/ &
3470  'VOLUME = ',e13.5,' TOLV = ',e13.5)
3471  go to 312
3472  305 CONTINUE
3473 ! WRITE (6,605) RADMAX,RAD(K),RATMAX,RCRIN(K)
3474  go to 312
3475  310 CONTINUE
3476  WRITE (6,610) v(k),tolv
3477  312 DO 315 k=1,ndel
3478  nflag(ldel(k)) = 0
3479  315 CONTINUE
3480  nfail = 1
3481  RETURN
3482  320 CONTINUE
3483 ! WRITE (6,620)
3484  DO 325 k=1,ndel
3485  nflag(ldel(k)) = 0
3486  325 CONTINUE
3487  nfail = 3
3488  RETURN
3489  350 CONTINUE
3490  vdiff = sum1 -sum2
3491  WRITE (6,650) vdiff
3492  DO 355 k=1,ndel
3493  nflag(ldel(k)) = 0
3494  355 CONTINUE
3495  nfail = 3
3496  RETURN
3497  360 CONTINUE
3498  WRITE (6,660)
3499  stop
3500  370 CONTINUE
3501  WRITE (6,670)
3502  stop
3503  380 CONTINUE
3504  WRITE (6,680)
3505  stop
3506  390 CONTINUE
3507  WRITE (6,690) ntot1,ntot2
3508  stop
3509  595 FORMAT(5x,'CAVITY DOES NOT CONTAIN ORIGINATING TETRAHEDRON')
3510  600 FORMAT(//5x,'AT LEAST ONE NEW TETRAHEDRON HAS TOO SMALL A VOLUME'/ &
3511  5x,'ADDRESS OF INSERTED POINT IS ',i6)
3512  605 FORMAT(/5x,'RADMAX ',e13.5,' RC ',e13.5, &
3513  ' RATMAX ',e13.5,' RAT ',e13.5)
3514  610 FORMAT(5x,'VOLUME OF A NEW TETRAHEDRON IS LESS THAN TOLV'/ &
3515  5x,'VOLUME = ',e13.5,' TOLV = ',e13.5/)
3516  620 FORMAT(5x,'NEW POINT CREATES A TETRAHEDRON TOO CLOSE TO BOUNDARY')
3517  650 FORMAT(5x,'VOLUME VISIBILITY CHECK FAILED, VDIFF = ',e13.5)
3518  670 FORMAT(//5x,'DIMENSION OF NDC EXCEEDED IN ROUTINE INSERT'/ &
3519  5x,'INCREASE SIZE OF MCELL.')
3520  660 FORMAT(//5x,'UNABLE TO FIND EDGE ADDRESS FOR A NEW TETRAHEDRON'/ &
3521  5x,'PROGRAM STOPPED IN ROUTINE INSERT')
3522  680 FORMAT(//5x,'UNABLE TO FIND A CONTIGUITY BETWEEN A NEW'/ &
3523  5x,'TETRAHEDRON AND A NON-CAVITY TETRAHEDRON'/ &
3524  5x,'PROGRAM STOPPED IN ROUTINE INSERT')
3525  690 FORMAT(//5x,'NUMBER OF CAVITY POINTS = ',i6,' IS DIFFERENT FROM'/ &
3526  5x,'THE NUMBER OF NEW CELL BOUNDARY POINTS = ',i6// &
3527  5x,'PROBABLE CAUSE IS A FAILURE IN THE TOLERANCE FOR'/ &
3528  5x,'THE DELAUNAY SPHERE TEST IN ROUTINE CAVITY.'/ &
3529  5x,'PROGRAM STOPPED IN ROUTINE INSERT.')
3530  END SUBROUTINE insert
3531 
3532 
3533 
3534 
3535 
3536 
3537 !
3538 ! ******************************************************************
3539 !
3540  SUBROUTINE tetloc (NP,NCLOSE,LBRK,LCONT,NFAIL, &
3541  x,ndc,nbh,iprot,dens,vol, &
3542  iflag,nflag,nfill,newcel,tolv)
3543 !
3544 ! ******************************************************************
3545 ! * *
3546 ! * STARTING WITH TETRAHEDRON LBRK, CARRY OUT A TREE SEARCH TO *
3547 ! * TO FIND THE TETRAHEDRON LCONT THAT CONTAINS THE POINT NP. *
3548 ! * *
3549 ! ******************************************************************
3550 ! ******************************************************************
3551 ! * *
3552 ! * COPYRIGHT (C) TIM BAKER 1994 *
3553 ! * *
3554 ! ******************************************************************
3555 !
3556  IMPLICIT NONE
3557 
3558  INTEGER :: lbrk,lcont,nclose,nfail,np
3559  INTEGER :: ndc(4,*),nbh(4,*),iprot(*)
3560  INTEGER :: iflag(*),nflag(*)
3561  INTEGER :: nfill(*),newcel(*)
3562  DOUBLE PRECISION :: tolv
3563  DOUBLE PRECISION :: x(3,*),dens(*),vol(*)
3564 
3565  INTEGER :: k,k1,k2,l,lbest,lchk,lcnt,lnext,lseek,l1,l2,l3,l4, &
3566  l5,nchk,ncont,ncnt,nmon,nprox,n1,n2,n3,n4
3567  DOUBLE PRECISION :: denb,rtest,tols,tolz,vbest,vdiff,vtet, &
3568  vthres,v1,v2,v3,v4,v5,xpt,ypt,zpt
3569 !
3570 ! ******************************************************************
3571 !
3572  tols = 1.e-15
3573  tolz = 1.e-8
3574  xpt = x(1,np)
3575  ypt = x(2,np)
3576  zpt = x(3,np)
3577  lseek = lbrk
3578  nmon = 1
3579  iflag(nmon) = lseek
3580 
3581  CALL volcom(lseek,np,vdiff,ncont,x,ndc)
3582 
3583  vthres = max(tolv,tolz*vol(lseek))
3584  IF (vdiff.LT.vthres) go to 50
3585  IF (ncont.EQ.0) go to 50
3586  IF (ncont.EQ.-1) go to 360
3587  nprox = 0
3588  vbest = vdiff
3589  lbest = lseek
3590  nflag(lseek) = 1
3591  nfill(1) = lseek
3592  lcnt = 1
3593  10 ncnt = 0
3594  nchk = 0
3595 !
3596 ! TREE SEARCH THROUGH NEIGHBORING TETRAHEDRA
3597 !
3598  DO 20 lchk=1,lcnt
3599  l = nfill(lchk)
3600  DO 20 k=1,4
3601  lseek = nbh(k,l)
3602  n1 = ndc(1,lseek)
3603  n2 = ndc(2,lseek)
3604  n3 = ndc(3,lseek)
3605  n4 = ndc(4,lseek)
3606  IF (nflag(lseek).EQ.1) go to 20
3607  IF (ndc(4,lseek).EQ.-1.AND.nprox.EQ.0) go to 20
3608  IF (ndc(4,lseek).EQ.-1.AND.nprox.GT.0) go to 15
3609  IF (nprox.EQ.0.AND.n1.NE.nclose.AND.n2.NE.nclose &
3610  .AND.n3.NE.nclose.AND.n4.NE.nclose) go to 20
3611  nchk = 1
3612 
3613  CALL volcom(lseek,np,vdiff,ncont,x,ndc)
3614 
3615  vthres = max(tolv,tolz*vol(lseek))
3616  IF (vdiff.LT.vthres) go to 50
3617  IF (ncont.EQ.0) go to 50
3618  IF (ncont.EQ.-1) go to 360
3619  IF (vdiff.GT.vbest) go to 15
3620  vbest = vdiff
3621  lbest = lseek
3622  15 ncnt = ncnt +1
3623  IF (ncnt.GT.mxtest) go to 310
3624  newcel(ncnt) = lseek
3625  nmon = nmon +1
3626  IF (nmon.GT.mxnode) go to 315
3627  IF (nmon.GT.mxnode) go to 320
3628  iflag(nmon) = lseek
3629  nflag(lseek) = 1
3630  20 CONTINUE
3631  IF (ncnt.GT.0.AND.nprox.EQ.0) go to 25
3632  IF (nprox.EQ.0) go to 45
3633  IF (nprox.EQ.15) go to 320
3634  nprox = nprox +1
3635  IF (ncnt.GT.0) go to 25
3636 
3637  rtest = vbest/vol(lbest)
3638  IF (rtest.GT.tolz) WRITE (6,920) nprox,vbest,vol(lbest),rtest
3639  920 FORMAT('DIFFICULTY, NPROX = ',i4,' MIN VDIFF = ',e13.5, &
3640  ' VOL ',e13.5,' RTEST ',e13.5)
3641 
3642  IF (rtest.GT.tolz) go to 320
3643  lseek = lbest
3644  go to 50
3645  25 lcnt = ncnt
3646  DO 40 k=1,lcnt
3647  nfill(k) = newcel(k)
3648  40 CONTINUE
3649  go to 10
3650  45 nprox = 1
3651  lseek = lbrk
3652  nfill(1) = lseek
3653  lcnt = 1
3654  go to 10
3655 !
3656 ! TETRAHEDRON LSEEK CONTAINS POINT (XPT,YPT,ZPT).
3657 ! INTERPOLATE LENGTH SCALE VALUE DENS FOR THE NEW POINT NP.
3658 !
3659  50 DO 60 k=1,nmon
3660  nflag(iflag(k)) = 0
3661  60 CONTINUE
3662  lcont = lseek
3663  IF (iprot(lcont).EQ.1) go to 330
3664  l1 = ndc(1,lcont)
3665  l2 = ndc(2,lcont)
3666  l3 = ndc(3,lcont)
3667  l4 = ndc(4,lcont)
3668 
3669  CALL tetcof(l1,l2,l3,l4,xpt,ypt,zpt,v1,v2,v3,v4,vtet,x)
3670 
3671  dens(np) = (v1*dens(l1) +v2*dens(l2) &
3672  +v3*dens(l3) +v4*dens(l4))/vtet
3673  IF (v1.GE.tolv.AND.v2.GE.tolv.AND.v3.GE.tolv &
3674  .AND.v4.GE.tolv) go to 100
3675  IF (v2.LT.tols.AND.v3.LT.tols.AND.v4.LT.tols) go to 340
3676  IF (v1.LT.tols.AND.v3.LT.tols.AND.v4.LT.tols) go to 340
3677  IF (v1.LT.tols.AND.v2.LT.tols.AND.v4.LT.tols) go to 340
3678  IF (v1.LT.tols.AND.v2.LT.tols.AND.v3.LT.tols) go to 340
3679  IF (v1.LT.tolv) go to 80
3680  IF (v2.LT.tolv) go to 85
3681  IF (v3.LT.tolv) go to 90
3682 
3683  CALL neighb(lcont,l1,l2,l3,lnext,k1,k2,ndc,nbh)
3684 
3685  l5 = ndc(1,lnext) +ndc(2,lnext) +ndc(3,lnext) &
3686  +ndc(4,lnext) -l1 -l2 -l3
3687 
3688  CALL tetcof(l1,l2,l3,l5,xpt,ypt,zpt,v1,v2,v3,v5,vtet,x)
3689 
3690  denb = (v1*dens(l1) +v2*dens(l2) +v3*dens(l3) &
3691  +v5*dens(l5))/vtet
3692  dens(np) = .5*(dens(np) +denb)
3693  go to 100
3694 
3695  80 CALL neighb(lcont,l2,l3,l4,lnext,k1,k2,ndc,nbh)
3696 
3697  l5 = ndc(1,lnext) +ndc(2,lnext) +ndc(3,lnext) &
3698  +ndc(4,lnext) -l2 -l3 -l4
3699 
3700  CALL tetcof(l2,l3,l4,l5,xpt,ypt,zpt,v2,v3,v4,v5,vtet,x)
3701 
3702  denb = (v2*dens(l2) +v3*dens(l3) +v4*dens(l4) &
3703  +v5*dens(l5))/vtet
3704  dens(np) = .5*(dens(np) +denb)
3705  go to 100
3706 
3707  85 CALL neighb(lcont,l3,l4,l1,lnext,k1,k2,ndc,nbh)
3708 
3709  l5 = ndc(1,lnext) +ndc(2,lnext) +ndc(3,lnext) &
3710  +ndc(4,lnext) -l3 -l4 -l1
3711 
3712  CALL tetcof(l3,l4,l1,l5,xpt,ypt,zpt,v3,v4,v1,v5,vtet,x)
3713 
3714  denb = (v3*dens(l3) +v4*dens(l4) +v1*dens(l1) &
3715  +v5*dens(l5))/vtet
3716  dens(np) = .5*(dens(np) +denb)
3717  go to 100
3718 
3719  90 CALL neighb(lcont,l4,l1,l2,lnext,k1,k2,ndc,nbh)
3720 
3721  l5 = ndc(1,lnext) +ndc(2,lnext) +ndc(3,lnext) &
3722  +ndc(4,lnext) -l4 -l1 -l2
3723 
3724  CALL tetcof(l4,l1,l2,l5,xpt,ypt,zpt,v4,v1,v2,v5,vtet,x)
3725 
3726  denb = (v4*dens(l4) +v1*dens(l1) +v2*dens(l2) &
3727  +v5*dens(l5))/vtet
3728  dens(np) = .5*(dens(np) +denb)
3729  100 RETURN
3730  310 CONTINUE
3731  WRITE (6,610)
3732  stop
3733  315 CONTINUE
3734  WRITE (6,615)
3735  stop
3736  320 CONTINUE
3737  DO 325 k=1,nmon
3738  nflag(iflag(k)) = 0
3739  325 CONTINUE
3740  nfail = 1
3741  RETURN
3742  330 CONTINUE
3743 ! WRITE (6,630)
3744  nfail = 2
3745  RETURN
3746  340 CONTINUE
3747  WRITE (6,640) np,x(1,np),x(2,np),x(3,np), &
3748  l1,l2,l3,l4,vtet,v1,v2,v3,v4
3749  stop
3750  350 CONTINUE
3751  nfail = 4
3752  RETURN
3753  360 CONTINUE
3754  WRITE (6,660)
3755 
3756  WRITE (6,910) np,x(1,np),x(2,np),x(3,np),ncont
3757  910 FORMAT('NP = ',i6,' X = ',f8.3,' Y = ',f8.3,' Z = ',f8.3, &
3758  ' NCONT ',i2)
3759  stop
3760 
3761  610 FORMAT(//5x,'DIMENSION OF NEWCEL EXCEEDED IN ROUTINE TETLOC'/ &
3762  5x,'INCREASE SIZE OF MTEST')
3763  615 FORMAT(//5x,'DIMENSION OF IFLAG EXCEEDED IN ROUTINE TETLOC'/ &
3764  5x,'INCREASE SIZE OF MBPTS')
3765  620 FORMAT(5x,'UNABLE TO FIND TETRAHEDRON THAT CONTAINS NEW POINT', &
3766  ' IN ROUTINE TETLOC')
3767  630 FORMAT(5x,'POINT LIES OUTSIDE DOMAIN TO BE MESHED')
3768  640 FORMAT(//5x,'NEW POINT, NP = ',i6,' X = ',f6.2,' Y = ',f6.2, &
3769  ' Z = ',f6.2/5x,'APPEARS TO BE COINCIDENT WITH AN', &
3770  ' EXISTING POINT IN THE MESH'/ &
3771  5x,'VERTEX ADDRESSES OF CONTAINING TETRAHEDRON'/ &
3772  5x,'L1 ',i6,' L2 ',i6,' L3 ',i6,' L4 ',i6,' VOL = ',e13.5/ &
3773  5x,'V1 = ',e13.5,' V2 = ',e13.5,' V3 = ',e13.5, &
3774  ' V4 = ',e13.5/5x,'PROGRAM STOPPED IN ROUTINE TETLOC')
3775  660 FORMAT(//5x,'A GEOMETRIC INCONSISTENCY HAS BEEN FOUND IN ROUTINE', &
3776  ' TETLOC.'/5x,'THE INSERTED POINT HAS A NEGATIVE', &
3777  ' ORIENTATION WITH RESPECT TO EVERY TETRAHEDRON FACE')
3778  END SUBROUTINE tetloc
3779 
3780 
3781 
3782 
3783 
3784 
3785 !
3786 ! ******************************************************************
3787 !
3788  SUBROUTINE cavity (NP,LCONT,NDEL,LDEL, &
3789  x,ndc,nbh,iprot,iflag,nflag, &
3790  xcen,ycen,zcen,rc,nfill,newcel,tolv)
3791 !
3792 ! ******************************************************************
3793 ! * *
3794 ! * STARTING FROM TETRAHEDRON LCONT WHICH CONTAINS THE POINT NP, *
3795 ! * CARRY OUT A TREE SEARCH TO FIND THE COMPLETE CAVITY OF *
3796 ! * TETRAHEDRA WHOSE CIRCUMSPHERES CONTAIN POINT NP *
3797 ! * *
3798 ! ******************************************************************
3799 ! ******************************************************************
3800 ! * *
3801 ! * COPYRIGHT (C) TIM BAKER 1994 *
3802 ! * *
3803 ! ******************************************************************
3804 !
3805  IMPLICIT NONE
3806 
3807  INTEGER :: lcont,ndel,np
3808  INTEGER :: iflag(*),nflag(*)
3809  INTEGER :: nfill(*),newcel(*)
3810  INTEGER :: ldel(*)
3811  INTEGER :: ndc(4,*),nbh(4,*),iprot(*)
3812  DOUBLE PRECISION :: tolv
3813  DOUBLE PRECISION :: x(3,*)
3814  DOUBLE PRECISION :: xcen(*),ycen(*),zcen(*),rc(*)
3815 
3816  INTEGER :: l,lseek,l1,l2,l3,k,k1,k2,lchk,lcnt,lnext,ncnt,nmon,m, &
3817  n1,n2,n3,n4,n5
3818  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,dcen,rnx,rny,rnz, &
3819  thres,tolp,vtet1,vtet2,xpt,ypt,zpt
3820 !
3821 ! ******************************************************************
3822 !
3823  tolp = 1.e-12
3824  xpt = x(1,np)
3825  ypt = x(2,np)
3826  zpt = x(3,np)
3827  ndel = 1
3828  ldel(1) = lcont
3829  lcnt = 1
3830  nfill(1) = lcont
3831  nmon = 1
3832  iflag(1) = lcont
3833  nflag(lcont) = 1
3834  10 ncnt = 0
3835 !
3836 ! SEARCH THROUGH NEIGHBORING TETRAHEDRA
3837 !
3838  DO 20 lchk=1,lcnt
3839  l = nfill(lchk)
3840  DO 20 k=1,4
3841  lseek = nbh(k,l)
3842 !
3843 ! CHECK WHETHER NEIGHBORING TETRAHEDRON LSEEK HAS ALREADY
3844 ! BEEN EXAMINED
3845 !
3846  IF (nflag(lseek).EQ.1) go to 20
3847 !
3848 ! CHECK WHETHER NEIGHBORING TETRAHEDRON LSEEK LIES OUTSIDE
3849 ! THE CONVEX HULL
3850 !
3851  IF (ndc(4,lseek).EQ.-1) go to 20
3852  nmon = nmon +1
3853  IF (nmon.GT.mxnode) go to 315
3854  iflag(nmon) = lseek
3855  nflag(lseek) = 1
3856 !
3857 ! CHECK WHETHER CIRCUMSPHERE OF TETRAHEDRON LSEEK CONTAINS
3858 ! THE POINT (XPT,YPT,ZPT)
3859 !
3860  dcen = sqrt((xpt -xcen(lseek))**2 +(ypt -ycen(lseek))**2 &
3861  +(zpt -zcen(lseek))**2)
3862  IF (dcen.GE.rc(lseek)*(1.+tolp))go to 20
3863 !
3864 ! CHECK WHETHER COMMON FACE IS PROTECTED
3865 !
3866  IF (iprot(lseek).EQ.1) go to 20
3867 !
3868 ! CHECK WHETHER ANY FACES OF TETRAHEDRON LSEEK ARE PROTECTED.
3869 ! IF A FACE IS PROTECTED, CHECK WHETHER FACE IS VISIBLE
3870 ! FROM POINT (XPT,YPT,ZPT)
3871 !
3872  DO 15 m=1,4
3873  lnext = nbh(m,lseek)
3874  IF (iprot(lnext).EQ.0) go to 15
3875 
3876  CALL lock(lseek,lnext,n1,n2,n3,n4,n5,k1,k2,ndc,nbh)
3877 
3878  l1 = max(n1,n2,n3)
3879  l3 = min(n1,n2,n3)
3880  l2 = n1 +n2 +n3 -l1 -l3
3881  rnx = cofact(x(2,l1),x(2,l2),x(2,l3),x(3,l1),x(3,l2),x(3,l3))
3882  rny = cofact(x(3,l1),x(3,l2),x(3,l3),x(1,l1),x(1,l2),x(1,l3))
3883  rnz = cofact(x(1,l1),x(1,l2),x(1,l3),x(2,l1),x(2,l2),x(2,l3))
3884  vtet1 = rnx*(xpt -x(1,l1)) +rny*(ypt -x(2,l1)) &
3885  +rnz*(zpt -x(3,l1))
3886  vtet2 = rnx*(x(1,n4) -x(1,l1)) +rny*(x(2,n4) -x(2,l1)) &
3887  +rnz*(x(3,n4) -x(3,l1))
3888  thres = max(1.0d0,abs(vtet2))
3889  IF (abs(vtet1).LT.tolv*thres) go to 20
3890  IF (vtet1*vtet2.LT.0.) go to 20
3891  15 CONTINUE
3892 !
3893 ! ADMIT TETRAHEDRON LSEEK TO LIST OF CAVITY TETRAHEDRA
3894 !
3895  17 ncnt = ncnt +1
3896  IF (ncnt.GT.mxtest) go to 310
3897  newcel(ncnt) = lseek
3898  ndel = ndel +1
3899  IF (ndel.GT.mxtest) go to 320
3900  ldel(ndel) = lseek
3901  20 CONTINUE
3902  IF (ncnt.EQ.0) go to 40
3903  lcnt = ncnt
3904  DO 30 k=1,lcnt
3905  nfill(k) = newcel(k)
3906  30 CONTINUE
3907  go to 10
3908  40 DO 50 k=1,nmon
3909  nflag(iflag(k)) = 0
3910  50 CONTINUE
3911  DO 60 k=1,ndel
3912  nflag(ldel(k)) = 1
3913  60 CONTINUE
3914  RETURN
3915  310 CONTINUE
3916  WRITE (6,610)
3917  stop
3918  315 CONTINUE
3919  WRITE (6,615)
3920  stop
3921  320 CONTINUE
3922  WRITE (6,620)
3923  stop
3924  610 FORMAT(//5x,'DIMENSION OF NEWCEL EXCEEDED IN ROUTINE CAVITY'/ &
3925  5x,'INCREASE SIZE OF MTEST')
3926  615 FORMAT(//5x,'DIMENSION OF IFLAG EXCEEDED IN ROUTINE CAVITY'/ &
3927  5x,'INCREASE SIZE OF MNODE')
3928  620 FORMAT(//5x,'DIMENSION OF LDEL EXCEEDED IN ROUTINE CAVITY'/ &
3929  5x,'INCREASE SIZE OF MTEST')
3930  END SUBROUTINE cavity
3931 
3932 
3933 
3934 
3935 !
3936 ! ******************************************************************
3937 !
3938  SUBROUTINE cavbnd (NP,LCONT,NDEL,LDEL,NCNT, &
3939  x,ndc,nbh,vol,iflag,nflag, &
3940  nfill,newcel,ntri,newnbh,nold,tolv)
3941 !
3942 ! ******************************************************************
3943 ! * *
3944 ! * SEARCH THROUGH LIST OF CAVITY TETRAHEDRA TO FIND THE FACES *
3945 ! * NTRI(3,--) ON THE CAVITY BOUNDARY *
3946 ! * *
3947 ! ******************************************************************
3948 ! ******************************************************************
3949 ! * *
3950 ! * COPYRIGHT (C) TIM BAKER 1994 *
3951 ! * *
3952 ! ******************************************************************
3953 !
3954  IMPLICIT NONE
3955 
3956  INTEGER :: lcont,ncnt,ndel,np
3957  INTEGER :: ndc(4,*),nbh(4,*)
3958  INTEGER :: iflag(*),nflag(*)
3959  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*),newcel(*)
3960  INTEGER :: ldel(*)
3961  DOUBLE PRECISION :: tolv
3962  DOUBLE PRECISION :: x(3,*),vol(*)
3963 
3964  INTEGER :: j,k,l,lchk,lcnt,ll,ltry,m,mend,mmax,mmin,msum, &
3965  m1,m2,m3,m4,n,ncont,nend,njoin,nmax,nmon,nmin, &
3966  nsum,nwatch,n1,n2,n3,n4
3967  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,fac,rnx,rny,rnz,vdiff, &
3968  vtet,vtet1,vtet2,v1,v2,v3,v4,xpt,ypt,zpt
3969 !
3970 ! ******************************************************************
3971 !
3972  xpt = x(1,np)
3973  ypt = x(2,np)
3974  zpt = x(3,np)
3975  10 ncnt = 0
3976  nwatch = 0
3977  DO 70 k=1,ndel
3978  njoin = 0
3979  n1 = ndc(1,ldel(k))
3980  n2 = ndc(2,ldel(k))
3981  n3 = ndc(3,ldel(k))
3982  n4 = ndc(4,ldel(k))
3983  DO 65 j=1,4
3984  l = nbh(j,ldel(k))
3985  IF (nflag(l).GT.0) go to 65
3986  nend = n4
3987  m1 = ndc(1,l)
3988  m2 = ndc(2,l)
3989  m3 = ndc(3,l)
3990  m4 = ndc(4,l)
3991  20 mend = m4
3992  nmin = min(n1,n2,n3)
3993  nmax = max(n1,n2,n3)
3994  nsum = n1 +n2 +n3
3995  30 mmin = min(m1,m2,m3)
3996  mmax = max(m1,m2,m3)
3997  msum = m1 +m2 +m3
3998  IF (mmin.EQ.nmin.AND.mmax.EQ.nmax.AND.msum.EQ.nsum) go to 40
3999  IF (m1.EQ.mend) go to 35
4000  m = m1
4001  m1 = m2
4002  m2 = m3
4003  m3 = m4
4004  m4 = m
4005  go to 30
4006  35 IF (n1.EQ.nend) go to 300
4007  n = n1
4008  n1 = n2
4009  n2 = n3
4010  n3 = n4
4011  n4 = n
4012  go to 20
4013 !
4014 ! CHECK WHETHER CAVITY FACE (N1,N2,N3) IS VISIBLE FROM
4015 ! POINT (XPT,YPT,ZPT)
4016 !
4017  40 rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
4018  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
4019  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
4020  fac = 1./sqrt(rnx*rnx +rny*rny +rnz*rnz)
4021  vtet1 = fac*(rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
4022  +rnz*(zpt -x(3,n1)))
4023  vtet2 = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
4024  +rnz*(x(3,n4) -x(3,n1))
4025 ! THRES = MAX(1.,ABS(VTET2))
4026 ! IF (LDEL(K).NE.LCONT.AND.ABS(VTET1).LT.TOLV*THRES) GO TO 45
4027  IF (ldel(k).NE.lcont.AND.abs(vtet1).LT.tolv) go to 45
4028  IF (vtet1*vtet2.GE.0.) go to 50
4029  45 nflag(ldel(k)) = 2
4030  nwatch = 1
4031  go to 70
4032 !
4033 ! CAVITY FACE (N1,N2,N3) IS VISIBLE. STORE VERTICES IN ARRAY
4034 ! NTRI
4035 !
4036  50 ncnt = ncnt +1
4037  IF (ncnt.GT.mxtest) go to 310
4038  njoin = njoin +1
4039  ntri(1,ncnt) = n1
4040  ntri(2,ncnt) = n2
4041  ntri(3,ncnt) = n3
4042  newnbh(1,ncnt) = l
4043  nold(ncnt) = ldel(k)
4044  65 CONTINUE
4045  IF (njoin.EQ.4.AND.ndel.GT.1) go to 320
4046  70 CONTINUE
4047  IF (nwatch.EQ.0) RETURN
4048  IF (nflag(lcont).EQ.2) go to 330
4049 !
4050 ! REPEAT TREE SEARCH TO FIND A CONTIGUOUS SET OF TETRAHEDRA,
4051 ! STARTING FROM TETRAHEDRON THAT CONTAINS POINT NP
4052 !
4053  lcnt = 1
4054  nfill(1) = lcont
4055  nmon = 1
4056  iflag(1) = lcont
4057  nflag(lcont) = 2
4058  80 ncnt = 0
4059  DO 85 lchk=1,lcnt
4060  l = nfill(lchk)
4061  DO 85 k=1,4
4062  ltry = nbh(k,l)
4063  IF (nflag(ltry).NE.1) go to 85
4064  nflag(ltry) = 2
4065  ncnt = ncnt +1
4066  newcel(ncnt) = ltry
4067  nmon = nmon +1
4068  IF (nmon.GT.mxnode) go to 335
4069  iflag(nmon) = ltry
4070  85 CONTINUE
4071  IF (ncnt.EQ.0) go to 95
4072  lcnt = ncnt
4073  DO 90 k=1,ncnt
4074  nfill(k) = newcel(k)
4075  90 CONTINUE
4076  go to 80
4077 !
4078 ! RE-INITIALIZE NFLAG ARRAY
4079 !
4080  95 DO 100 k=1,ndel
4081  nflag(ldel(k)) = 0
4082  100 CONTINUE
4083  ndel = nmon
4084  DO 110 k=1,ndel
4085  ldel(k) = iflag(k)
4086  nflag(ldel(k)) = 1
4087  110 CONTINUE
4088  go to 10
4089  300 CONTINUE
4090  WRITE (6,600)
4091  stop
4092  310 CONTINUE
4093  WRITE (6,610)
4094  stop
4095  320 CONTINUE
4096  WRITE (6,620)
4097  stop
4098  330 CONTINUE
4099  WRITE (6,630)
4100 
4101  CALL volcom(lcont,np,vdiff,ncont,x,ndc)
4102 
4103  n1 = ndc(1,lcont)
4104  n2 = ndc(2,lcont)
4105  n3 = ndc(3,lcont)
4106  n4 = ndc(4,lcont)
4107 
4108  CALL tetcof(n1,n2,n3,n4,xpt,ypt,zpt,v1,v2,v3,v4,vtet,x)
4109 
4110  WRITE (6,998) np,ndel,lcont,n1,n2,n3,n4, &
4111  v1,v2,v3,v4,vtet,vdiff,ncont
4112  998 FORMAT('NP ',i6,' NDEL ',i4,' LDEL ',i7,' N1,N2,N3,N4 ',4i6/ &
4113  'V1 ',e13.5,' V2 ',e13.5,' V3 ',e13.5,' V4 ',e13.5/ &
4114  ' VTET ',e13.5,' VDIFF ',e13.5,' NCONT ',i2)
4115  DO 996 k=1,ndel
4116  ll = ldel(k)
4117  n1 = ndc(1,ll)
4118  n2 = ndc(2,ll)
4119  n3 = ndc(3,ll)
4120  n4 = ndc(4,ll)
4121  996 WRITE (6,997) ll,nflag(ll),n1,n2,n3,n4,vol(ll)
4122  997 FORMAT('CELL ',i7,' NFLAG ',i2,' N1,N2,N3,N4 ',4i6,' VOL ',e13.5)
4123  stop
4124  335 CONTINUE
4125  WRITE (6,635)
4126  stop
4127  600 FORMAT(//5x,'UNABLE TO FIND A CONTIGUITY BETWEEN A CAVITY'/ &
4128  5x,'TETRAHEDRON AND A NON-CAVITY TETRAHEDRON'/ &
4129  5x,'PROGRAM STOPPED IN ROUTINE CAVBND')
4130  610 FORMAT(//5x,'DIMENSION OF NTRI ARRAY EXCEEDED IN ROUTINE CAVBND'/ &
4131  5x,'INCREASE SIZE OF MTEST')
4132  620 FORMAT(//5x,'FOUR CONTIGUITIES HAVE BEEN FOUND FOR A NEW' &
4133  ,' TETRAHEDRON'/ &
4134  5x,'NEW TETRAHEDRON IS THEREFORE ISOLATED'/ &
4135  5x,'PROGRAM STOPPED IN ROUTINE CAVBND')
4136  630 FORMAT(//5x,'TETRAHEDRON CONTAINING POINT HAS FAILED'/ &
4137  5x,'VISIBILITY TEST'/ &
4138  5x,'PROGRAM STOPPED IN ROUTINE CAVBND')
4139  635 FORMAT(//5x,'DIMENSION OF IFLAG EXCEEDED IN ROUTINE CAVBND.'/ &
4140  5x,'INCREASE SIZE OF MBPTS')
4141  END SUBROUTINE cavbnd
4142 
4143 
4144 
4145 
4146 
4147 
4148 !
4149 ! ******************************************************************
4150 !
4151  SUBROUTINE recon (LDEL,NDEL,NCNT, &
4152  ndc,nbh,iprot,ndg,idgp,ndgp,nflag, &
4153  ntri,ncavfc,ikeep,nedgrm,iedgrm)
4154 !
4155 ! ******************************************************************
4156 ! * *
4157 ! * REMOVE INTERNAL CAVITY EDGES FROM DATA STRUCTURE NDG. *
4158 ! * *
4159 ! ******************************************************************
4160 ! ******************************************************************
4161 ! * *
4162 ! * COPYRIGHT (C) TIM BAKER 1994 *
4163 ! * *
4164 ! ******************************************************************
4165 !
4166  IMPLICIT NONE
4167 
4168  INTEGER :: iedgrm,ncnt,ndel
4169  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),nflag(*)
4170  INTEGER :: ntri(3,*),nedgrm(*)
4171  INTEGER :: idgp(*),ndgp(*)
4172  INTEGER :: ldel(*),ncavfc(3,*),ikeep(*)
4173 
4174  INTEGER :: j,k,kcnt,l,l1,l2,m,mend,mmax,mmin,msum,m1,m2,m3,m4, &
4175  n,nedg,nend,nf,nmax,nmin,nsum,n1,n2,n3,n4
4176 !
4177 ! ******************************************************************
4178 !
4179 ! FORM LIST OF INTERNAL CAVITY FACES
4180 !
4181  iedgrm = 0
4182  nf = 0
4183  DO 70 k=1,ndel
4184  IF (iprot(ldel(k)).EQ.1) go to 370
4185  nflag(ldel(k)) = 0
4186  DO 65 j=1,4
4187  l = nbh(j,ldel(k))
4188  IF (nflag(l).EQ.0) go to 65
4189  n1 = ndc(1,ldel(k))
4190  n2 = ndc(2,ldel(k))
4191  n3 = ndc(3,ldel(k))
4192  n4 = ndc(4,ldel(k))
4193  nend = n4
4194  m1 = ndc(1,l)
4195  m2 = ndc(2,l)
4196  m3 = ndc(3,l)
4197  m4 = ndc(4,l)
4198  40 mend = m4
4199  nmin = min(n1,n2,n3)
4200  nmax = max(n1,n2,n3)
4201  nsum = n1 +n2 +n3
4202  45 mmin = min(m1,m2,m3)
4203  mmax = max(m1,m2,m3)
4204  msum = m1 +m2 +m3
4205  IF (mmin.EQ.nmin.AND.mmax.EQ.nmax.AND.msum.EQ.nsum) go to 60
4206  IF (m1.EQ.mend) go to 50
4207  m = m1
4208  m1 = m2
4209  m2 = m3
4210  m3 = m4
4211  m4 = m
4212  go to 45
4213  50 IF (n1.EQ.nend) go to 300
4214  n = n1
4215  n1 = n2
4216  n2 = n3
4217  n3 = n4
4218  n4 = n
4219  go to 40
4220  60 nf = nf +1
4221  IF (nf.GT.mxtest) go to 310
4222  ncavfc(1,nf) = n1
4223  ncavfc(2,nf) = n2
4224  ncavfc(3,nf) = n3
4225  65 CONTINUE
4226  70 CONTINUE
4227  IF (nf.EQ.0) RETURN
4228 !
4229 ! FORM LIST OF EDGES ON BOUNDARY CAVITY
4230 !
4231  kcnt = 0
4232  DO 100 l=1,ncnt
4233  n1 = ntri(1,l)
4234  n2 = ntri(2,l)
4235  n3 = ntri(3,l)
4236  90 l1 = min(n1,n2)
4237  l2 = max(n1,n2)
4238  nedg = idgp(l1)
4239  95 IF (nedg.EQ.0) go to 320
4240  IF (l2.EQ.ndg(2,nedg)) go to 97
4241  nedg = ndgp(nedg)
4242  go to 95
4243  97 IF (nflag(nedg).EQ.1) go to 98
4244  nflag(nedg) = 1
4245  kcnt = kcnt +1
4246  IF (kcnt.GT.mxtest) go to 330
4247  ikeep(kcnt) = nedg
4248  98 IF (n1.EQ.ntri(3,l)) go to 100
4249  n = n1
4250  n1 = n2
4251  n2 = n3
4252  n3 = n
4253  go to 90
4254  100 CONTINUE
4255 !
4256 ! CHECK FOR CAVITY EDGES THAT ARE NOT ON BOUNDARY
4257 !
4258  DO 140 j=1,nf
4259  n1 = ncavfc(1,j)
4260  n2 = ncavfc(2,j)
4261  n3 = ncavfc(3,j)
4262  110 l1 = min(n1,n2)
4263  l2 = max(n1,n2)
4264  nedg = idgp(l1)
4265  120 IF (nedg.EQ.0) go to 320
4266  IF (l2.EQ.ndg(2,nedg)) go to 130
4267  nedg = ndgp(nedg)
4268  go to 120
4269  130 IF (nflag(nedg).NE.0) go to 135
4270  nflag(nedg) = 2
4271  kcnt = kcnt +1
4272  IF (kcnt.GT.mxtest) go to 330
4273  ikeep(kcnt) = nedg
4274  135 IF (n1.EQ.ncavfc(3,j)) go to 140
4275  n = n1
4276  n1 = n2
4277  n2 = n3
4278  n3 = n
4279  go to 110
4280  140 CONTINUE
4281  IF (kcnt.EQ.0) RETURN
4282  DO 180 k=1,kcnt
4283  nedg = ikeep(k)
4284  IF (nflag(nedg).NE.2) go to 170
4285 
4286  CALL edgerm(nedg,ndg,idgp,ndgp)
4287 
4288  IF (iedgrm.EQ.mxtest) go to 170
4289  iedgrm = iedgrm +1
4290  nedgrm(iedgrm) = nedg
4291  170 nflag(nedg) = 0
4292  180 CONTINUE
4293  RETURN
4294 
4295  300 WRITE (6,600)
4296  stop
4297  310 WRITE (6,610)
4298  stop
4299  320 WRITE (6,620)
4300  stop
4301  330 WRITE (6,630)
4302  stop
4303  350 WRITE (6,650)
4304  stop
4305  370 WRITE (6,670)
4306  stop
4307  380 WRITE (6,680)
4308  stop
4309  600 FORMAT(//5x,'UNABLE TO FIND A CONTIGUITY BETWEEN CAVITY'/ &
4310  5x,'TETRAHEDRA'/ &
4311  5x,'PROGRAM STOPPED IN ROUTINE RECON')
4312  610 FORMAT(//5x,'DIMENSION OF NTRI ARRAY EXCEEDED IN ROUTINE RECON'/ &
4313  5x,'INCREASE SIZE OF MTEST')
4314  620 FORMAT(5x,'UNABLE TO FIND EDGE IN CAVITY AMONG NDG ARRAY',/ &
4315  'PROGRAM STOPPED IN ROUTINE RECON')
4316  630 FORMAT(//5x,'DIMENSION OF IKEEP ARRAY EXCEEDED IN ROUTINE RECON'/ &
4317  5x,'INCREASE SIZE OF MTEST')
4318  650 FORMAT(5x,'AT LEAST ONE INTERNAL CAVITY FACE IS A PROTECTED'/ &
4319  5x,'BOUNDARY FACE. PROGRAM STOPPED IN ROUTINE RECON')
4320  670 FORMAT(/5x,'AT LEAST ONE CAVITY TETRAHEDRON IS PROTECTED.'/ &
4321  5x,'PROGRAM STOPPED IN ROUTINE RECON.')
4322  680 FORMAT(//5x,'UNABLE TO FIND FACE IN LINKED LIST'/ &
4323  5x,'PROGRAM STOPPED IN RECON')
4324  END SUBROUTINE recon
4325 
4326 
4327 
4328 
4329 
4330 
4331 !
4332 ! ******************************************************************
4333 !
4334  SUBROUTINE cavedg (NCNT,NEDG,IPOINT,NPOINT, &
4335  ntri,ncav,newnbh,newcel)
4336 !
4337 ! ******************************************************************
4338 ! * *
4339 ! * GENERATE LIST OF EDGES ON CAVITY BOUNDARY AND CONSTRUCT EDGE *
4340 ! * ARRAY NCAV(4,--) *
4341 ! * *
4342 ! ******************************************************************
4343 ! ******************************************************************
4344 ! * *
4345 ! * COPYRIGHT (C) TIM BAKER 1994 *
4346 ! * *
4347 ! ******************************************************************
4348 !
4349  IMPLICIT NONE
4350 
4351  INTEGER :: ncnt,nedg
4352  INTEGER :: npoint(*),ipoint(*)
4353  INTEGER :: ntri(3,*),newnbh(4,*),newcel(*),ncav(4,*)
4354 
4355  INTEGER :: i,j1,j2,k,l,l1,l2,l3,next,n1,n2
4356 !
4357 ! ******************************************************************
4358 !
4359  nedg = 0
4360  DO 60 k=1,ncnt
4361  l1 = ntri(1,k)
4362  l2 = ntri(2,k)
4363  l3 = ntri(3,k)
4364  10 n1 = max(l1,l2)
4365  n2 = min(l1,l2)
4366  i = ipoint(n1)
4367  IF (i.EQ.0) go to 30
4368  20 IF (n2.EQ.ncav(2,i)) go to 40
4369  next = npoint(i)
4370  IF (next.EQ.0) go to 30
4371  i = next
4372  go to 20
4373  30 nedg = nedg +1
4374  IF (nedg.GT.mxcav) go to 300
4375  ncav(1,nedg) = n1
4376  ncav(2,nedg) = n2
4377  ncav(3,nedg) = k
4378  ncav(4,nedg) = 0
4379  npoint(nedg) = 0
4380  IF (i.NE.0) npoint(i) = nedg
4381  IF (i.EQ.0) ipoint(n1) = nedg
4382  go to 50
4383  40 ncav(4,i) = k
4384  50 IF (l1.EQ.ntri(3,k)) go to 60
4385  l = l1
4386  l1 = l2
4387  l2 = l3
4388  l3 = l
4389  go to 10
4390  60 CONTINUE
4391 !
4392 ! FROM EDGE LIST,FIND REMAINING THREE NEIGHBORING
4393 ! TETRAHEDRA TO EACH NEW VERTEX
4394 !
4395  DO 70 k=1,ncnt
4396  70 npoint(k) = 1
4397  DO 80 i=1,nedg
4398  j1 = ncav(3,i)
4399  j2 = ncav(4,i)
4400  npoint(j1) = npoint(j1) +1
4401  npoint(j2) = npoint(j2) +1
4402  newnbh(npoint(j1),j1) = newcel(j2)
4403  newnbh(npoint(j2),j2) = newcel(j1)
4404  80 CONTINUE
4405  DO 90 k=1,ncnt
4406  IF (npoint(k).NE.4) go to 310
4407  90 CONTINUE
4408 !
4409 ! SET IPOINT ENTRIES BACK TO ZERO
4410 !
4411  DO 100 k=1,ncnt
4412  IF (ntri(1,k).GT.0) ipoint(ntri(1,k)) = 0
4413  IF (ntri(2,k).GT.0) ipoint(ntri(2,k)) = 0
4414  IF (ntri(3,k).GT.0) ipoint(ntri(3,k)) = 0
4415  100 CONTINUE
4416  RETURN
4417  300 CONTINUE
4418  WRITE (6,600)
4419  stop
4420  310 CONTINUE
4421  WRITE (6,610)
4422  stop
4423  600 FORMAT(//5x,'DIMENSION OF NCAV EXCEEDED IN ROUTINE CAVEDG'/ &
4424  5x,'INCREASE SIZE OF MCAV')
4425  610 FORMAT(//5x,'UNABLE TO FIND ALL CONTIGUITIES BETWEEN NEW', &
4426  ' TETRAHEDRA'/5x,'PROGRAM STOPPED IN ROUTINE CAVEDG')
4427  END SUBROUTINE cavedg
4428 
4429 
4430 
4431 
4432 
4433 !
4434 ! ******************************************************************
4435 !
4436  SUBROUTINE datsrf (NP,NCNT,NEDG,NDG,IDGP,NDGP,NEDGE, &
4437  ipoint,ncav,nedgrm,iedgrm)
4438 !
4439 ! ******************************************************************
4440 ! * *
4441 ! * UPDATE EDGE DATA STRUCTURE NDG *
4442 ! * *
4443 ! ******************************************************************
4444 ! ******************************************************************
4445 ! * *
4446 ! * COPYRIGHT (C) TIM BAKER 1994 *
4447 ! * *
4448 ! ******************************************************************
4449 !
4450  IMPLICIT NONE
4451 
4452  INTEGER :: iedgrm,ncnt,nedg,nedge,np
4453  INTEGER :: ndg(2,*),idgp(*),ndgp(*)
4454  INTEGER :: ipoint(*)
4455  INTEGER :: ncav(4,*),nedgrm(*)
4456 
4457  INTEGER :: i,iedg,j1,j2,l1,l2,lp,nedcnt,newed,n1,n2
4458 
4459 !
4460 ! ******************************************************************
4461 !
4462 ! INSERT NEW EDGES INTO LIST NDG
4463 !
4464  nedcnt = 0
4465  DO 80 i=1,nedg
4466  n1 = ncav(1,i)
4467  n2 = ncav(2,i)
4468  j1 = ncav(3,i)
4469  j2 = ncav(4,i)
4470  IF (ipoint(n1).GT.0) go to 65
4471  l1 = min(n1,np)
4472  lp = max(n1,np)
4473  iedg = idgp(l1)
4474  IF (iedg.EQ.0) go to 50
4475  40 IF (ndgp(iedg).EQ.0) go to 50
4476  iedg = ndgp(iedg)
4477  go to 40
4478  50 nedcnt = nedcnt +1
4479  IF (nedcnt.GT.iedgrm) go to 55
4480  newed = nedgrm(nedcnt)
4481  go to 60
4482  55 nedge = nedge +1
4483  IF (nedge.GT.mxedge) go to 310
4484  newed = nedge
4485  60 ndg(1,newed) = l1
4486  ndg(2,newed) = lp
4487  ndgp(newed) = 0
4488  IF (iedg.EQ.0) idgp(l1) = newed
4489  IF (iedg.GT.0) ndgp(iedg) = newed
4490  ipoint(n1) = 1
4491  65 IF (ipoint(n2).GT.0) go to 80
4492  l2 = min(n2,np)
4493  lp = max(n2,np)
4494  iedg = idgp(l2)
4495  IF (iedg.EQ.0) go to 68
4496  66 IF (ndgp(iedg).EQ.0) go to 68
4497  iedg = ndgp(iedg)
4498  go to 66
4499  68 nedcnt = nedcnt +1
4500  IF (nedcnt.GT.iedgrm) go to 70
4501  newed = nedgrm(nedcnt)
4502  go to 75
4503  70 nedge = nedge +1
4504  IF (nedge.GT.mxedge) go to 310
4505  newed = nedge
4506  75 ndg(1,newed) = l2
4507  ndg(2,newed) = lp
4508  ndgp(newed) = 0
4509  IF (iedg.EQ.0) idgp(l2) = newed
4510  IF (iedg.GT.0) ndgp(iedg) = newed
4511  ipoint(n2) = 1
4512  80 CONTINUE
4513  RETURN
4514  310 WRITE (6,610)
4515  stop
4516  610 FORMAT(//5x,'DIMENSION OF NDG ARRAY EXCEEDED IN ROUTINE DATSRF.'/ &
4517  5x,'INCREASE SIZE OF MEDGE.')
4518  END SUBROUTINE datsrf
4519 
4520 
4521 
4522 
4523 
4524 !
4525 ! ******************************************************************
4526 !
4527  SUBROUTINE colaps (NA,NB,NCOL,NVERT,NFAIL, &
4528  x,ndc,nbh,iprot, &
4529  ityp,xcen,ycen,zcen,vol,rc,rat, &
4530  nvcnt,iflag,nflag,nptet, &
4531  ndg,idgp,ndgp, &
4532  noctr,ioctr,nlink,xfar,yfar,zfar,idone,nref, &
4533  ksrch,nsrch,iring,ntetkp, &
4534  lnbr,ishk,mnbr,kshk,tolv)
4535 !
4536 ! ******************************************************************
4537 ! * *
4538 ! * COLLAPSE EDGE (NA,NB) AND REMOVE THE TETRAHEDRA SURROUNDING *
4539 ! * EACH COLLAPSED EDGE. *
4540 ! * *
4541 ! ******************************************************************
4542 ! ******************************************************************
4543 ! * *
4544 ! * COPYRIGHT (C) TIM BAKER 1998 *
4545 ! * *
4546 ! ******************************************************************
4547 !
4548  IMPLICIT NONE
4549 
4550  INTEGER :: ioctr,na,nb,ncol,nfail,nvert
4551  INTEGER :: ityp(*),ndc(4,*),nbh(4,*),iprot(*),ndg(2,*)
4552  INTEGER :: idgp(*),ndgp(*)
4553  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
4554  INTEGER :: nvcnt(*),nptet(*)
4555  INTEGER :: iflag(*),nflag(*)
4556  INTEGER :: nsrch(*),ksrch(*)
4557  INTEGER :: iring(*),ntetkp(*),lnbr(*),ishk(*),mnbr(*),kshk(*)
4558  DOUBLE PRECISION :: tolv
4559  DOUBLE PRECISION :: x(3,*)
4560  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
4561  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
4562 
4563  INTEGER :: i,iedg,imon,inad,ip1,ismall,itypt,jnext,jpre,k,kcnt, &
4564  kk,k1,k2,l,lc,ln,l1,l2,m,m1,m2,m3,m4,n,nabdy,nbbdy, &
4565  ncnt,nexch,nkeep,np,npass,npnext,npre,nrbdy,nrngp1, &
4566  nring,n1,n2,n3,n4
4567  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,radc,radmax,ratmax, &
4568  rcrin,rnx,rny,rnz,tols,vl,vtet1,vtet2,xcn, &
4569  ycn,zcn,xpt,ypt,zpt
4570 !
4571 ! ******************************************************************
4572 !
4573  nfail = 0
4574  nvert = 0
4575  tols = 1.e-9
4576  IF (na.LT.0.OR.nb.LT.0) RETURN
4577  IF (ityp(na).LT.0.OR.ityp(nb).LT.0) RETURN
4578 !
4579 ! FIND A TETRAHEDRON THAT IS INCIDENT TO EDGE (NA,NB)
4580 !
4581  ksrch(1) = nptet(na)
4582  imon = 0
4583  kcnt = 1
4584  10 ncnt = 0
4585  DO 22 k=1,kcnt
4586  lc = ksrch(k)
4587  IF (lc.LE.0) go to 300
4588  IF (nflag(lc).EQ.1) go to 22
4589  m1 = ndc(1,lc)
4590  m2 = ndc(2,lc)
4591  m3 = ndc(3,lc)
4592  m4 = ndc(4,lc)
4593  IF (m1.NE.nb.AND.m2.NE.nb.AND.m3.NE.nb.AND.m4.NE.nb) go to 15
4594  go to 30
4595  15 nflag(lc) = 1
4596  imon = imon +1
4597  IF (imon.GT.mxnode) go to 310
4598 ! IF (IMON.GT.MXNODE) GO TO 200
4599  iflag(imon) = lc
4600  DO 20 m=1,4
4601  ln = nbh(m,lc)
4602  IF (nflag(ln).EQ.1) go to 20
4603  m1 = ndc(1,ln)
4604  m2 = ndc(2,ln)
4605  m3 = ndc(3,ln)
4606  m4 = ndc(4,ln)
4607  IF (m1.NE.na.AND.m2.NE.na.AND.m3.NE.na.AND.m4.NE.na) go to 20
4608  ncnt = ncnt +1
4609  IF (ncnt.GT.mxtest) go to 320
4610  nsrch(ncnt) = ln
4611  20 CONTINUE
4612  22 CONTINUE
4613  IF (ncnt.EQ.0) go to 200
4614  kcnt = ncnt
4615  DO 25 k=1,kcnt
4616  ksrch(k) = nsrch(k)
4617  25 CONTINUE
4618  go to 10
4619 !
4620 ! TETRAHEDRON FOUND. RE-INITIALIZE ARRAY NFLAG
4621 !
4622  30 IF (imon.EQ.0) go to 40
4623  DO 35 k=1,imon
4624  nflag(iflag(k)) = 0
4625  35 CONTINUE
4626 !
4627 ! FIND ADDRESSES N1 AND N2 OF REMAINING TWO VERTICES OF TETRAHEDRON
4628 !
4629  40 DO 45 k=1,4
4630  m = ndc(k,lc)
4631  IF (m.NE.na.AND.m.NE.nb) go to 50
4632  45 CONTINUE
4633  50 n1 = m
4634  n2 = ndc(1,lc) +ndc(2,lc) +ndc(3,lc) +ndc(4,lc) &
4635  -na -nb -n1
4636  IF (n1.GT.0) THEN
4637  IF (nvcnt(n1).EQ.4) THEN
4638  nvert = n1
4639  RETURN
4640  ENDIF
4641  ENDIF
4642 !
4643 ! STARTING FROM FACE (N1,NA,NB) FIND SEQUENCE OF TETRAHEDRA
4644 ! INCIDENT TO EDGE (NA,NB) UNTIL FACE (N2,NA,NB) IS REACHED
4645 !
4646  nrbdy = 0
4647  nring = 1
4648 
4649  CALL neighb(lc,n1,na,nb,jnext,k1,k2,ndc,nbh)
4650 
4651  npnext = ndc(1,jnext) +ndc(2,jnext) +ndc(3,jnext) &
4652  +ndc(4,jnext) -n1 -na -nb
4653  iring(1) = n1
4654  ntetkp(1) = jnext
4655  nflag(jnext) = 1
4656  iflag(1) = jnext
4657  IF (iprot(jnext).EQ.1) nrbdy = 1
4658  60 jpre = jnext
4659  npre = npnext
4660 
4661  CALL neighb(jpre,npre,na,nb,jnext,k1,k2,ndc,nbh)
4662 
4663  npnext = ndc(1,jnext) +ndc(2,jnext) +ndc(3,jnext) &
4664  +ndc(4,jnext) -npre -na -nb
4665  IF (npre.GT.0) THEN
4666  IF (nvcnt(npre).EQ.4) THEN
4667  nvert = npre
4668  DO 62 k=1,nring
4669  nflag(iflag(k)) = 0
4670  62 CONTINUE
4671  RETURN
4672  ENDIF
4673  ENDIF
4674  nring = nring +1
4675  IF (nring.GT.mxring) go to 340
4676  iring(nring) = npre
4677  ntetkp(nring) = jnext
4678  nflag(jnext) = 1
4679  iflag(nring) = jnext
4680  IF (iprot(jnext).EQ.1) nrbdy = 1
4681  IF (npnext.EQ.n1) go to 350
4682  IF (npnext.NE.n2) go to 60
4683  IF (n2.GT.0) THEN
4684  IF (nvcnt(n2).EQ.4) THEN
4685  nvert = n2
4686  DO 64 k=1,nring
4687  nflag(iflag(k)) = 0
4688  64 CONTINUE
4689  RETURN
4690  ENDIF
4691  ENDIF
4692  nring = nring +1
4693  IF (nring.GT.mxring) go to 340
4694  iring(nring) = n2
4695  ntetkp(nring) = lc
4696  nflag(lc) = 1
4697  iflag(nring) = lc
4698  imon = nring
4699 !
4700 ! FIND ALL TETRAHEDRA THAT ARE INCIDENT TO THE VERTICES NA AND NB
4701 !
4702  nabdy = 0
4703  nbbdy = 0
4704  np = na
4705  65 ksrch(1) = nptet(np)
4706  kcnt = 1
4707  lc = ksrch(1)
4708  n1 = ndc(1,lc)
4709  n2 = ndc(2,lc)
4710  n3 = ndc(3,lc)
4711  n4 = ndc(4,lc)
4712  IF (lc.LE.0) go to 300
4713  IF (nflag(lc).GT.0) go to 70
4714  IF (n1.NE.np.AND.n2.NE.np.AND.n3.NE.np.AND.n4.NE.np) go to 70
4715  nflag(lc) = np
4716  imon = imon +1
4717  IF (imon.GT.mxnode) go to 310
4718  iflag(imon) = lc
4719  IF (iprot(lc).EQ.1.AND.np.EQ.na) nabdy = 1
4720  IF (iprot(lc).EQ.1.AND.np.EQ.nb) nbbdy = 1
4721  70 ncnt = 0
4722  DO 75 k=1,kcnt
4723  l = ksrch(k)
4724  DO 75 m=1,4
4725  lc = nbh(m,l)
4726  IF (lc.LE.0) go to 300
4727  IF (nflag(lc).GT.0) go to 75
4728  n1 = ndc(1,lc)
4729  n2 = ndc(2,lc)
4730  n3 = ndc(3,lc)
4731  n4 = ndc(4,lc)
4732  IF (n1.NE.np.AND.n2.NE.np.AND.n3.NE.np.AND.n4.NE.np) go to 75
4733  ncnt = ncnt +1
4734  IF (ncnt.GT.mxtest) go to 320
4735  nsrch(ncnt) = lc
4736  nflag(lc) = np
4737  imon = imon +1
4738  IF (imon.GT.mxnode) go to 310
4739  iflag(imon) = lc
4740  IF (iprot(lc).EQ.1.AND.np.EQ.na) nabdy = 1
4741  IF (iprot(lc).EQ.1.AND.np.EQ.nb) nbbdy = 1
4742  75 CONTINUE
4743  IF (ncnt.EQ.0) go to 85
4744  kcnt = ncnt
4745  DO 80 k=1,kcnt
4746  ksrch(k) = nsrch(k)
4747  80 CONTINUE
4748  go to 70
4749  85 IF (np.EQ.nb) go to 90
4750  np = nb
4751  go to 65
4752 !
4753 ! FIND NEIGHBORS OF THE TETRAHEDRAL RING
4754 !
4755  90 radmax = 0.
4756  ratmax = 0.
4757  DO 115 i=1,nring
4758  radmax = max(radmax,rc(ntetkp(i)))
4759  ratmax = max(ratmax,rat(ntetkp(i)))
4760  ip1 = mod(i,nring) +1
4761 
4762  CALL neighb(ntetkp(i),iring(i),iring(ip1),na,lnbr(i),kk,ishk(i), &
4763  ndc,nbh)
4764 
4765  CALL neighb(ntetkp(i),iring(i),iring(ip1),nb,mnbr(i),kk,kshk(i), &
4766  ndc,nbh)
4767 
4768  115 CONTINUE
4769 !
4770 ! DEFINE COORDINATES OF NEW POINT TO REPLACE POINTS AT NA AND NB
4771 !
4772 ! Exit from COLAPS if edge (NA,NB) lies on the boundary.
4773 !
4774  IF (nabdy.EQ.1.AND.nbbdy.EQ.1) go to 230
4775 
4776  npass = 0
4777  xpt = .5*(x(1,na) +x(1,nb))
4778  ypt = .5*(x(2,na) +x(2,nb))
4779  zpt = .5*(x(3,na) +x(3,nb))
4780  itypt = max(ityp(na),ityp(nb))
4781  IF (nrbdy.EQ.nabdy.AND.nrbdy.EQ.nbbdy) go to 118
4782  xpt = x(1,na)
4783  ypt = x(2,na)
4784  zpt = x(3,na)
4785  itypt = ityp(na)
4786  IF (nrbdy.EQ.0.AND.nabdy.EQ.1.AND.nbbdy.EQ.0) go to 118
4787  xpt = x(1,nb)
4788  ypt = x(2,nb)
4789  zpt = x(3,nb)
4790  itypt = ityp(nb)
4791  nexch = na
4792  na = nb
4793  nb = nexch
4794  IF (nrbdy.EQ.0.AND.nabdy.EQ.0.AND.nbbdy.EQ.1) THEN
4795  nabdy = 1
4796  nbbdy = 0
4797  go to 118
4798  ELSE
4799  go to 230
4800  ENDIF
4801 !
4802 ! CHECK WHETHER NEW TETRAHEDRAL RING FORMS A CONVEX ENSEMBLE
4803 !
4804  118 nrngp1 = nring +1
4805  DO 125 i=nrngp1,imon
4806  l = iflag(i)
4807  IF (iprot(l).EQ.1) go to 125
4808  n1 = ndc(1,l)
4809  n2 = ndc(2,l)
4810  n3 = ndc(3,l)
4811  n4 = ndc(4,l)
4812  120 IF (n4.EQ.na.OR.n4.EQ.nb) go to 123
4813  nkeep = n1
4814  n1 = n2
4815  n2 = n3
4816  n3 = n4
4817  n4 = nkeep
4818  go to 120
4819  123 rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
4820  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
4821  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
4822  vtet1 = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
4823  +rnz*(x(3,n4) -x(3,n1))
4824  vtet2 = rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
4825  +rnz*(zpt -x(3,n1))
4826  IF (abs(vtet2).LT.tols.OR.vtet1*vtet2.LT.0.0) THEN
4827  IF (npass.EQ.1) THEN
4828  go to 220
4829  ELSE
4830  npass = 1
4831  IF (n4.EQ.na.AND.nabdy.EQ.0.AND.nbbdy.EQ.1) go to 220
4832  IF (n4.EQ.nb.AND.nabdy.EQ.1.AND.nbbdy.EQ.0) go to 220
4833  xpt = x(1,n4)
4834  ypt = x(2,n4)
4835  zpt = x(3,n4)
4836  itypt = ityp(n4)
4837  go to 118
4838  ENDIF
4839  ENDIF
4840 
4841  CALL circum2(x,n1,n2,n3,xpt,ypt,zpt, &
4842  xcn,ycn,zcn,vl,radc,ismall,tolv)
4843 
4844  IF (radc.GT.50.*radmax) go to 220
4845  area = tetar3(n1,n2,n3,xpt,ypt,zpt,x)
4846  rcrin = radc*area/vl
4847  IF (rcrin.GT.50.*ratmax) go to 220
4848  125 CONTINUE
4849 !
4850 ! MODIFY BOUNDARY DATA STRUCTURE IF THE EDGE (NA,NB) IS
4851 ! A BOUNDARY EDGE
4852 !
4853 !
4854 ! ASSIGN NEW POINT TO ADDRESS NA
4855 !
4856 !
4857  CALL octrmv(na,x,noctr,nlink,idone,nref)
4858 
4859  CALL octrmv(nb,x,noctr,nlink,idone,nref)
4860 
4861  ityp(nb) = -1
4862  x(1,na) = xpt
4863  x(2,na) = ypt
4864  x(3,na) = zpt
4865  ityp(na) = itypt
4866 
4867  CALL octfil(na,x,noctr,ioctr,nlink,nref,xfar,yfar,zfar)
4868 
4869  idone(na) = 1
4870  ncol = ncol +1
4871 !
4872 ! REMOVE RING OF TETRAHEDRA AND UPDATE NBH ARRAY
4873 !
4874  DO 130 i=1,nring
4875  nbh(1,ntetkp(i)) = 0
4876  nbh(2,ntetkp(i)) = 0
4877  nbh(3,ntetkp(i)) = 0
4878  nbh(4,ntetkp(i)) = 0
4879  nbh(ishk(i),lnbr(i)) = mnbr(i)
4880  nbh(kshk(i),mnbr(i)) = lnbr(i)
4881  IF (iring(i).GT.0) nvcnt(iring(i)) = nvcnt(iring(i)) -1
4882  130 CONTINUE
4883  nvcnt(na) = nvcnt(na) +nvcnt(nb) -nring -2
4884 !
4885 ! REMOVE EDGE (NA,NB) AND EDGES JOINING NB TO RING POINTS
4886 ! FROM DATA STRUCTURE NDG
4887 !
4888  l1 = min(na,nb)
4889  l2 = max(na,nb)
4890  iedg = idgp(l1)
4891  135 IF (iedg.EQ.0) go to 330
4892  IF (l2.EQ.ndg(2,iedg)) go to 140
4893  iedg = ndgp(iedg)
4894  go to 135
4895 
4896  140 CALL edgerm(iedg,ndg,idgp,ndgp)
4897 
4898  DO 152 i=1,nring
4899  IF (iring(i).LT.0) go to 152
4900  l1 = min(nb,iring(i))
4901  l2 = max(nb,iring(i))
4902  iedg = idgp(l1)
4903  145 IF (iedg.EQ.0) go to 330
4904  IF (l2.EQ.ndg(2,iedg)) go to 150
4905  iedg = ndgp(iedg)
4906  go to 145
4907 !
4908  150 CALL edgerm(iedg,ndg,idgp,ndgp)
4909 !
4910  152 CONTINUE
4911 !
4912 ! UPDATE NDC ARRAYS WHICH REFER TO POINT NB
4913 !
4914  DO 162 i=nrngp1,imon
4915  l = iflag(i)
4916  IF (nflag(l).EQ.na) go to 162
4917  n1 = ndc(1,l)
4918  n2 = ndc(2,l)
4919  n3 = ndc(3,l)
4920  n4 = ndc(4,l)
4921  IF (n1.EQ.nb) ndc(1,l) = na
4922  IF (n2.EQ.nb) ndc(2,l) = na
4923  IF (n3.EQ.nb) ndc(3,l) = na
4924  IF (n4.EQ.nb) ndc(4,l) = na
4925  162 CONTINUE
4926 !
4927 ! UPDATE NDG ARRAYS WHICH REFER TO POINT NB
4928 !
4929  DO 177 i=nrngp1,imon
4930  l = iflag(i)
4931  IF (nflag(l).EQ.na) go to 177
4932  DO 175 k=1,4
4933  n = ndc(k,l)
4934  IF (n.LT.0.OR.n.EQ.na) go to 175
4935  l1 = min(n,nb)
4936  l2 = max(n,nb)
4937  iedg = idgp(l1)
4938  165 IF (iedg.EQ.0) go to 175
4939  IF (l2.EQ.ndg(2,iedg)) go to 170
4940  iedg = ndgp(iedg)
4941  go to 165
4942 
4943  170 CALL edgerm(iedg,ndg,idgp,ndgp)
4944 
4945  m1 = min(n,na)
4946  m2 = max(n,na)
4947  inad = idgp(m1)
4948  IF (inad.EQ.0) go to 174
4949  172 IF (ndgp(inad).EQ.0) go to 174
4950  inad = ndgp(inad)
4951  go to 172
4952  174 ndg(1,iedg) = m1
4953  ndg(2,iedg) = m2
4954  ndgp(iedg) = 0
4955  IF (inad.EQ.0) idgp(m1) = iedg
4956  IF (inad.GT.0) ndgp(inad) = iedg
4957  175 CONTINUE
4958  177 CONTINUE
4959 !
4960 ! COMPUTE VOLUME,CIRCUMCENTER AND CIRCUMRADIUS FOR NEW CELLS
4961 !
4962  DO 195 k=nrngp1,imon
4963  l = iflag(k)
4964  IF (iprot(l).EQ.1) go to 195
4965  n1 = ndc(1,l)
4966  n2 = ndc(2,l)
4967  n3 = ndc(3,l)
4968  n4 = ndc(4,l)
4969 
4970  CALL circum(x,n1,n2,n3,n4,xcn,ycn,zcn,vl,radc,ismall,tolv)
4971 
4972  IF (ismall.EQ.1) go to 360
4973  xcen(l) = xcn
4974  ycen(l) = ycn
4975  zcen(l) = zcn
4976  vol(l) = vl
4977  rc(l) = radc
4978  area = tetar(l,x,ndc)
4979  rat(l) = rc(l)*area/vol(l)
4980  DO 190 i=1,4
4981  n = ndc(i,l)
4982  nptet(n) = l
4983  190 CONTINUE
4984  195 CONTINUE
4985  go to 250
4986 !
4987 ! FAILURE MODES
4988 !
4989  200 nfail = 1
4990 ! WRITE (6,700) NA,NB
4991  700 FORMAT('EDGE WITH VERTICES ',i6,' , ',i6,' DOES NOT EXIST.'/ &
4992  'COLLAPSE OF THESE TWO POINTS IS NOT POSSIBLE.')
4993  go to 250
4994  220 nfail = 3
4995 ! WRITE (6,720) NA,NB
4996  720 FORMAT('ATTEMPTED COLLAPSE OF EDGE WITH VERTICES ',i6,' , ',i6/ &
4997  'CREATES A NON-CONVEX TETRAHEDRON')
4998  go to 250
4999  230 nfail = 4
5000 ! WRITE (6,725) NA,NB
5001  725 FORMAT('ATTEMPTED COLLAPSE OF AN EDGE THAT DOES NOT LIE IN THE'/ &
5002  'BOUNDARY SURFACE BUT WHOSE END-POINTS ',i6,' AND ',i6/ &
5003  'BOTH LIE IN THE BOUNDARY SURFACE')
5004 !
5005 ! RE-INITIALIZE NFLAG ARRAY
5006 !
5007  250 DO 260 i=1,imon
5008  nflag(iflag(i)) = 0
5009  260 CONTINUE
5010  RETURN
5011  300 WRITE (6,600) na,nb,lc
5012  stop
5013  310 WRITE (6,610)
5014  stop
5015  320 WRITE (6,620)
5016  stop
5017  330 WRITE (6,630)
5018  stop
5019  340 WRITE (6,640)
5020  stop
5021  350 WRITE (6,650)
5022  stop
5023  360 WRITE (6,660)
5024  stop
5025  600 FORMAT(///5x,'INVALID TETRAHEDRON ADDRESS FOUND WHILE SEARCHING'/ &
5026  5x,'FOR A TETRAHEDRON INCIDENT TO EDGE WITH VERTICES', &
5027  i6,' , ',i6/5x,'TETRAHEDRON ADDRESS IS ',i7/ &
5028  5x,'PROGRAM STOPPED IN ROUTINE COLAPS')
5029  610 FORMAT(///5x,'DIMENSION OF ARRAY IFLAG EXCEEDED. INCREASE SIZE'/ &
5030  5x,'OF MNODE. PROGRAM STOPPED IN COLAPS')
5031  620 FORMAT(///5x,'DIMENSION OF ARRAY NSRCH EXCEEDED. INCREASE SIZE'/ &
5032  5x,'OF MTEST. PROGRAM STOPPED IN COLAPS')
5033  650 FORMAT(///5x,'SEARCH FOR TETRAHEDRAL RING HAS RETURNED TO THE'/ &
5034  5x,'STARTING FACE. THIS INDICATES AN INCONSISTENCY IN'/ &
5035  5x,'THE TETRAHEDRAL ENSEMBLE.'/ &
5036  5x,'PROGRAM STOPPED IN COLAPS')
5037  630 FORMAT(///5x,'UNABLE TO FIND EDGE ADDRESS FOR A NEW TETRAHEDRON'/ &
5038  5x,'PROGRAM STOPPED IN ROUTINE COLAPS')
5039  640 FORMAT(///5x,'DIMENSION OF ARRAY IRING EXCEEDED. INCREASE SIZE'/ &
5040  5x,'OF MRING. PROGRAM STOPPED IN COLAPS')
5041  660 FORMAT(///5x,'AT LEAST ONE NEW TETRAHEDRON HAS TOO SMALL A VOLUME' &
5042  /5x,'PROGRAM STOPPED IN COLAPS')
5043  END SUBROUTINE colaps
5044 
5045 
5046 
5047 
5048 
5049 
5050 !
5051 ! ******************************************************************
5052 !
5053  SUBROUTINE smooth (X,ITYP,NNODE,NDC,NBH,IPROT,NCELL, &
5054  ndg,idgp,ndgp,nedge, &
5055  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
5056  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
5057  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
5058  xkeep,ykeep,zkeep,ksrch,nsrch, &
5059  ipoint,npoint,iflag,nflag, &
5060  dx,dy,dz,ds,vlt,iring,ntetkp,nfad,newc, &
5061  nbhkp,iedkp,lnbr,ishk,mnbr,kshk,npp, &
5062  nfill,newcel,ntri, &
5063  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
5064  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
5065  listf,volmin,rcmx,tolv)
5066 !
5067 ! ******************************************************************
5068 ! * *
5069 ! * OPTIMIZE MESH QUALITY BY ALTERNATELY SWAPPING EDGE/FACE *
5070 ! * COMBINATIONS AND ADJUSTING POINT POSITIONS. *
5071 ! * *
5072 ! ******************************************************************
5073 ! ******************************************************************
5074 ! * *
5075 ! * COPYRIGHT (C) TIM BAKER 1994 *
5076 ! * *
5077 ! ******************************************************************
5078 !
5079  IMPLICIT NONE
5080 
5081  INTEGER :: ioctr,ncell,nedge,nnode
5082  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),idgp(*),ndgp(*)
5083  INTEGER :: idone(*),nref(*),nlink(*),noctr(2,*)
5084  INTEGER :: ityp(*),nptet(*),nacpt(*),listf(*)
5085  INTEGER :: npoint(*),ipoint(*)
5086  INTEGER :: iflag(*),nflag(*)
5087  INTEGER :: lnkup(*),lnkdn(*)
5088  INTEGER :: nsrch(*),ksrch(*)
5089  INTEGER :: iring(*),ntetkp(*),nfad(3,*),newc(*), &
5090  nbhkp(3,*),iedkp(4,*),lnbr(*),ishk(*), &
5091  mnbr(*),kshk(*),npp(*)
5092  INTEGER :: ntri(3,*),nfill(*),newnbh(4,*),nold(*), &
5093  newcel(*),nshake(*),ncav(4,*)
5094  INTEGER :: nedgrm(*)
5095  INTEGER :: ldel(*),ncavfc(3,*),ikeep(*)
5096  DOUBLE PRECISION :: volmin,rcmx,tolv
5097  DOUBLE PRECISION :: x(3,*),dens(*)
5098  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
5099  DOUBLE PRECISION :: xoctr(2,*),yoctr(2,*),zoctr(2,*), &
5100  xhold(2,*),yhold(2,*),zhold(2,*), &
5101  xfar(2),yfar(2),zfar(2),xkeep(2), &
5102  ykeep(2),zkeep(2)
5103  DOUBLE PRECISION :: dx(*),dy(*),dz(*),ds(*),vlt(*)
5104  DOUBLE PRECISION :: xc(*),yc(*),zc(*),v(*),rad(*),rcrin(*)
5105  DOUBLE PRECISION :: ang(6)
5106 
5107  INTEGER :: i,i1,i2,i3,j,k,l,loop,m1,m2,n,na,nb,nchk,nfail, &
5108  nmax,nmin,nn,np,npass,npt,nring,nsum,ntet, &
5109  nwait,n1,n2,n3,n4
5110  DOUBLE PRECISION :: angmax,angmx1,angmx2,angmx3
5111 
5112 !
5113 ! ******************************************************************
5114 !
5115 ! CREATE ORDERED LIST OF CELLS ACCORDING TO CIRCUM-RADIUS TO
5116 ! IN-RADIUS RATIO
5117 !
5118  WRITE (6,610)
5119 
5120  DO 140 loop=1,10
5121 
5122  CALL tree(rat,lnkdn,lnkup,nflag,listf,nacpt,nwait, &
5123  nbh,iprot,ncell)
5124 
5125  30 WRITE (6,910) nwait,loop
5126  910 FORMAT(//'IN SMOOTH, NWAIT = ',i7,' ITERATION ',i2)
5127 !
5128 ! SEARCH THROUGH LIST OF CELLS AND TRY TO REMOVE SLIVERS BY
5129 ! EDGE/FACE SWAPS
5130 !
5131  nchk = 0
5132  l = 1
5133  40 j = listf(l)
5134  IF (nbh(1,j).LE.0) go to 130
5135  IF (nacpt(j).EQ.1) go to 130
5136  nacpt(j) = 1
5137  n1 = ndc(1,j)
5138  n2 = ndc(2,j)
5139  n3 = ndc(3,j)
5140  n4 = ndc(4,j)
5141  ang(1) = dihed(n1,n2,n3,n4,x)
5142  IF (ang(1).GT.180.) ang(1) = 360. -ang(1)
5143  ang(2) = dihed(n2,n3,n4,n1,x)
5144  IF (ang(2).GT.180.) ang(2) = 360. -ang(2)
5145  ang(3) = dihed(n3,n4,n1,n2,x)
5146  IF (ang(3).GT.180.) ang(3) = 360. -ang(3)
5147  ang(4) = dihed(n4,n1,n2,n3,x)
5148  IF (ang(4).GT.180.) ang(4) = 360. -ang(4)
5149  ang(5) = dihed(n1,n3,n2,n4,x)
5150  IF (ang(5).GT.180.) ang(5) = 360. -ang(5)
5151  ang(6) = dihed(n2,n4,n1,n3,x)
5152  IF (ang(6).GT.180.) ang(6) = 360. -ang(6)
5153 !
5154 ! FIND THE THREE EDGES WITH THE LARGEST DIHEDRAL ANGLES
5155 !
5156  i1 = 1
5157  angmx1 = ang(1)
5158  DO 50 k=2,6
5159  IF (ang(k).LT.angmx1) go to 50
5160  i1 = k
5161  angmx1 = ang(k)
5162  50 CONTINUE
5163  i2 = 0
5164  DO 60 k=1,6
5165  IF (k.EQ.i1) go to 60
5166  IF (i2.EQ.0) go to 55
5167  IF (ang(k).LT.angmx2) go to 60
5168  55 i2 = k
5169  angmx2 = ang(k)
5170  60 CONTINUE
5171  i3 = 0
5172  DO 70 k=1,6
5173  IF (k.EQ.i1.OR.k.EQ.i2) go to 70
5174  IF (i3.EQ.0) go to 65
5175  IF (ang(k).LT.angmx3) go to 70
5176  65 i3 = k
5177  angmx3 = ang(k)
5178  70 CONTINUE
5179 !
5180 ! DETERMINE WHETHER THE SINGULAR TETRAHEDRON IS A FLAT OR A SLIVER
5181 !
5182  np = 0
5183  nmin = min(i1,i2,i3)
5184  nmax = max(i1,i2,i3)
5185  nsum = i1 +i2 +i3
5186  IF (nmin.EQ.1.AND.nmax.EQ.5.AND.nsum.EQ.10) np = n1
5187  IF (nmin.EQ.1.AND.nmax.EQ.6.AND.nsum.EQ.9) np = n2
5188  IF (nmin.EQ.2.AND.nmax.EQ.5.AND.nsum.EQ.10) np = n3
5189  IF (nmin.EQ.3.AND.nmax.EQ.6.AND.nsum.EQ.13) np = n4
5190  IF (np.EQ.0.OR.angmx3.LT.120.) go to 110
5191 !
5192 ! A FLAT TETRAHEDRON HAS BEEN FOUND
5193 !
5194  75 IF (np.EQ.n4) go to 80
5195  nn = n1
5196  n1 = n2
5197  n2 = n3
5198  n3 = n4
5199  n4 = nn
5200  go to 75
5201 
5202  80 CALL triswp(n4,n1,n2,n3,j,nfail, &
5203  x,ndc,nbh,iprot,ncell,ndg,idgp,ndgp,nedge, &
5204  vol,xcen,ycen,zcen,rc,rat,nptet,nacpt,tolv)
5205 
5206  IF (nfail.EQ.0) THEN
5207  go to 125
5208  ELSE
5209  go to 128
5210  ENDIF
5211 !
5212 ! A SLIVER HAS BEEN FOUND
5213 !
5214  110 IF (max(angmx1,angmx2).LT.120.) go to 135
5215  npass = 0
5216  i = i1
5217  angmax = angmx1
5218  115 IF (angmax.LT.120.) go to 130
5219  na = n1
5220  nb = n2
5221  m1 = n3
5222  IF (i.EQ.1) go to 120
5223  na = n2
5224  nb = n3
5225  m1 = n4
5226  IF (i.EQ.2) go to 120
5227  na = n3
5228  nb = n4
5229  m1 = n1
5230  IF (i.EQ.3) go to 120
5231  na = n4
5232  nb = n1
5233  m1 = n2
5234  IF (i.EQ.4) go to 120
5235  na = n1
5236  nb = n3
5237  m1 = n4
5238  IF (i.EQ.5) go to 120
5239  na = n2
5240  nb = n4
5241  m1 = n1
5242  120 m2 = n1 +n2 +n3 +n4 -na -nb -m1
5243 
5244  CALL replace(m1,m2,na,nb,j,nring,npass,nfail, &
5245  x,dens,ityp,nnode,ndc,nbh,iprot,ncell, &
5246  ndg,idgp,ndgp,nedge,ipoint,npoint, &
5247  vol,xcen,ycen,zcen,rc,rat,nptet,nacpt, &
5248  noctr,ioctr,nlink,nref,xfar,yfar,zfar, &
5249  iring,ntetkp,lnbr,ishk,mnbr,kshk, &
5250  nfad,nbhkp,iedkp,newc,dx,dy,dz,ds,npp,vlt,tolv)
5251 
5252  IF (nfail.EQ.0) go to 125
5253  IF (npass.EQ.1.OR.nfail.EQ.2) go to 128
5254  npass = 1
5255  i = i2
5256  angmax = angmx2
5257  go to 115
5258  125 nchk = nchk +1
5259  go to 40
5260  128 IF (loop.LE.4) THEN
5261 
5262  CALL putpnt(j,nfail, &
5263  x,ityp,nnode,ndc,nbh,iprot,ncell, &
5264  ndg,idgp,ndgp,nedge, &
5265  vol,xcen,ycen,zcen,rc,rat,dens,nptet,nacpt, &
5266  idone,nref,nlink,noctr,ioctr,xfar,yfar,zfar, &
5267  xoctr,yoctr,zoctr,xhold,yhold,zhold, &
5268  xkeep,ykeep,zkeep,ksrch,nsrch, &
5269  ipoint,npoint,iflag,nflag,nfill,newcel,ntri, &
5270  ncav,nshake,newnbh,nold,ncavfc,ikeep,ldel, &
5271  nedgrm,xc,yc,zc,v,rad,rcrin,lnkup,lnkdn, &
5272  volmin,rcmx,tolv)
5273 
5274  IF (nfail.EQ.0) go to 125
5275  ENDIF
5276  130 l = l +1
5277  IF (l.GT.nwait) go to 135
5278  go to 40
5279  135 CONTINUE
5280  WRITE (6,950) nchk
5281  950 FORMAT(i6,' SLIVERS REMOVED')
5282 !
5283 ! CYCLE THROUGH FIELD POINTS AND TRY ADJUST POINT POSITIONS
5284 ! BY A LAPLACIAN SMOOTHER
5285 !
5286  IF (nchk.EQ.0) go to 145
5287  140 CONTINUE
5288  145 ntet = 0
5289  DO 160 l=1,ncell
5290  IF (iprot(l).EQ.1) go to 160
5291  IF (nbh(1,l).EQ.0) go to 160
5292  ntet = ntet +1
5293  160 CONTINUE
5294  npt = 0
5295  DO 165 n=1,nnode
5296  IF (ityp(n).LT.0) go to 165
5297  npt = npt +1
5298  165 CONTINUE
5299  WRITE (6,600) npt,ntet
5300  RETURN
5301  600 FORMAT(/'MESH OPTIMIZATION COMPLETE'/ &
5302  5x,i7,' MESH POINTS'/ &
5303  5x,i7,' MESH CELLS'/)
5304  610 FORMAT(/'BEGIN MESH OPTIMIZATION')
5305  END SUBROUTINE smooth
5306 
5307 
5308 
5309 
5310 
5311 !
5312 ! ******************************************************************
5313 !
5314  SUBROUTINE replace (N1,N2,NA,NB,J,NRING,NPASS,NFAIL, &
5315  x,dens,ityp,nnode,ndc,nbh,iprot,ncell, &
5316  ndg,idgp,ndgp,nedge,ipoint,npoint, &
5317  vol,xcen,ycen,zcen,rc,rat,nptet,nacpt, &
5318  noctr,ioctr,nlink,nref,xfar,yfar,zfar, &
5319  iring,ntetkp,lnbr,ishk,mnbr,kshk, &
5320  nfad,nbhkp,iedkp,newc,dx,dy,dz,ds,np,vlt,tolv)
5321 !
5322 ! ******************************************************************
5323 ! * *
5324 ! * FIND THE RING OF TETRAHEDRA SURROUNDING EDGE (NA,NB) AND *
5325 ! * CREATE NEW ENSEMBLE OF TETRAHEDRA IN ORDER TO IMPROVE MESH *
5326 ! * QUALITY *
5327 ! * *
5328 ! ******************************************************************
5329 ! ******************************************************************
5330 ! * *
5331 ! * COPYRIGHT (C) TIM BAKER 1994 *
5332 ! * *
5333 ! ******************************************************************
5334 !
5335  IMPLICIT NONE
5336 
5337  INTEGER :: ioctr,j,na,nb,ncell,nedge,nfail,nnode,npass,nring,n1,n2
5338  INTEGER :: ityp(*),npoint(*),ipoint(*),nptet(*),nacpt(*)
5339  INTEGER :: ndc(4,*),nbh(4,*),iprot(*),ndg(2,*),idgp(*),ndgp(*)
5340  INTEGER :: nref(*),nlink(*),noctr(2,*)
5341  INTEGER :: iring(*),ntetkp(*),nfad(3,*),newc(*), &
5342  nbhkp(3,*),iedkp(4,*),lnbr(*),ishk(*), &
5343  mnbr(*),kshk(*),np(*)
5344  DOUBLE PRECISION :: tolv
5345  DOUBLE PRECISION :: x(3,*),dens(*)
5346  DOUBLE PRECISION :: vol(*),xcen(*),ycen(*),zcen(*),rc(*),rat(*)
5347  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2)
5348  DOUBLE PRECISION :: dx(*),dy(*),dz(*),ds(*),vlt(*)
5349 
5350  INTEGER :: i,iedg,ip1,ismall,jnext,jpre,j1,j2,k,kcnt,kend,khalf, &
5351  kk,kmax,kmin,km1,kplus,kplusm,kplusp,kp1,ksum,k1,k2, &
5352  k3,k4,l,loop,l1,l2,m,mend,mmax,mmin,msum,m1,m2,m3,m4, &
5353  m5,n,nedk,npnext,npre,nrngp1
5354  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,radc,radmax,ratmax, &
5355  rcrin,rnx,rny,rnz,vl,vmin,vorig,vtet1,vtet2, &
5356  xcn,ycn,zcn
5357 !
5358 ! ******************************************************************
5359 !
5360  nfail = 0
5361  vorig = vol(j)
5362 !
5363 ! STARTING FROM SLIVER FACE (N1,NA,NB) FIND SEQUENCE OF TETRAHEDRA
5364 ! INCIDENT TO EDGE (NA,NB) UNTIL FACE (N2,NA,NB) IS REACHED
5365 !
5366  nring = 1
5367 
5368  CALL neighb(j,n1,na,nb,jnext,k1,k2,ndc,nbh)
5369 
5370  npnext = ndc(1,jnext) +ndc(2,jnext) +ndc(3,jnext) &
5371  +ndc(4,jnext) -n1 -na -nb
5372  iring(1) = n1
5373  ntetkp(1) = jnext
5374  10 jpre = jnext
5375  npre = npnext
5376 
5377  CALL neighb(jpre,npre,na,nb,jnext,k1,k2,ndc,nbh)
5378 
5379  npnext = ndc(1,jnext) +ndc(2,jnext) +ndc(3,jnext) &
5380  +ndc(4,jnext) -npre -na -nb
5381  nring = nring +1
5382  IF (nring.GT.mxring) go to 310
5383  iring(nring) = npre
5384  ntetkp(nring) = jnext
5385  IF (npnext.EQ.n1) go to 300
5386  IF (npnext.NE.n2) go to 10
5387  nring = nring +1
5388  iring(nring) = n2
5389  ntetkp(nring) = j
5390 !
5391 ! FIND NEIGHBORS OF THE TETRAHEDRAL RING
5392 !
5393  radmax = 0.
5394  ratmax = 0.
5395  DO 20 i=1,nring
5396  IF (iprot(ntetkp(i)).EQ.1) go to 200
5397  radmax = max(radmax,rc(ntetkp(i)))
5398  ratmax = max(ratmax,rat(ntetkp(i)))
5399  ip1 = mod(i,nring) +1
5400 
5401  CALL neighb(ntetkp(i),iring(i),iring(ip1),na,lnbr(i),kk,ishk(i), &
5402  ndc,nbh)
5403 
5404  CALL neighb(ntetkp(i),iring(i),iring(ip1),nb,mnbr(i),kk,kshk(i), &
5405  ndc,nbh)
5406 
5407  20 CONTINUE
5408  khalf = nring -2
5409 
5410  CALL tessel(iring,nring,nfad,nbhkp,iedkp,nedk,0,0, &
5411  x,ipoint,npoint,dx,dy,dz,ds,np)
5412 !
5413 ! CHECK WHETHER TETRAHEDRAL RING FORMS A CONVEX ENSEMBLE
5414 !
5415  DO 30 k=1,khalf
5416  m1 = nfad(1,k)
5417  m2 = nfad(2,k)
5418  m3 = nfad(3,k)
5419 
5420  CALL circum(x,m1,m2,m3,na,xcn,ycn,zcn,vl,radc,ismall,tolv)
5421 
5422  IF (radc.GT.radmax) go to 200
5423  area = tetar2(m1,m2,m3,na,x)
5424  rcrin = radc*area/vl
5425  IF (rcrin.GT.ratmax) go to 200
5426 
5427  CALL circum(x,m1,m2,m3,nb,xcn,ycn,zcn,vl,radc,ismall,tolv)
5428 
5429  IF (radc.GT.radmax) go to 200
5430  area = tetar2(m1,m2,m3,nb,x)
5431  rcrin = radc*area/vl
5432  IF (rcrin.GT.ratmax) go to 200
5433  rnx = cofact(x(2,m1),x(2,m2),x(2,m3),x(3,m1),x(3,m2),x(3,m3))
5434  rny = cofact(x(3,m1),x(3,m2),x(3,m3),x(1,m1),x(1,m2),x(1,m3))
5435  rnz = cofact(x(1,m1),x(1,m2),x(1,m3),x(2,m1),x(2,m2),x(2,m3))
5436  vtet1 = rnx*(x(1,na) -x(1,m1)) +rny*(x(2,na) -x(2,m1)) &
5437  +rnz*(x(3,na) -x(3,m1))
5438  vtet2 = rnx*(x(1,nb) -x(1,m1)) +rny*(x(2,nb) -x(2,m1)) &
5439  +rnz*(x(3,nb) -x(3,m1))
5440  IF (abs(vtet1).LT.vorig.OR.abs(vtet2).LT.vorig) go to 100
5441  IF (vtet1*vtet2.GE.0.0) go to 100
5442  30 CONTINUE
5443  DO 39 loop=1,2
5444  DO 38 k=1,khalf
5445  DO 38 i=1,3
5446  l = nbhkp(i,k)
5447  IF (l.LT.0) go to 38
5448  j2 = lnbr(l)
5449  IF (loop.EQ.2) j2 = mnbr(l)
5450  IF (iprot(j2).EQ.1) go to 38
5451  k1 = nfad(1,k)
5452  k2 = nfad(2,k)
5453  k3 = nfad(3,k)
5454  k4 = na
5455  IF (loop.EQ.2) k4 = nb
5456  kend = k4
5457  m1 = ndc(1,j2)
5458  m2 = ndc(2,j2)
5459  m3 = ndc(3,j2)
5460  m4 = ndc(4,j2)
5461  31 mend = m4
5462  kmin = min(k1,k2,k3)
5463  kmax = max(k1,k2,k3)
5464  ksum = k1 +k2 +k3
5465  32 mmin = min(m1,m2,m3)
5466  mmax = max(m1,m2,m3)
5467  msum = m1 +m2 +m3
5468  IF (mmin.EQ.kmin.AND.mmax.EQ.kmax.AND.msum.EQ.ksum) go to 34
5469  IF (m1.EQ.mend) go to 33
5470  m = m1
5471  m1 = m2
5472  m2 = m3
5473  m3 = m4
5474  m4 = m
5475  go to 32
5476  33 IF (k1.EQ.kend) go to 340
5477  kk = k1
5478  k1 = k2
5479  k2 = k3
5480  k3 = k4
5481  k4 = kk
5482  go to 31
5483  34 m5 = k4
5484  rnx = cofact(x(2,m1),x(2,m2),x(2,m3),x(3,m1),x(3,m2),x(3,m3))
5485  rny = cofact(x(3,m1),x(3,m2),x(3,m3),x(1,m1),x(1,m2),x(1,m3))
5486  rnz = cofact(x(1,m1),x(1,m2),x(1,m3),x(2,m1),x(2,m2),x(2,m3))
5487  vtet1 = rnx*(x(1,m4) -x(1,m1)) +rny*(x(2,m4) -x(2,m1)) &
5488  +rnz*(x(3,m4) -x(3,m1))
5489  vtet2 = rnx*(x(1,m5) -x(1,m1)) +rny*(x(2,m5) -x(2,m1)) &
5490  +rnz*(x(3,m5) -x(3,m1))
5491  IF (vtet1*vtet2.GE.0.) go to 100
5492  38 CONTINUE
5493  39 CONTINUE
5494 !
5495 ! ASSIGN ADDRESSES OF NEW CELLS
5496 !
5497  kcnt = 2*(nring -2)
5498  DO 40 k=1,kcnt
5499  IF (k.GT.nring) go to 35
5500  newc(k) = ntetkp(k)
5501  nacpt(newc(k)) = 1
5502  go to 40
5503  35 ncell = ncell +1
5504  newc(k) = ncell
5505  nacpt(newc(k)) = 1
5506  40 CONTINUE
5507 !
5508 ! ASSIGN ADDRESSES OF NEW NDC ARRAYS
5509 !
5510  DO 60 k=1,khalf
5511  ndc(1,newc(k)) = nfad(1,k)
5512  ndc(2,newc(k)) = nfad(2,k)
5513  ndc(3,newc(k)) = nfad(3,k)
5514  ndc(4,newc(k)) = na
5515  kplus = k +khalf
5516  ndc(1,newc(kplus)) = nfad(1,k)
5517  ndc(2,newc(kplus)) = nfad(2,k)
5518  ndc(3,newc(kplus)) = nfad(3,k)
5519  ndc(4,newc(kplus)) = nb
5520  60 CONTINUE
5521 !
5522 ! UPDATE NBH ARRAY
5523 !
5524  DO 75 k=1,nring
5525  nbh(1,ntetkp(k)) = 0
5526  75 CONTINUE
5527  DO 90 k=1,khalf
5528  kplus = k +khalf
5529  DO 85 i=1,3
5530  l = nbhkp(i,k)
5531  IF (l.GT.0) go to 80
5532  l = -l
5533  nbh(i,newc(k)) = newc(l)
5534  nbh(i,newc(kplus)) = newc(l+khalf)
5535  go to 85
5536  80 nbh(i,newc(k)) = lnbr(l)
5537  nbh(i,newc(kplus)) = mnbr(l)
5538  nbh(ishk(l),lnbr(l)) = newc(k)
5539  nbh(kshk(l),mnbr(l)) = newc(kplus)
5540  85 CONTINUE
5541  nbh(4,newc(k)) = newc(kplus)
5542  nbh(4,newc(kplus)) = newc(k)
5543  90 CONTINUE
5544 !
5545 ! UPDATE NDG ARRAY
5546 !
5547  IF (nring.EQ.nedk) go to 145
5548  nrngp1 = nring +1
5549  DO 96 i=nrngp1,nedk
5550  m1 = iedkp(1,i)
5551  m2 = iedkp(2,i)
5552  l1 = min(m1,m2)
5553  l2 = max(m1,m2)
5554  iedg = idgp(l1)
5555  IF (iedg.EQ.0) go to 94
5556  92 IF (ndgp(iedg).EQ.0) go to 94
5557  iedg = ndgp(iedg)
5558  go to 92
5559  94 nedge = nedge +1
5560  IF (nedge.GT.mxedge) go to 370
5561  ndg(1,nedge) = l1
5562  ndg(2,nedge) = l2
5563  ndgp(nedge) = 0
5564  IF (iedg.EQ.0) idgp(l1) = nedge
5565  IF (iedg.GT.0) ndgp(iedg) = nedge
5566  96 CONTINUE
5567  go to 145
5568 !
5569 ! TETRAHEDRAL ENSEMBLE IS NON-CONVEX. INSERT POINT INSIDE
5570 ! THE ENSEMBLE TO REMOVE SLIVER
5571 !
5572  100 CALL neighb(j,n1,n2,na,j1,k1,k2,ndc,nbh)
5573 
5574  CALL neighb(j,n1,n2,nb,j2,k1,k2,ndc,nbh)
5575 
5576  IF (iprot(j1).EQ.0.AND.iprot(j2).EQ.0.AND.npass.EQ.0) go to 210
5577 
5578  CALL sliver(iring,nring,na,nb,nfail,vorig, &
5579  x,dens,ityp,ipoint,nnode, &
5580  noctr,ioctr,nlink,nref,xfar,yfar,zfar,vlt)
5581 
5582  IF (nfail.NE.0) RETURN
5583 !
5584 ! ASSIGN ADDRESSES OF NEW CELLS
5585 !
5586  kcnt = 2*nring
5587  DO 110 k=1,kcnt
5588  IF (k.GT.nring) go to 105
5589  newc(k) = ntetkp(k)
5590  nacpt(newc(k)) = 1
5591  go to 110
5592  105 ncell = ncell +1
5593  newc(k) = ncell
5594  nacpt(newc(k)) = 1
5595  110 CONTINUE
5596 !
5597 ! ASSIGN ADDRESSES OF NEW NDC ARRAYS
5598 !
5599  DO 120 k=1,nring
5600  kp1 = mod(k,nring) +1
5601  m1 = iring(k)
5602  m2 = iring(kp1)
5603  ndc(1,newc(k)) = m1
5604  ndc(2,newc(k)) = m2
5605  ndc(3,newc(k)) = nnode
5606  ndc(4,newc(k)) = na
5607  iprot(newc(k)) = 0
5608  kplus = k +nring
5609  ndc(1,newc(kplus)) = m1
5610  ndc(2,newc(kplus)) = m2
5611  ndc(3,newc(kplus)) = nnode
5612  ndc(4,newc(kplus)) = nb
5613  iprot(newc(kplus)) = 0
5614  120 CONTINUE
5615 !
5616 ! UPDATE NBH ARRAY
5617 !
5618  DO 125 k=1,nring
5619  nbh(1,ntetkp(k)) = 0
5620  125 CONTINUE
5621  DO 130 k=1,nring
5622  km1 = mod(nring-2+k,nring) +1
5623  kp1 = mod(k,nring) +1
5624  kplus = k +nring
5625  kplusm = km1 +nring
5626  kplusp = kp1 +nring
5627  nbh(1,newc(k)) = newc(km1)
5628  nbh(2,newc(k)) = newc(kp1)
5629  nbh(3,newc(k)) = lnbr(k)
5630  nbh(4,newc(k)) = newc(kplus)
5631  nbh(ishk(k),lnbr(k)) = newc(k)
5632  nbh(1,newc(kplus)) = newc(kplusm)
5633  nbh(2,newc(kplus)) = newc(kplusp)
5634  nbh(3,newc(kplus)) = mnbr(k)
5635  nbh(4,newc(kplus)) = newc(k)
5636  nbh(kshk(k),mnbr(k)) = newc(kplus)
5637  130 CONTINUE
5638 !
5639 ! UPDATE NDG ARRAY
5640 !
5641  DO 136 k=1,nring
5642  iedg = idgp(iring(k))
5643  IF (iedg.EQ.0) go to 134
5644  132 IF (ndgp(iedg).EQ.0) go to 134
5645  iedg = ndgp(iedg)
5646  go to 132
5647  134 nedge = nedge +1
5648  IF (nedge.GT.mxedge) go to 370
5649  ndg(1,nedge) = iring(k)
5650  ndg(2,nedge) = nnode
5651  ndgp(nedge) = 0
5652  IF (iedg.EQ.0) idgp(iring(k)) = nedge
5653  IF (iedg.GT.0) ndgp(iedg) = nedge
5654  136 CONTINUE
5655  iedg = idgp(na)
5656  IF (iedg.EQ.0) go to 140
5657  138 IF (ndgp(iedg).EQ.0) go to 140
5658  iedg = ndgp(iedg)
5659  go to 138
5660  140 nedge = nedge +1
5661  IF (nedge.GT.mxedge) go to 370
5662  ndg(1,nedge) = na
5663  ndg(2,nedge) = nnode
5664  ndgp(nedge) = 0
5665  IF (iedg.EQ.0) idgp(na) = nedge
5666  IF (iedg.GT.0) ndgp(iedg) = nedge
5667  iedg = idgp(nb)
5668  IF (iedg.EQ.0) go to 144
5669  142 IF (ndgp(iedg).EQ.0) go to 144
5670  iedg = ndgp(iedg)
5671  go to 142
5672  144 nedge = nedge +1
5673  IF (nedge.GT.mxedge) go to 370
5674  ndg(1,nedge) = nb
5675  ndg(2,nedge) = nnode
5676  ndgp(nedge) = 0
5677  IF (iedg.EQ.0) idgp(nb) = nedge
5678  IF (iedg.GT.0) ndgp(iedg) = nedge
5679 !
5680 ! REMOVE OLD EDGE JOINING POINTS NA AND NB
5681 !
5682  145 l1 = min(na,nb)
5683  l2 = max(na,nb)
5684  iedg = idgp(l1)
5685  146 IF (l2.EQ.ndg(2,iedg)) go to 148
5686  iedg = ndgp(iedg)
5687  go to 146
5688 
5689  148 CALL edgerm(iedg,ndg,idgp,ndgp)
5690 !
5691 ! COMPUTE VOLUME,CIRCUMCENTER AND CIRCUMRADIUS FOR NEW CELLS
5692 !
5693  DO 150 k=1,kcnt
5694  m1 = ndc(1,newc(k))
5695  m2 = ndc(2,newc(k))
5696  m3 = ndc(3,newc(k))
5697  m4 = ndc(4,newc(k))
5698 
5699  CALL circum(x,m1,m2,m3,m4,xcn,ycn,zcn,vl,radc,ismall,tolv)
5700 
5701  IF (k.EQ.1) vmin = vl
5702  IF (k.GT.1) vmin = min(vmin,vl)
5703 
5704  IF (ismall.EQ.1) WRITE (6,960) k,vl,radc, &
5705  m1,x(1,m1),x(2,m1),x(3,m1), &
5706  m2,x(1,m2),x(2,m2),x(3,m2), &
5707  m3,x(1,m3),x(2,m3),x(3,m3), &
5708  m4,x(1,m4),x(2,m4),x(3,m4)
5709  960 FORMAT('RING ',i2,' VOLUME = ',e13.5,' RC = ',e13.5/ &
5710  'M1 ',i6,' X = ',f6.3,' Y = ',f6.3,' Z = ',f6.3/ &
5711  'M2 ',i6,' X = ',f6.3,' Y = ',f6.3,' Z = ',f6.3/ &
5712  'M3 ',i6,' X = ',f6.3,' Y = ',f6.3,' Z = ',f6.3/ &
5713  'M4 ',i6,' X = ',f6.3,' Y = ',f6.3,' Z = ',f6.3)
5714 
5715  IF (ismall.EQ.1) go to 320
5716  xcen(newc(k)) = xcn
5717  ycen(newc(k)) = ycn
5718  zcen(newc(k)) = zcn
5719  vol(newc(k)) = vl
5720  rc(newc(k)) = radc
5721  area = tetar(newc(k),x,ndc)
5722  rat(newc(k)) = rc(newc(k))*area/vol(newc(k))
5723 ! WRITE (6,961) K,VL,RADC,RAT(NEWC(K))
5724 ! 961 FORMAT('NEW CELLS, K = ',I2,' VOL ',E13.5,
5725 ! . ' RC ',E13.5,' RAT ',E13.5)
5726  150 CONTINUE
5727 
5728 ! WRITE (6,990) VORIG,VMIN
5729 ! 990 FORMAT('VORIG = ',E13.5,' VMIN = ',E13.5)
5730 !
5731 ! UPDATE NPTET ARRAY
5732 !
5733  DO 155 k=1,kcnt
5734  DO 155 i=1,4
5735  n = ndc(i,newc(k))
5736  nptet(n) = newc(k)
5737  155 CONTINUE
5738  RETURN
5739  200 nfail = 1
5740 ! WRITE (6,920)
5741 ! 920 FORMAT('AT LEAST ONE OF THE RING TETRAHEDRA IS PROTECTED')
5742  RETURN
5743  210 nfail = 1
5744 ! WRITE (6,921)
5745 ! 921 FORMAT('NON BODY STICKING SLIVER. TRY OPPOSITE DIRECTION')
5746  RETURN
5747  300 WRITE (6,600)
5748  stop
5749  310 WRITE (6,610)
5750  stop
5751  320 WRITE (6,620)
5752  stop
5753  340 WRITE (6,640)
5754  stop
5755  360 WRITE (6,660)
5756  stop
5757  370 WRITE (6,670)
5758  stop
5759  600 FORMAT(///5x,'SEARCH FOR TETRAHEDRAL RING HAS RETURNED TO THE'/ &
5760  5x,'STARTING FACE. THIS INDICATES AN INCONSISTENCY IN'/ &
5761  5x,'THE TETRAHEDRAL ENSEMBLE.'/ &
5762  5x,'PROGRAM STOPPED IN REPLACE')
5763  610 FORMAT(///5x,'DIMENSION OF ARRAY IRING EXCEEDED. INCREASE SIZE'/ &
5764  5x,'OF MRING. PROGRAM STOPPED IN REPLACE')
5765  620 FORMAT(///5x,'AT LEAST ONE NEW TETRAHEDRON HAS TOO SMALL A VOLUME' &
5766  /5x,'PROGRAM STOPPED IN REPLACE')
5767  640 FORMAT(///5x,'UNABLE TO FIND COMMON FACE BETWEEN ADJACENT CELLS' &
5768  /5x,'PROGRAM STOPPED IN REPLACE')
5769  660 FORMAT(//5x,'UNABLE TO FIND EDGE ADDRESS FOR A NEW TETRAHEDRON'/ &
5770  5x,'PROGRAM STOPPED IN ROUTINE REPLACE')
5771  670 FORMAT(//5x,'DIMENSION OF NDG ARRAY EXCEEDED IN ROUTINE REPLACE.'/ &
5772  5x,'INCREASE SIZE OF MBPTS.')
5773  END SUBROUTINE replace
5774 
5775 
5776 
5777 
5778 
5779 
5780 !
5781 ! ******************************************************************
5782 !
5783  SUBROUTINE triswp (NPT,N1,N2,N3,J,NFAIL, &
5784  x,ndc,nbh,iprot,ncell,ndg,idgp,ndgp,nedge, &
5785  vol,xcen,ycen,zcen,rc,rat,nptet,nacpt,tolv)
5786 !
5787 ! ******************************************************************
5788 ! * *
5789 ! * GIVEN TWO TETRAHEDRA WITH COMMON FACE (N1,N2,N3), REMOVE THIS *
5790 ! * FACE AND INSERT AN EDGE TO CREATE A SET OF THREE TETRAHEDRA. *
5791 ! * *
5792 ! ******************************************************************
5793 ! ******************************************************************
5794 ! * *
5795 ! * COPYRIGHT (C) TIM BAKER 2001 *
5796 ! * *
5797 ! ******************************************************************
5798 !
5799  IMPLICIT NONE
5800 
5801  INTEGER :: j,nedge,nfail,npt,n1,n2,n3
5802  INTEGER :: nptet(*),nacpt(*),ndc(4,*),nbh(4,*),iprot(*),ndg(2,*), &
5803  idgp(*),ndgp(*)
5804  DOUBLE PRECISION :: tolv
5805  DOUBLE PRECISION :: x(3,*),vol(*),xcen(*),ycen(*),zcen(*), &
5806  rc(*),rat(*)
5807 
5808  INTEGER :: i,iedg,im1,ip1,ismall,k,kk,km1,kp1,k1,k2,la,l1,l2, &
5809  m1,m2,m3,m4,na,ncell,nold
5810  INTEGER :: iring(3),newc(3),lnbr(3),ishk(3),mnbr(3),kshk(3)
5811  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,radmax,ratmax,rcrin, &
5812  rnx,rny,rnz,xcn,ycn,zcn,vl,vtet1,vtet2,radc
5813 !
5814 ! ******************************************************************
5815 !
5816  nfail = 0
5817 !
5818 ! FIND NEIGHBORING TETRAHEDRON LA AND OPPOSITE VERTEX NA.
5819 !
5820  CALL neighb(j,n1,n2,n3,la,k1,k2,ndc,nbh)
5821 !
5822  IF (iprot(la).EQ.1) RETURN
5823  na = ndc(1,la) +ndc(2,la) +ndc(3,la) +ndc(4,la) &
5824  -n1 -n2 -n3
5825  iring(1) = n1
5826  iring(2) = n2
5827  iring(3) = n3
5828 !
5829 ! CHECK WHETHER THE TETRAHEDRAL RING FORMS A CONVEX ENSEMBLE
5830 !
5831  radmax = max(rc(j),rc(la))
5832  ratmax = max(rat(j),rat(la))
5833  DO 10 i=1,3
5834  ip1 = mod(i,3) +1
5835  im1 = mod(i+1,3) +1
5836  m1 = iring(i)
5837  m2 = iring(ip1)
5838  m3 = iring(im1)
5839 
5840  CALL circum(x,m1,m2,npt,na,xcn,ycn,zcn,vl,radc,ismall,tolv)
5841 
5842  IF (radc.GT.radmax) go to 300
5843  area = tetar2(m1,m2,npt,na,x)
5844  rcrin = radc*area/vl
5845  IF (rcrin.GT.ratmax) go to 300
5846  rnx = cofact(x(2,m1),x(2,m2),x(2,na),x(3,m1),x(3,m2),x(3,na))
5847  rny = cofact(x(3,m1),x(3,m2),x(3,na),x(1,m1),x(1,m2),x(1,na))
5848  rnz = cofact(x(1,m1),x(1,m2),x(1,na),x(2,m1),x(2,m2),x(2,na))
5849  vtet1 = rnx*(x(1,m3) -x(1,m1)) +rny*(x(2,m3) -x(2,m1)) &
5850  +rnz*(x(3,m3) -x(3,m1))
5851  vtet2 = rnx*(x(1,npt) -x(1,m1)) +rny*(x(2,npt) -x(2,m1)) &
5852  +rnz*(x(3,npt) -x(3,m1))
5853  IF (vtet1*vtet2.LT.0) go to 310
5854  IF (abs(vtet1).LT.10.*tolv) go to 310
5855  IF (abs(vtet2).LT.10.*tolv) go to 310
5856  10 CONTINUE
5857 !
5858 ! FIND THE SIX NEIGHBORING TETRAHEDRA LNBR(K),MNBR(K), K=1,3
5859 !
5860  DO 20 k=1,3
5861  kp1 = mod(k,3) +1
5862 
5863  CALL neighb(j,iring(k),iring(kp1),npt,lnbr(k),kk,ishk(k),ndc,nbh)
5864 
5865  CALL neighb(la,iring(k),iring(kp1),na,mnbr(k),kk,kshk(k),ndc,nbh)
5866 
5867  20 CONTINUE
5868 !
5869 ! ASSIGN ADDRESSES OF NEW CELLS
5870 !
5871  newc(1) = j
5872  newc(2) = la
5873  ncell = ncell +1
5874  IF (ncell.GT.mxcell) go to 360
5875  newc(3) = ncell
5876 !
5877 ! CREATE NDC ARRAY FOR NEW CELLS
5878 !
5879  DO 30 k=1,3
5880  kp1 = mod(k,3) +1
5881  ndc(1,newc(k)) = npt
5882  ndc(2,newc(k)) = iring(k)
5883  ndc(3,newc(k)) = iring(kp1)
5884  ndc(4,newc(k)) = na
5885  nacpt(newc(k)) = 1
5886  iprot(newc(k)) = 0
5887  30 CONTINUE
5888 !
5889 ! COMPUTE VOLUME,CIRCUMCENTER AND CIRCUMRADIUS FOR NEW CELLS
5890 !
5891  DO 40 k=1,3
5892  m1 = ndc(1,newc(k))
5893  m2 = ndc(2,newc(k))
5894  m3 = ndc(3,newc(k))
5895  m4 = ndc(4,newc(k))
5896 
5897  CALL circum(x,m1,m2,m3,m4,xcn,ycn,zcn,vl,radc,ismall,tolv)
5898 
5899 
5900  IF (ismall.EQ.1) WRITE (6,910) npt,na,(iring(kk),kk=1,3)
5901  910 FORMAT('NPT ',i6,' NA ',i6,' IRING ',4i6)
5902  IF (ismall.EQ.1) WRITE (6,960) k,vl, &
5903  m1,x(1,m1),x(2,m1),x(3,m1), &
5904  m2,x(1,m2),x(2,m2),x(3,m2), &
5905  m3,x(1,m3),x(2,m3),x(3,m3), &
5906  m4,x(1,m4),x(2,m4),x(3,m4)
5907  960 FORMAT('RING ',i2,' VOLUME = ',e13.5/ &
5908  'M1 ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4/ &
5909  'M2 ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4/ &
5910  'M3 ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4/ &
5911  'M4 ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4)
5912 
5913  IF (ismall.EQ.1) go to 350
5914  xcen(newc(k)) = xcn
5915  ycen(newc(k)) = ycn
5916  zcen(newc(k)) = zcn
5917  vol(newc(k)) = vl
5918  rc(newc(k)) = radc
5919  area = tetar(newc(k),x,ndc)
5920  rat(newc(k)) = rc(newc(k))*area/vol(newc(k))
5921  40 CONTINUE
5922 !
5923 ! UPDATE NBH ARRAY
5924 !
5925  DO 50 k=1,3
5926  km1 = mod(k+1,3) +1
5927  kp1 = mod(k,3) +1
5928  nbh(ishk(k),lnbr(k)) = newc(k)
5929  nbh(kshk(k),mnbr(k)) = newc(k)
5930  nbh(1,newc(k)) = newc(km1)
5931  nbh(2,newc(k)) = newc(kp1)
5932  nbh(3,newc(k)) = lnbr(k)
5933  nbh(4,newc(k)) = mnbr(k)
5934  50 CONTINUE
5935 !
5936 ! INSERT NEW EDGE
5937 !
5938  l1 = min(npt,na)
5939  l2 = max(npt,na)
5940  iedg = idgp(l1)
5941  IF (iedg.EQ.0) go to 60
5942  55 IF (ndgp(iedg).EQ.0) go to 60
5943  iedg = ndgp(iedg)
5944  go to 55
5945  60 nedge = nedge +1
5946  IF (nedge.GT.mxedge) go to 330
5947  ndg(1,nedge) = l1
5948  ndg(2,nedge) = l2
5949  ndgp(nedge) = 0
5950  IF (iedg.EQ.0) idgp(l1) = nedge
5951  IF (iedg.GT.0) ndgp(iedg) = nedge
5952 !
5953 ! UPDATE NPTET ARRAY
5954 !
5955  nptet(npt) = newc(1)
5956  nptet(na) = newc(1)
5957  DO 80 k=1,3
5958  nptet(iring(k)) = newc(k)
5959  80 CONTINUE
5960  RETURN
5961  300 nfail = 1
5962 ! WRITE (6,600)
5963  RETURN
5964  310 nfail = 1
5965 ! WRITE (6,610)
5966  RETURN
5967  320 WRITE (6,620) nold,l1,l2,npt,na
5968  stop
5969  330 WRITE (6,630)
5970  stop
5971  350 WRITE (6,650)
5972  stop
5973  360 WRITE (6,660)
5974  stop
5975  600 FORMAT(5x,'A NEW TETRAHEDRON IS WORSE THAN AN EXISTING ONE')
5976  610 FORMAT(5x,'TETRAHEDRAL RING IS NON-CONVEX')
5977  620 FORMAT(///5x,'EDGE TO BE INSERTED ALREADY EXISTS'/ &
5978  5x,'EDGE ',i6,' VERTICES ',2i6,' NPT ',i6,' NA ',i6/ &
5979  //5x,'PROGRAM STOPPED IN TRISWP')
5980  630 FORMAT(///5x,'DIMENSION OF ARRAY NDG EXCEEDED IN ROUTINE TRISWP.'/ &
5981  //5x,'INCREASE SIZE OF MNODE.'/ &
5982  //5x,'PROGRAM STOPPED IN TRISWP')
5983  650 FORMAT(///5x,'AT LEAST ONE OF THE NEW TETRAHEDRA HAS TOO'/ &
5984  5x,'SMALL A VOLUME.'/ &
5985  //5x,'PROGRAM STOPPED IN TRISWP')
5986  660 FORMAT(///5x,'DIMENSION OF ARRAY NDC EXCEEDS ALLOWED VALUE.'/ &
5987  //5x,'INCREASE SIZE OF MCELL.'/ &
5988  //5x,'PROGRAM STOPPED IN TRISWP')
5989  END SUBROUTINE triswp
5990 
5991 
5992 
5993 
5994 
5995 
5996 !
5997 ! ******************************************************************
5998 !
5999  SUBROUTINE tessel (IRING,NRING,NFAD,NBHKP,IEDKP,NEDK,IMEET,ITOUCH, &
6000  x,ipoint,npoint,dx,dy,dz,ds,np)
6001 !
6002 ! ******************************************************************
6003 ! * *
6004 ! * CREATE FACET TRIANGULATION OF THE DOMAIN INSIDE THE RING *
6005 ! * *
6006 ! ******************************************************************
6007 ! ******************************************************************
6008 ! * *
6009 ! * COPYRIGHT (C) TIM BAKER 1994 *
6010 ! * *
6011 ! ******************************************************************
6012 !
6013  IMPLICIT NONE
6014 
6015  INTEGER :: imeet,itouch,nedk,nring
6016  INTEGER :: npoint(*),ipoint(*)
6017  INTEGER :: iring(*),nfad(3,*),nbhkp(3,*),iedkp(4,*),np(*)
6018  DOUBLE PRECISION :: x(3,*)
6019  DOUBLE PRECISION :: dx(*),dy(*),dz(*),ds(*)
6020 
6021  INTEGER :: i,ia,ib,imin,imin1,im1,ip1,k,kpre,l,la,lb,ncnt,nedtot, &
6022  nswit,num
6023 !
6024 ! ******************************************************************
6025 !
6026 ! LOAD RING EDGES INTO EDGE DATA STRUCTURE
6027 !
6028  nedtot = 2*nring -3
6029  DO 2 i=1,nedtot
6030  npoint(i) = 0
6031  2 CONTINUE
6032  DO 4 i=1,nring
6033  ipoint(iring(i)) = 0
6034  np(i) = iring(i)
6035  4 CONTINUE
6036  DO 10 i=1,nring
6037  ip1 = mod(i,nring) +1
6038  ia = min(iring(i),iring(ip1))
6039  ib = max(iring(i),iring(ip1))
6040  iedkp(1,i) = ia
6041  iedkp(2,i) = ib
6042  iedkp(3,i) = i
6043  iedkp(4,i) = 0
6044  k = ipoint(ia)
6045  6 IF (k.EQ.0) go to 8
6046  kpre = k
6047  k = npoint(kpre)
6048  go to 6
6049  8 IF (ipoint(ia).NE.0) npoint(kpre) = i
6050  IF (ipoint(ia).EQ.0) ipoint(ia) = i
6051  npoint(i) = 0
6052  10 CONTINUE
6053  nedk = nring
6054  num = nring
6055 !
6056 ! ITERATE TO CREATE TRIANGULATION OF RING INTERIOR
6057 !
6058  nswit = 0
6059  20 IF (num.EQ.3) go to 60
6060 
6061  CALL angfnd(num,iring,imin,imeet,itouch,x,dx,dy,dz,ds)
6062 
6063  im1 = mod(num+imin-2,num) +1
6064  ip1 = mod(imin,num) +1
6065  nswit = nswit +1
6066  nfad(1,nswit) = iring(imin)
6067  nfad(2,nswit) = iring(ip1)
6068  nfad(3,nswit) = iring(im1)
6069  nedk = nedk +1
6070  ia = min(iring(im1),iring(ip1))
6071  ib = max(iring(im1),iring(ip1))
6072  iedkp(1,nedk) = ia
6073  iedkp(2,nedk) = ib
6074  iedkp(3,nedk) = -nswit
6075  iedkp(4,nedk) = 0
6076  k = ipoint(ia)
6077  22 IF (k.EQ.0) go to 24
6078  kpre = k
6079  k = npoint(kpre)
6080  go to 22
6081  24 IF (ipoint(ia).NE.0) npoint(kpre) = nedk
6082  IF (ipoint(ia).EQ.0) ipoint(ia) = nedk
6083  ia = min(iring(im1),iring(imin))
6084  ib = max(iring(im1),iring(imin))
6085  k = ipoint(ia)
6086  25 IF (ib.EQ.iedkp(2,k)) go to 30
6087  k = npoint(k)
6088  IF (k.EQ.0) go to 330
6089  go to 25
6090  30 iedkp(4,k) = -nswit
6091  ia = min(iring(ip1),iring(imin))
6092  ib = max(iring(ip1),iring(imin))
6093  k = ipoint(ia)
6094  35 IF (ib.EQ.iedkp(2,k)) go to 40
6095  k = npoint(k)
6096  IF (k.EQ.0) go to 340
6097  go to 35
6098  40 iedkp(4,k) = -nswit
6099  ncnt = 0
6100  DO 50 i=1,num
6101  IF (i.EQ.imin) go to 50
6102  ncnt = ncnt +1
6103  iring(ncnt) = iring(i)
6104  50 CONTINUE
6105  num = ncnt
6106  go to 20
6107 !
6108 ! ONLY ONE TRIANGLE REMAINING
6109 !
6110  60 nswit = nswit +1
6111  IF (nswit.NE.nring-2) go to 320
6112  nfad(1,nswit) = iring(1)
6113  nfad(2,nswit) = iring(2)
6114  nfad(3,nswit) = iring(3)
6115  ia = min(iring(1),iring(2))
6116  ib = max(iring(1),iring(2))
6117  k = ipoint(ia)
6118  65 IF (ib.EQ.iedkp(2,k)) go to 70
6119  k = npoint(k)
6120  go to 65
6121  70 iedkp(4,k) = -nswit
6122  ia = min(iring(2),iring(3))
6123  ib = max(iring(2),iring(3))
6124  k = ipoint(ia)
6125  75 IF (ib.EQ.iedkp(2,k)) go to 80
6126  k = npoint(k)
6127  go to 75
6128  80 iedkp(4,k) = -nswit
6129  ia = min(iring(3),iring(1))
6130  ib = max(iring(3),iring(1))
6131  k = ipoint(ia)
6132  85 IF (ib.EQ.iedkp(2,k)) go to 90
6133  k = npoint(k)
6134  go to 85
6135  90 iedkp(4,k) = -nswit
6136 !
6137 ! ASSEMBLE ADJACENCY INFORMATION FOR RING TRIANGLES
6138 !
6139  DO 100 i=1,nring
6140  ipoint(np(i)) = 0
6141  iring(i) = np(i)
6142  100 CONTINUE
6143  DO 110 k=1,nedk
6144  npoint(k) = 0
6145  110 CONTINUE
6146  DO 120 k=1,nedk
6147  la = iabs(iedkp(3,k))
6148  lb = iabs(iedkp(4,k))
6149  IF (la.EQ.0.OR.lb.EQ.0) go to 300
6150  npoint(lb) = npoint(lb) +1
6151  nbhkp(npoint(lb),lb) = iedkp(3,k)
6152  IF (iedkp(3,k).GT.0) go to 120
6153  npoint(la) = npoint(la) +1
6154  nbhkp(npoint(la),la) = iedkp(4,k)
6155  120 CONTINUE
6156  DO 125 l=1,nswit
6157  IF (npoint(l).NE.3) go to 310
6158  npoint(l) = 0
6159  125 CONTINUE
6160  RETURN
6161  300 WRITE (6,600) la,lb
6162  stop
6163  310 WRITE (6,610)
6164  stop
6165  320 WRITE (6,620) nring,nswit
6166  stop
6167  330 WRITE (6,630) ia,ib
6168  stop
6169  340 WRITE (6,640) ia,ib
6170  stop
6171  600 FORMAT(/5x,'A ZERO ADDRESS HAS BEEN FOUND FOR A TRIANGLE', &
6172  5x,'ADDRESSES ARE ',i6,' AND ',i6, &
6173  5x,'PROGRAM STOPPED IN ROUTINE TESSEL')
6174  610 FORMAT(/5x,'INCORRECT ASSEMBLY OF TRIANGLES', &
6175  5x,'PROGRAM STOPPED IN ROUTINE TESSEL')
6176  620 FORMAT(/5x,'NRING IS NOT EQUAL TO NSWIT PLUS TWO', &
6177  5x,'NRING = ',i3,' NSWIT = ',i3, &
6178  5x,'PROGRAM STOPPED IN ROUTINE TESSEL')
6179  630 FORMAT(/5x,'EDGE WITH ZERO ADDRESS FOUND AFTER LABEL 25', &
6180  5x,'IA = ',i6,' IB = ',i6, &
6181  5x,'PROGRAM STOPPED IN ROUTINE TESSEL')
6182  640 FORMAT(/5x,'EDGE WITH ZERO ADDRESS FOUND AFTER LABEL 35', &
6183  5x,'IA = ',i6,' IB = ',i6, &
6184  5x,'PROGRAM STOPPED IN ROUTINE TESSEL')
6185  END SUBROUTINE tessel
6186 
6187 
6188 
6189 
6190 
6191 
6192 
6193 
6194 !
6195 ! ******************************************************************
6196 !
6197  SUBROUTINE angfnd (NUM,IRING,IMIN,IMEET,ITOUCH,X,DX,DY,DZ,DS)
6198 !
6199 ! ******************************************************************
6200 ! * *
6201 ! * SEARCH THROUGH RING OF ADJACENT EDGES TO FIND VERTEX WHICH *
6202 ! * HAS THE SMALLEST INTERIOR ANGLE *
6203 ! * *
6204 ! ******************************************************************
6205 ! ******************************************************************
6206 ! * *
6207 ! * COPYRIGHT (C) TIM BAKER 1994 *
6208 ! * *
6209 ! ******************************************************************
6210 !
6211  IMPLICIT NONE
6212 
6213  INTEGER :: imeet,imin,itouch,num
6214  INTEGER :: iring(*)
6215  DOUBLE PRECISION :: x(3,*)
6216  DOUBLE PRECISION :: dx(*),dy(*),dz(*),ds(*)
6217 
6218  INTEGER :: i,im1,ip1
6219  DOUBLE PRECISION :: ang,angmin,beta,cang,det,div,ds1sq,ds2sq,fac, &
6220  fact1,fact2,gamma,pi,prod,rnx,rpx,rny,rpy, &
6221  rnz,rpz,sang,sum
6222 !
6223 ! ******************************************************************
6224 !
6225  pi = 4*atan(1.)
6226  sum = 0.
6227  imin = 0
6228  DO 10 i=1,num
6229  im1 = mod(num+i-2,num) +1
6230  dx(i) = x(1,iring(im1)) -x(1,iring(i))
6231  dy(i) = x(2,iring(im1)) -x(2,iring(i))
6232  dz(i) = x(3,iring(im1)) -x(3,iring(i))
6233  ds(i) = 1./sqrt(dx(i)*dx(i) +dy(i)*dy(i) +dz(i)*dz(i))
6234  10 CONTINUE
6235  rpx = 0.
6236  rpy = 0.
6237  rpz = 0.
6238  DO 20 i=1,num
6239  ip1 = mod(i,num) +1
6240  fac = ds(i)*ds(ip1)
6241  rpx = rpx -fac*(dy(ip1)*dz(i) -dy(i)*dz(ip1))
6242  rpy = rpy -fac*(dz(ip1)*dx(i) -dz(i)*dx(ip1))
6243  rpz = rpz -fac*(dx(ip1)*dy(i) -dx(i)*dy(ip1))
6244  20 CONTINUE
6245  fac = 1./sqrt(rpx*rpx +rpy*rpy +rpz*rpz)
6246  rpx = fac*rpx
6247  rpy = fac*rpy
6248  rpz = fac*rpz
6249  DO 30 i=1,num
6250  ip1 = mod(i,num) +1
6251  im1 = mod(num+i-2,num) +1
6252  prod = -dx(i)*dx(ip1) -dy(i)*dy(ip1) -dz(i)*dz(ip1)
6253  fact1 = ds(i)*ds(ip1) -prod
6254  fact2 = ds(i)*ds(ip1) +prod
6255  det = 1./(fact1*fact2)
6256  ds1sq = ds(i)*ds(i)
6257  ds2sq = ds(ip1)*ds(ip1)
6258  beta = ds2sq*(rpx*dx(i) +rpy*dy(i) +rpz*dz(i)) &
6259  +prod*(rpx*dx(ip1) +rpy*dy(ip1) +rpz*dz(ip1))*det
6260  gamma = ds1sq*(rpx*dx(ip1) +rpy*dy(ip1) +rpz*dz(ip1)) &
6261  +prod*(rpx*dx(i) +rpy*dy(i) +rpz*dz(i))*det
6262  rnx = rpx -beta*dx(i) -gamma*dx(ip1)
6263  rny = rpy -beta*dy(i) -gamma*dy(ip1)
6264  rnz = rpz -beta*dz(i) -gamma*dz(ip1)
6265  fac = 1./sqrt(rnx*rnx +rny*rny +rnz*rnz)
6266  rnx = fac*rnx
6267  rny = fac*rny
6268  rnz = fac*rnz
6269  div = ds(i)*ds(ip1)
6270  cang = div*prod
6271  sang = -div*((dy(ip1)*dz(i) -dy(i)*dz(ip1))*rnx &
6272  +(dz(ip1)*dx(i) -dz(i)*dx(ip1))*rny &
6273  +(dx(ip1)*dy(i) -dx(i)*dy(ip1))*rnz)
6274  ang = atan2(sang,cang)
6275  IF (ang.LT.0.) ang = ang +2.*pi
6276  IF (imin.EQ.0) go to 25
6277  IF (ang.GT.angmin) go to 30
6278  IF (iring(i).EQ.imeet.AND.iring(im1).EQ.itouch) go to 25
6279  IF (iring(i).EQ.imeet.AND.iring(ip1).EQ.itouch) go to 25
6280  IF (iring(i).EQ.itouch.AND.iring(im1).EQ.imeet) go to 25
6281  IF (iring(i).EQ.itouch.AND.iring(ip1).EQ.imeet) go to 25
6282  IF (iring(i).EQ.imeet.OR.iring(i).EQ.itouch) go to 30
6283  25 angmin = ang
6284  imin = i
6285  30 CONTINUE
6286  RETURN
6287  END SUBROUTINE angfnd
6288 
6289 
6290 
6291 
6292 
6293 
6294 !
6295 ! ******************************************************************
6296 !
6297  SUBROUTINE sliver (IRING,NRING,NA,NB,NFAIL,VORIG, &
6298  x,dens,ityp,ipoint,nnode, &
6299  noctr,ioctr,nlink,nref,xfar,yfar,zfar,vlt)
6300 !
6301 ! ******************************************************************
6302 ! * *
6303 ! * INSERT A POINT INSIDE TETRAHEDRAL RING IN ORDER TO REMOVE *
6304 ! * SLIVER *
6305 ! * *
6306 ! ******************************************************************
6307 ! ******************************************************************
6308 ! * *
6309 ! * COPYRIGHT (C) TIM BAKER 1994 *
6310 ! * *
6311 ! ******************************************************************
6312 !
6313  IMPLICIT NONE
6314 
6315  INTEGER :: ioctr,na,nb,nfail,nnode,nring
6316  INTEGER :: ipoint(*),iring(*),ityp(*),nref(*),nlink(*),noctr(2,*)
6317  DOUBLE PRECISION :: vorig
6318  DOUBLE PRECISION :: x(3,*),dens(*)
6319  DOUBLE PRECISION :: xfar(2),yfar(2),zfar(2),vlt(*)
6320 
6321  INTEGER :: i,im1,m1,m2,n,ncnt,ncyc,nrm1
6322  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,densum,fac,rnx,rny,rnz,tol, &
6323  vtet1,vtet2,xpt,ypt,zpt
6324 !
6325 ! ******************************************************************
6326 !
6327  tol = 1.e-15
6328  xpt = 0.
6329  ypt = 0.
6330  zpt = 0.
6331  densum = 0.
6332  nrm1 = nring -1
6333  DO 10 i=2,nrm1
6334  xpt = xpt +x(1,iring(i))
6335  ypt = ypt +x(2,iring(i))
6336  zpt = zpt +x(3,iring(i))
6337  densum = densum +dens(iring(i))
6338  10 CONTINUE
6339  fac = 1./float(nring-2)
6340  xpt = .5*fac*xpt +.25*(x(1,na) +x(1,nb))
6341  ypt = .5*fac*ypt +.25*(x(2,na) +x(2,nb))
6342  zpt = .5*fac*zpt +.25*(x(3,na) +x(3,nb))
6343  densum = .5*fac*densum +.25*(dens(na) +dens(nb))
6344  ncyc = 0
6345  12 ncnt = 0
6346  DO 20 i=1,nring
6347  im1 = mod(nring-2+i,nring) +1
6348  m1 = iring(i)
6349  m2 = iring(im1)
6350  rnx = cofact(x(2,m1),x(2,m2),x(2,na),x(3,m1),x(3,m2),x(3,na))
6351  rny = cofact(x(3,m1),x(3,m2),x(3,na),x(1,m1),x(1,m2),x(1,na))
6352  rnz = cofact(x(1,m1),x(1,m2),x(1,na),x(2,m1),x(2,m2),x(2,na))
6353  vtet2 = rnx*(xpt -x(1,m1)) +rny*(ypt -x(2,m1)) &
6354  +rnz*(zpt -x(3,m1))
6355  ncnt = ncnt +1
6356  vlt(ncnt) = vtet2
6357  IF (abs(vtet2).LT.vorig) go to 210
6358  IF (i.EQ.1) go to 15
6359  IF (vtet1*vtet2.LE.tol) go to 100
6360  go to 20
6361  15 vtet1 = vtet2
6362  20 CONTINUE
6363  DO 30 i=1,nring
6364  im1 = mod(nring-2+i,nring) +1
6365  m1 = iring(i)
6366  m2 = iring(im1)
6367  rnx = cofact(x(2,m1),x(2,m2),x(2,nb),x(3,m1),x(3,m2),x(3,nb))
6368  rny = cofact(x(3,m1),x(3,m2),x(3,nb),x(1,m1),x(1,m2),x(1,nb))
6369  rnz = cofact(x(1,m1),x(1,m2),x(1,nb),x(2,m1),x(2,m2),x(2,nb))
6370  vtet2 = rnx*(xpt -x(1,m1)) +rny*(ypt -x(2,m1)) &
6371  +rnz*(zpt -x(3,m1))
6372  ncnt = ncnt +1
6373  vlt(ncnt) = vtet2
6374  IF (abs(vtet2).LT.vorig) go to 210
6375  IF (vtet1*vtet2.GE.tol) go to 100
6376  30 CONTINUE
6377  nnode = nnode +1
6378  IF (nnode.GT.mxnode) go to 230
6379  n = nnode
6380  x(1,n) = xpt
6381  x(2,n) = ypt
6382  x(3,n) = zpt
6383  dens(n) = densum
6384  ityp(n) = 8
6385  ipoint(n) = 0
6386 
6387  CALL octfil(n,x,noctr,ioctr,nlink,nref,xfar,yfar,zfar)
6388 
6389  RETURN
6390  100 IF (ncyc.EQ.2) go to 200
6391  ncyc = ncyc +1
6392  xpt = .5*xpt +.25*(x(1,na) +x(1,nb))
6393  ypt = .5*ypt +.25*(x(2,na) +x(2,nb))
6394  zpt = .5*zpt +.25*(x(3,na) +x(3,nb))
6395  densum = .5*densum +.25*(dens(na) +dens(nb))
6396  go to 12
6397  200 nfail = 2
6398 ! WRITE (6,600)
6399  RETURN
6400  210 nfail = 2
6401 ! WRITE (6,610) VORIG,VTET2
6402  RETURN
6403  230 WRITE (6,630)
6404  stop
6405  600 FORMAT(//'POINT TO BE INSERTED LIES OUTSIDE TETRAHEDRAL RING')
6406  610 FORMAT(//'A NEW TETRAHEDRON IS TOO SMALL'/ &
6407  'VORIG = ',e13.5,' VTET = ',e13.5)
6408  630 FORMAT(//5x,'NNODE EXCEEDS DIMENSION OF ARRAY X.'/ &
6409  5x,'INCREASE SIZE OF MNODE.'/ &
6410  5x,'PROGRAM STOPPED IN ROUTINE SLIVER')
6411  END SUBROUTINE sliver
6412 
6413 
6414 
6415 
6416 
6417 
6418 !
6419 ! ******************************************************************
6420 !
6421  SUBROUTINE circum (X,N1,N2,N3,N4,XCN,YCN,ZCN,VTET,RCIR,IFLAG,TOL)
6422 !
6423 ! ******************************************************************
6424 ! * *
6425 ! * FIND VOLUME, CIRCUMRADIUS AND CIRCUMCENTER COORDINATES OF *
6426 ! * TETRAHEDRON (N1,N2,N3,N4). *
6427 ! * IFLAG = 0 FOR IF VOLUME EXCEEDS THRESHOLD. *
6428 ! * IFLAG = 1 IF VOLUME IS TOO SMALL. *
6429 ! * *
6430 ! ******************************************************************
6431 ! ******************************************************************
6432 ! * *
6433 ! * COPYRIGHT (C) TIM BAKER 1994 *
6434 ! * *
6435 ! ******************************************************************
6436 !
6437  IMPLICIT NONE
6438 
6439  INTEGER :: iflag,n1,n2,n3,n4
6440  DOUBLE PRECISION :: xcn,ycn,zcn,vtet,rcir,tol
6441  DOUBLE PRECISION :: x(3,*)
6442 
6443  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,c5,c6,c9,det,fac,h1,h2,h3, &
6444  rnx,rny,rnz,vcell,xshf,yshf,zshf
6445 !
6446 ! ******************************************************************
6447 !
6448  iflag = 0
6449 !
6450 ! COMPUTE VOLUME OF TETRAHEDRON
6451 !
6452  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
6453  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
6454  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
6455  det = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
6456  +rnz*(x(3,n4) -x(3,n1))
6457  vtet = abs(det)
6458 !
6459 ! COMPUTE CIRCUMCENTER COORDINATES
6460 !
6461  rcir = 1.e10
6462  IF (vtet.LT.tol) go to 30
6463  fac = .5/det
6464  xshf = .5*(x(1,n1) +x(1,n2) +x(1,n3) +x(1,n4))
6465  yshf = .5*(x(2,n1) +x(2,n2) +x(2,n3) +x(2,n4))
6466  zshf = .5*(x(3,n1) +x(3,n2) +x(3,n3) +x(3,n4))
6467  h1 = (x(1,n4) -x(1,n1))*(x(1,n4) -xshf +x(1,n1)) &
6468  +(x(2,n4) -x(2,n1))*(x(2,n4) -yshf +x(2,n1)) &
6469  +(x(3,n4) -x(3,n1))*(x(3,n4) -zshf +x(3,n1))
6470  h2 = (x(1,n3) -x(1,n1))*(x(1,n3) -xshf +x(1,n1)) &
6471  +(x(2,n3) -x(2,n1))*(x(2,n3) -yshf +x(2,n1)) &
6472  +(x(3,n3) -x(3,n1))*(x(3,n3) -zshf +x(3,n1))
6473  h3 = (x(1,n2) -x(1,n1))*(x(1,n2) -xshf +x(1,n1)) &
6474  +(x(2,n2) -x(2,n1))*(x(2,n2) -yshf +x(2,n1)) &
6475  +(x(3,n2) -x(3,n1))*(x(3,n2) -zshf +x(3,n1))
6476  c5 = h2*(x(3,n2) -x(3,n1)) -h3*(x(3,n3) -x(3,n1))
6477  c6 = h2*(x(2,n2) -x(2,n1)) -h3*(x(2,n3) -x(2,n1))
6478  c9 = h3*(x(1,n3) -x(1,n1)) -h2*(x(1,n2) -x(1,n1))
6479  xcn = .5*xshf +(h1*rnx +(x(2,n4) -x(2,n1))*c5 &
6480  -(x(3,n4) -x(3,n1))*c6)*fac
6481  ycn = .5*yshf +(-(x(1,n4) -x(1,n1))*c5 +h1*rny &
6482  -(x(3,n4) -x(3,n1))*c9)*fac
6483  zcn = .5*zshf +((x(1,n4) -x(1,n1))*c6 &
6484  +(x(2,n4) -x(2,n1))*c9 +h1*rnz)*fac
6485 !
6486 ! COMPUTE CIRCUMRADIUS
6487 !
6488  rcir = sqrt((x(1,n1) -xcn)**2 +(x(2,n1) -ycn)**2 &
6489  +(x(3,n1) -zcn)**2)
6490  RETURN
6491  30 vcell = vtet/6.
6492 ! WRITE (6,600) VCELL
6493  iflag = 1
6494  RETURN
6495  600 FORMAT(//5x,'TETRAHEDRON WITH AN EXTREMELY SMALL VOLUME FOUND'// &
6496  ' IN ROUTINE CIRCUM'//5x,'VOLUME = ',e13.5/)
6497  END SUBROUTINE circum
6498 
6499 
6500 
6501 
6502 
6503 
6504 !
6505 ! ******************************************************************
6506 !
6507  SUBROUTINE circum2 (X,N1,N2,N3,XPT,YPT,ZPT, &
6508  xcn,ycn,zcn,vtet,rcir,iflag,tol)
6509 !
6510 ! ******************************************************************
6511 ! * *
6512 ! * FIND VOLUME, CIRCUMRADIUS AND CIRCUMCENTER COORDINATES OF *
6513 ! * TETRAHEDRON WHOSE BASE HAS THE VERTEX ADDRESSES N1,N2,N3 AND *
6514 ! * WHOSE FOURTH VERTEX IS THE POINT (XPT,YPT,ZPT). *
6515 ! * IFLAG = 0 FOR IF VOLUME EXCEEDS THRESHOLD. *
6516 ! * IFLAG = 1 IF VOLUME IS TOO SMALL. *
6517 ! * *
6518 ! ******************************************************************
6519 ! ******************************************************************
6520 ! * *
6521 ! * COPYRIGHT (C) TIM BAKER 1994 *
6522 ! * *
6523 ! ******************************************************************
6524 !
6525  IMPLICIT NONE
6526 
6527  INTEGER :: n1,n2,n3
6528  DOUBLE PRECISION :: xcn,xpt,ycn,ypt,zcn,zpt,vtet,rcir,tol
6529  DOUBLE PRECISION :: x(3,*)
6530 
6531  INTEGER :: iflag
6532  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,c5,c6,c9,det,fac,h1,h2,h3, &
6533  rnx,rny,rnz,vcell,xshf,yshf,zshf
6534 !
6535 ! ******************************************************************
6536 !
6537  iflag = 0
6538 !
6539 ! COMPUTE VOLUME OF TETRAHEDRON
6540 !
6541  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
6542  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
6543  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
6544  det = rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
6545  +rnz*(zpt -x(3,n1))
6546  vtet = abs(det)
6547 !
6548 ! COMPUTE CIRCUMCENTER COORDINATES
6549 !
6550  rcir = 1.e10
6551  IF (vtet.LT.tol) go to 30
6552  fac = .5/det
6553  xshf = .5*(x(1,n1) +x(1,n2) +x(1,n3) +xpt)
6554  yshf = .5*(x(2,n1) +x(2,n2) +x(2,n3) +ypt)
6555  zshf = .5*(x(3,n1) +x(3,n2) +x(3,n3) +zpt)
6556  h1 = (xpt -x(1,n1))*(xpt -xshf +x(1,n1)) &
6557  +(ypt -x(2,n1))*(ypt -yshf +x(2,n1)) &
6558  +(zpt -x(3,n1))*(zpt -zshf +x(3,n1))
6559  h2 = (x(1,n3) -x(1,n1))*(x(1,n3) -xshf +x(1,n1)) &
6560  +(x(2,n3) -x(2,n1))*(x(2,n3) -yshf +x(2,n1)) &
6561  +(x(3,n3) -x(3,n1))*(x(3,n3) -zshf +x(3,n1))
6562  h3 = (x(1,n2) -x(1,n1))*(x(1,n2) -xshf +x(1,n1)) &
6563  +(x(2,n2) -x(2,n1))*(x(2,n2) -yshf +x(2,n1)) &
6564  +(x(3,n2) -x(3,n1))*(x(3,n2) -zshf +x(3,n1))
6565  c5 = h2*(x(3,n2) -x(3,n1)) -h3*(x(3,n3) -x(3,n1))
6566  c6 = h2*(x(2,n2) -x(2,n1)) -h3*(x(2,n3) -x(2,n1))
6567  c9 = h3*(x(1,n3) -x(1,n1)) -h2*(x(1,n2) -x(1,n1))
6568  xcn = .5*xshf +(h1*rnx +(ypt -x(2,n1))*c5 &
6569  -(zpt -x(3,n1))*c6)*fac
6570  ycn = .5*yshf +(-(xpt -x(1,n1))*c5 +h1*rny &
6571  -(zpt -x(3,n1))*c9)*fac
6572  zcn = .5*zshf +((xpt -x(1,n1))*c6 &
6573  +(ypt -x(2,n1))*c9 +h1*rnz)*fac
6574 !
6575 ! COMPUTE CIRCUMRADIUS
6576 !
6577  rcir = sqrt((xpt -xcn)**2 +(ypt -ycn)**2 &
6578  +(zpt -zcn)**2)
6579  RETURN
6580  30 vcell = vtet/6.
6581 ! WRITE (6,600) VCELL
6582  iflag = 1
6583  RETURN
6584  600 FORMAT(//5x,'TETRAHEDRON WITH AN EXTREMELY SMALL VOLUME FOUND'// &
6585  ' IN ROUTINE CIRCUM2'//5x,'VOLUME = ',e13.5/)
6586  END SUBROUTINE circum2
6587 
6588 
6589 
6590 
6591 
6592 
6593 
6594 !
6595 ! ******************************************************************
6596 !
6597  SUBROUTINE neighb (L1,N1,N2,N3,L2,K1,K2,NDC,NBH)
6598 !
6599 ! ******************************************************************
6600 ! * *
6601 ! * GIVEN FACE (N1,N2,N3) OF TETRAHEDRON L1, FIND THE NEIGHBORING *
6602 ! * TETRAHEDRON, L2, WHICH SHARES THIS FACE. *
6603 ! * LABELS K1 AND K2 ARE INDICES OF ARRAY NBH. *
6604 ! * THUS, NBH(K1,L1) = L2 AND NBH(K2,L2) = L1 *
6605 ! * *
6606 ! ******************************************************************
6607 ! ******************************************************************
6608 ! * *
6609 ! * COPYRIGHT (C) TIM BAKER 1994 *
6610 ! * *
6611 ! ******************************************************************
6612 !
6613  IMPLICIT NONE
6614 
6615  INTEGER :: k1,k2,l1,l2,n1,n2,n3
6616  INTEGER :: ndc(4,*),nbh(4,*)
6617 
6618  INTEGER :: k,kk,m,mend,mmax,mmin,msum,m1,m2,m3,m4,nmax,nmin,nsum
6619 !
6620 ! ******************************************************************
6621 !
6622  nmin = min(n1,n2,n3)
6623  nmax = max(n1,n2,n3)
6624  nsum = n1 +n2 +n3
6625  DO 20 k=1,4
6626  k1 = k
6627  l2 = nbh(k1,l1)
6628  m1 = ndc(1,l2)
6629  m2 = ndc(2,l2)
6630  m3 = ndc(3,l2)
6631  m4 = ndc(4,l2)
6632  mend = m4
6633  10 mmin = min(m1,m2,m3)
6634  mmax = max(m1,m2,m3)
6635  msum = m1 +m2 +m3
6636  IF (mmin.EQ.nmin.AND.mmax.EQ.nmax.AND.msum.EQ.nsum) go to 30
6637  IF (m1.EQ.mend) go to 20
6638  m = m1
6639  m1 = m2
6640  m2 = m3
6641  m3 = m4
6642  m4 = m
6643  go to 10
6644  20 CONTINUE
6645  go to 110
6646 !
6647 ! NEIGHBORING TETRAHEDRON L2 HAS BEEN FOUND
6648 !
6649  30 DO 40 k=1,4
6650  k2 = k
6651  IF (nbh(k2,l2).EQ.l1) RETURN
6652  40 CONTINUE
6653  WRITE (6,600)
6654  stop
6655  110 WRITE (6,610)
6656 
6657  WRITE (6,900) n1,n2,n3, &
6658  l1,(ndc(kk,l1),kk=1,4),l2,(ndc(kk,l2),kk=1,4)
6659  900 FORMAT('N1,N2,N3 ',3i6,' L1 ',i6,' VERTS ',4i6/ &
6660  27x,' L2 ',i6,' VERTS ',4i6)
6661 
6662  stop
6663  600 FORMAT(//5x,'UNABLE TO FIND NBH INDEX OF NEIGHBORING TETRAHEDRON', &
6664  5x,'TO ORIGINAL TETRAHEDRON. PROGRAM STOPPED IN NEIGHB')
6665  610 FORMAT(//5x,'UNABLE TO FIND A NEIGHBORING TETRAHEDRON THAT HAS', &
6666  5x,'THE REQUIRED FACE. PROGRAM STOPPED IN NEIGHB')
6667  END SUBROUTINE neighb
6668 
6669 
6670 
6671 
6672 
6673 
6674 
6675 
6676 !
6677 ! ******************************************************************
6678 !
6679  SUBROUTINE lock (L1,L2,N1,N2,N3,N4,N5,K1,K2,NDC,NBH)
6680 !
6681 ! ******************************************************************
6682 ! * *
6683 ! * FIND COMMON FACE BETWEEN TETRAHEDRA L1 AND L2. THEN SET THE *
6684 ! * LABELS N1,N2,N3,N4 TO BE THE VERTEX ADDRESSES OF L1 AND SET *
6685 ! * N1,N2,N3,N5 TO BE THE VERTEX ADDRESSES OF L2. LABELS K1 AND *
6686 ! * K2 ARE INDICES OF ARRAY NBH. *
6687 ! * THUS, NBH(K1,L1) = L2 AND NBH(K2,L2) = L1 *
6688 ! * *
6689 ! ******************************************************************
6690 ! ******************************************************************
6691 ! * *
6692 ! * COPYRIGHT (C) TIM BAKER 1994 *
6693 ! * *
6694 ! ******************************************************************
6695 !
6696  IMPLICIT NONE
6697 
6698  INTEGER :: k1,k2,l1,l2,n1,n2,n3,n4,n5
6699  INTEGER :: ndc(4,*),nbh(4,*)
6700 
6701  INTEGER :: m,mend,mmax,mmin,msum,m1,m2,m3,m4,n,nend,nmax,nmin,nsum
6702 !
6703 ! ******************************************************************
6704 !
6705  n1 = ndc(1,l1)
6706  n2 = ndc(2,l1)
6707  n3 = ndc(3,l1)
6708  n4 = ndc(4,l1)
6709  nend = n4
6710  m1 = ndc(1,l2)
6711  m2 = ndc(2,l2)
6712  m3 = ndc(3,l2)
6713  m4 = ndc(4,l2)
6714  10 mend = m4
6715  nmin = min(n1,n2,n3)
6716  nmax = max(n1,n2,n3)
6717  nsum = n1 +n2 +n3
6718  20 mmin = min(m1,m2,m3)
6719  mmax = max(m1,m2,m3)
6720  msum = m1 +m2 +m3
6721  IF (mmin.EQ.nmin.AND.mmax.EQ.nmax.AND.msum.EQ.nsum) go to 40
6722  IF (m1.EQ.mend) go to 30
6723  m = m1
6724  m1 = m2
6725  m2 = m3
6726  m3 = m4
6727  m4 = m
6728  go to 20
6729  30 IF (n1.EQ.nend) go to 100
6730  n = n1
6731  n1 = n2
6732  n2 = n3
6733  n3 = n4
6734  n4 = n
6735  go to 10
6736 !
6737 ! COMMON FACE (N1,N2,N3) HAS BEEN FOUND
6738 !
6739  40 n5 = m4
6740  k1 = 0
6741  IF (nbh(1,l1).EQ.l2) k1 = 1
6742  IF (nbh(2,l1).EQ.l2) k1 = 2
6743  IF (nbh(3,l1).EQ.l2) k1 = 3
6744  IF (nbh(4,l1).EQ.l2) k1 = 4
6745  k2 = 0
6746  IF (nbh(1,l2).EQ.l1) k2 = 1
6747  IF (nbh(2,l2).EQ.l1) k2 = 2
6748  IF (nbh(3,l2).EQ.l1) k2 = 3
6749  IF (nbh(4,l2).EQ.l1) k2 = 4
6750  RETURN
6751  100 WRITE (6,600)
6752  stop
6753  600 FORMAT(//5x,'UNABLE TO FIND THE COMMON FACE IN ROUTINE LOCK')
6754  END SUBROUTINE lock
6755 
6756 
6757 
6758 
6759 
6760 
6761 
6762 !
6763 ! ******************************************************************
6764 !
6765  FUNCTION facear (X,N1,N2,N3)
6766 !
6767 ! ******************************************************************
6768 ! * *
6769 ! * COMPUTE AREA OF FACE J *
6770 ! * *
6771 ! ******************************************************************
6772 !
6773  IMPLICIT NONE
6774 
6775  DOUBLE PRECISION :: facear
6776 
6777  INTEGER :: n1,n2,n3
6778  DOUBLE PRECISION :: ax,ay,az
6779  DOUBLE PRECISION :: x(3,*)
6780 !
6781 ! ******************************************************************
6782 !
6783  ax = (x(2,n2) -x(2,n1))*(x(3,n3) -x(3,n1)) &
6784  -(x(3,n2) -x(3,n1))*(x(2,n3) -x(2,n1))
6785  ay = (x(3,n2) -x(3,n1))*(x(1,n3) -x(1,n1)) &
6786  -(x(1,n2) -x(1,n1))*(x(3,n3) -x(3,n1))
6787  az = (x(1,n2) -x(1,n1))*(x(2,n3) -x(2,n1)) &
6788  -(x(2,n2) -x(2,n1))*(x(1,n3) -x(1,n1))
6789  facear = 0.5d0*sqrt(ax*ax +ay*ay +az*az)
6790  RETURN
6791  END FUNCTION facear
6792 
6793 
6794 
6795 
6796 
6797 
6798 !
6799 ! ******************************************************************
6800 !
6801  FUNCTION dihed (N1,N2,N3,N4,X)
6802 !
6803 ! ******************************************************************
6804 ! * *
6805 ! * CALCULATE DIHEDRAL ANGLE BETWEEN PLANES DEFINED BY (N1,N2,N3) *
6806 ! * AND (N2,N1,N4) WHICH INTERSECT ALONG COMMON EDGE (N1,N2) *
6807 ! * *
6808 ! ******************************************************************
6809 !
6810  IMPLICIT NONE
6811 
6812  DOUBLE PRECISION :: dihed
6813 
6814  INTEGER n1,n2,n3,n4
6815  DOUBLE PRECISION :: x(3,*)
6816 
6817  DOUBLE PRECISION :: asiz,ax,ay,az,a1,a2,a3, &
6818  bsiz,bx,by,bz,b1,b2,b3, &
6819  cosang,fac,pi,px,py,pz,rad, &
6820  sinang,sx,sy,sz
6821 !
6822 ! ******************************************************************
6823 !
6824  pi = 4.0d0*atan(1.0d0)
6825  rad = 180.0d0/pi
6826  dihed = 0.d0
6827 !
6828 ! CALCULATE UNIT NORMAL (AX,AY,AZ) TO TRIANGLE (N1,N2,N3)
6829 !
6830  ax = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
6831  ay = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
6832  az = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
6833  asiz = sqrt(ax*ax +ay*ay +az*az)
6834  IF (asiz.LT.1.0d-6) RETURN
6835  fac = 1./asiz
6836  ax = ax*fac
6837  ay = ay*fac
6838  az = az*fac
6839 !
6840 ! CALCULATE UNIT NORMAL (BX,BY,BZ) TO TRIANGLE (N2,N1,N4)
6841 !
6842  bx = cofact(x(2,n1),x(2,n4),x(2,n2),x(3,n1),x(3,n4),x(3,n2))
6843  by = cofact(x(3,n1),x(3,n4),x(3,n2),x(1,n1),x(1,n4),x(1,n2))
6844  bz = cofact(x(1,n1),x(1,n4),x(1,n2),x(2,n1),x(2,n4),x(2,n2))
6845  bsiz = sqrt(bx*bx +by*by +bz*bz)
6846  IF (bsiz.LT.1.0d-6) RETURN
6847  fac = 1./bsiz
6848  bx = bx*fac
6849  by = by*fac
6850  bz = bz*fac
6851 !
6852 ! FORM COSINE OF ANGLE BETWEEN THE NORMALS
6853 !
6854  cosang = ax*bx +ay*by +az*bz
6855 !
6856 ! COMPUTE UNIT VECTOR (PX,PY,PZ) DIRECTED FROM POINT N1 TO POINT N2
6857 !
6858  px = x(1,n2) -x(1,n1)
6859  py = x(2,n2) -x(2,n1)
6860  pz = x(3,n2) -x(3,n1)
6861  fac = 1.0d0/sqrt(px*px +py*py +pz*pz)
6862  px = px*fac
6863  py = py*fac
6864  pz = pz*fac
6865 !
6866 ! FORM SCALAR TRIPLE PRODUCT OF VECTORS (A,B,P) TO OBTAIN THE SINE
6867 ! OF THE ANGLE BETWEEN THE NORMALS
6868 !
6869  sx = ay*bz -az*by
6870  sy = az*bx -ax*bz
6871  sz = ax*by -ay*bx
6872  sinang = sx*px +sy*py +sz*pz
6873  dihed = 180.d0 +rad*atan2(sinang,cosang)
6874  IF (dihed.GE.360.d0) dihed = dihed -360.d0
6875  RETURN
6876  END FUNCTION dihed
6877 
6878 
6879 
6880 
6881 
6882 
6883 !
6884 ! ******************************************************************
6885 !
6886  FUNCTION tetar (L,X,NDC)
6887 !
6888 ! ******************************************************************
6889 ! * *
6890 ! * COMPUTE COMBINED AREA OF THE FOUR FACES OF TETRAHEDRON L *
6891 ! * *
6892 ! ******************************************************************
6893 !
6894  IMPLICIT NONE
6895 
6896  DOUBLE PRECISION :: tetar
6897 
6898  INTEGER :: l
6899  INTEGER :: ndc(4,*)
6900  DOUBLE PRECISION :: x(3,*)
6901 
6902  INTEGER :: n,nend,n1,n2,n3,n4
6903  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,rnx,rny,rnz
6904 !
6905 ! ******************************************************************
6906 !
6907  n1 = ndc(1,l)
6908  n2 = ndc(2,l)
6909  n3 = ndc(3,l)
6910  n4 = ndc(4,l)
6911  nend = n4
6912  area = 0.
6913  10 rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
6914  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
6915  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
6916  area = area +sqrt(rnx*rnx +rny*rny +rnz*rnz)
6917  IF (n1.EQ.nend) go to 20
6918  n = n1
6919  n1 = n2
6920  n2 = n3
6921  n3 = n4
6922  n4 = n
6923  go to 10
6924  20 tetar = area
6925  RETURN
6926  END FUNCTION tetar
6927 
6928 
6929 
6930 
6931 
6932 
6933 !
6934 ! ******************************************************************
6935 !
6936  FUNCTION tetar2 (M1,M2,M3,M4,X)
6937 !
6938 ! ******************************************************************
6939 ! * *
6940 ! * COMPUTE COMBINED AREA OF THE FOUR FACES OF THE TETRAHEDRON *
6941 ! * WHOSE VERTEX ADDRESSES ARE N1, N2, N3 AND N4 *
6942 ! * *
6943 ! ******************************************************************
6944 !
6945  IMPLICIT NONE
6946 
6947  DOUBLE PRECISION :: tetar2
6948 
6949  INTEGER :: m1,m2,m3,m4
6950  DOUBLE PRECISION :: x(3,*)
6951 
6952  INTEGER :: n,nend,n1,n2,n3,n4
6953  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,rnx,rny,rnz
6954 !
6955 ! ******************************************************************
6956 !
6957  n1 = m1
6958  n2 = m2
6959  n3 = m3
6960  n4 = m4
6961  nend = n4
6962  area = 0.
6963  10 rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
6964  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
6965  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
6966  area = area +sqrt(rnx*rnx +rny*rny +rnz*rnz)
6967  IF (n1.EQ.nend) go to 20
6968  n = n1
6969  n1 = n2
6970  n2 = n3
6971  n3 = n4
6972  n4 = n
6973  go to 10
6974  20 tetar2 = area
6975  RETURN
6976  END FUNCTION tetar2
6977 
6978 
6979 
6980 
6981 
6982 
6983 !
6984 ! ******************************************************************
6985 !
6986  FUNCTION tetar3 (M1,M2,M3,XPT,YPT,ZPT,X)
6987 !
6988 ! ******************************************************************
6989 ! * *
6990 ! * COMPUTE COMBINED AREA OF THE FOUR FACES OF THE TETRAHEDRON *
6991 ! * WHOSE BASE HAS THE VERTEX ADDRESSES N1, N2, N3 AND WHOSE *
6992 ! * FOURTH VERTEX IS GIVEN BY THE POINT (XPT,YPT,ZPT). *
6993 ! * *
6994 ! ******************************************************************
6995 !
6996  IMPLICIT NONE
6997 
6998  DOUBLE PRECISION :: tetar3
6999 
7000  INTEGER :: m1,m2,m3
7001  DOUBLE PRECISION :: xpt,ypt,zpt
7002  DOUBLE PRECISION :: x(3,*)
7003 
7004  INTEGER :: n,nend,n1,n2,n3
7005  DOUBLE PRECISION :: area,a1,a2,a3,b1,b2,b3,rnx,rny,rnz
7006 !
7007 ! ******************************************************************
7008 !
7009  n1 = m1
7010  n2 = m2
7011  n3 = m3
7012  nend = n3
7013  area = 0.
7014  10 rnx = cofact(x(2,n1),x(2,n2),ypt,x(3,n1),x(3,n2),zpt)
7015  rny = cofact(x(3,n1),x(3,n2),zpt,x(1,n1),x(1,n2),xpt)
7016  rnz = cofact(x(1,n1),x(1,n2),xpt,x(2,n1),x(2,n2),ypt)
7017  area = area +sqrt(rnx*rnx +rny*rny +rnz*rnz)
7018  IF (n1.EQ.nend) go to 20
7019  n = n1
7020  n1 = n2
7021  n2 = n3
7022  n3 = n
7023  go to 10
7024  20 rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
7025  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
7026  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
7027  tetar3 = area +sqrt(rnx*rnx +rny*rny +rnz*rnz)
7028  RETURN
7029  END FUNCTION tetar3
7030 
7031 
7032 
7033 
7034 
7035 
7036 !
7037 ! ******************************************************************
7038 !
7039  SUBROUTINE fangle (J,X,NFCE,ANGL1,ANGL2,ANGL3,Q)
7040 !
7041 ! ******************************************************************
7042 ! * *
7043 ! * COMPUTE FACE ANGLES AND QUALITY MEASURE FOR FACE J *
7044 ! * *
7045 ! ******************************************************************
7046 ! ******************************************************************
7047 ! * *
7048 ! * COPYRIGHT (C) TIM BAKER 1994 *
7049 ! * *
7050 ! ******************************************************************
7051 !
7052  IMPLICIT NONE
7053 
7054  INTEGER :: j
7055  INTEGER :: nfce(3,*)
7056  DOUBLE PRECISION :: angl1,angl2,angl3,q
7057  DOUBLE PRECISION :: x(3,*)
7058 
7059  INTEGER ::n1,n2,n3
7060  DOUBLE PRECISION :: chalf,c1,c2,c3,da,db,dc,prod1,prod2,prod3, &
7061  rad,s1,s2,s3,t1,t2,t3
7062 !
7063 ! ******************************************************************
7064 !
7065  rad = 45.0d0/atan(1.0d0)
7066  n1 = nfce(1,j)
7067  n2 = nfce(2,j)
7068  n3 = nfce(3,j)
7069  prod1 = (x(1,n2) -x(1,n1))*(x(1,n3) -x(1,n1)) &
7070  +(x(2,n2) -x(2,n1))*(x(2,n3) -x(2,n1)) &
7071  +(x(3,n2) -x(3,n1))*(x(3,n3) -x(3,n1))
7072  da = sqrt((x(1,n2) -x(1,n1))**2 +(x(2,n2) -x(2,n1))**2 &
7073  +(x(3,n2) -x(3,n1))**2)
7074  db = sqrt((x(1,n3) -x(1,n1))**2 +(x(2,n3) -x(2,n1))**2 &
7075  +(x(3,n3) -x(3,n1))**2)
7076  c1 = prod1/(da*db)
7077  chalf = .5*(1. +c1)
7078  IF (chalf.LT.1.e-6) go to 200
7079  t1 = sqrt(1./chalf -1)
7080  angl1 = 2.*atan(t1)
7081  s1 = sin(angl1)
7082  angl1 = rad*angl1
7083  prod2 = (x(1,n3) -x(1,n2))*(x(1,n1) -x(1,n2)) &
7084  +(x(2,n3) -x(2,n2))*(x(2,n1) -x(2,n2)) &
7085  +(x(3,n3) -x(3,n2))*(x(3,n1) -x(3,n2))
7086  da = sqrt((x(1,n3) -x(1,n2))**2 +(x(2,n3) -x(2,n2))**2 &
7087  +(x(3,n3) -x(3,n2))**2)
7088  db = sqrt((x(1,n1) -x(1,n2))**2 +(x(2,n1) -x(2,n2))**2 &
7089  +(x(3,n1) -x(3,n2))**2)
7090  c2 = prod2/(da*db)
7091  chalf = .5*(1. +c2)
7092  IF (chalf.LT.1.e-6) go to 200
7093  t2 = sqrt(1./chalf -1)
7094  angl2 = 2.*atan(t2)
7095  s2 = sin(angl2)
7096  angl2 = rad*angl2
7097  prod3 = (x(1,n1) -x(1,n3))*(x(1,n2) -x(1,n3)) &
7098  +(x(2,n1) -x(2,n3))*(x(2,n2) -x(2,n3)) &
7099  +(x(3,n1) -x(3,n3))*(x(3,n2) -x(3,n3))
7100  da = sqrt((x(1,n1) -x(1,n3))**2 +(x(2,n1) -x(2,n3))**2 &
7101  +(x(3,n1) -x(3,n3))**2)
7102  db = sqrt((x(1,n2) -x(1,n3))**2 +(x(2,n2) -x(2,n3))**2 &
7103  +(x(3,n2) -x(3,n3))**2)
7104  c3 = prod3/(da*db)
7105  chalf = .5*(1. +c3)
7106  IF (chalf.LT.1.e-6) go to 200
7107  t3 = sqrt(1./chalf -1)
7108  angl3 = 2.*atan(t3)
7109  s3 = sin(angl3)
7110  angl3 = rad*angl3
7111  q = .5*(s1 +s2 +s3)/(s1*s2*s3)
7112  RETURN
7113  200 WRITE (6,600) j,n1,x(1,n1),x(2,n1),x(3,n1), &
7114  n2,x(1,n2),x(2,n2),x(3,n2), &
7115  n3,x(1,n3),x(2,n3),x(3,n3)
7116  stop
7117  600 FORMAT(//5x,'FACE ',i6,' HAS AN ANGLE OF 180 DEGREES'// &
7118  5x,'VERTEX ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4/ &
7119  5x,'VERTEX ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4/ &
7120  5x,'VERTEX ',i6,' X = ',f10.4,' Y = ',f10.4,' Z = ',f10.4// &
7121  5x,'PROGRAM STOPPED IN FANGLE')
7122  END SUBROUTINE fangle
7123 
7124 
7125 
7126 
7127 
7128 
7129 
7130 !
7131 ! ******************************************************************
7132 !
7133  SUBROUTINE tetang (X,NDC,NBH,IPROT,NCELL)
7134 !
7135 ! ******************************************************************
7136 ! * *
7137 ! * CALCULATE MAXIMUM AND MINIMUM DIHEDRAL ANGLE AMONG ALL *
7138 ! * TETRAHEDRA IN MESH *
7139 ! * *
7140 ! ******************************************************************
7141 ! ******************************************************************
7142 ! * *
7143 ! * COPYRIGHT (C) TIM BAKER 1994 *
7144 ! * *
7145 ! ******************************************************************
7146 !
7147  IMPLICIT NONE
7148 
7149  INTEGER :: ncell
7150  INTEGER :: ndc(4,*),nbh(4,*),iprot(*)
7151  DOUBLE PRECISION :: x(3,*)
7152 
7153  INTEGER :: j,npass,n1,n2,n3,n4
7154  DOUBLE PRECISION :: angmax,angmin,ang1,ang2,ang3,ang4,ang5,ang6, &
7155  dsmax,dsmin,ds1,ds2,ds3,ds4,ds5,ds6
7156 
7157 !
7158 ! ******************************************************************
7159 !
7160  angmin = 180.
7161  angmax = 0.
7162  npass = 0
7163  DO 20 j=1,ncell
7164  IF (iprot(j).EQ.1) go to 20
7165  IF (ndc(1,j).EQ.0) go to 20
7166  IF (nbh(1,j).EQ.0) go to 20
7167  n1 = ndc(1,j)
7168  n2 = ndc(2,j)
7169  n3 = ndc(3,j)
7170  n4 = ndc(4,j)
7171  IF (n4.EQ.-1) go to 20
7172  ang1 = dihed(n1,n2,n3,n4,x)
7173  IF (ang1.GT.180.) ang1 = 360. -ang1
7174  ang2 = dihed(n2,n3,n1,n4,x)
7175  IF (ang2.GT.180.) ang2 = 360. -ang2
7176  ang3 = dihed(n3,n1,n2,n4,x)
7177  IF (ang3.GT.180.) ang3 = 360. -ang3
7178  ang4 = dihed(n1,n4,n2,n3,x)
7179  IF (ang4.GT.180.) ang4 = 360. -ang4
7180  ang5 = dihed(n2,n4,n1,n3,x)
7181  IF (ang5.GT.180.) ang5 = 360. -ang5
7182  ang6 = dihed(n3,n4,n1,n2,x)
7183  IF (ang6.GT.180.) ang6 = 360. -ang6
7184  angmin = min(angmin,ang1,ang2,ang3,ang4,ang5,ang6)
7185  angmax = max(angmax,ang1,ang2,ang3,ang4,ang5,ang6)
7186  ds1 = (x(1,n1) -x(1,n2))**2 +(x(2,n1) -x(2,n2))**2 &
7187  +(x(3,n1) -x(3,n2))**2
7188  ds2 = (x(1,n1) -x(1,n3))**2 +(x(2,n1) -x(2,n3))**2 &
7189  +(x(3,n1) -x(3,n3))**2
7190  ds3 = (x(1,n1) -x(1,n4))**2 +(x(2,n1) -x(2,n4))**2 &
7191  +(x(3,n1) -x(3,n4))**2
7192  ds4 = (x(1,n2) -x(1,n3))**2 +(x(2,n2) -x(2,n3))**2 &
7193  +(x(3,n2) -x(3,n3))**2
7194  ds5 = (x(1,n2) -x(1,n4))**2 +(x(2,n2) -x(2,n4))**2 &
7195  +(x(3,n2) -x(3,n4))**2
7196  ds6 = (x(1,n3) -x(1,n4))**2 +(x(2,n3) -x(2,n4))**2 &
7197  +(x(3,n3) -x(3,n4))**2
7198  IF (npass.EQ.1) go to 10
7199  npass = 1
7200  dsmin = min(ds1,ds2,ds3,ds4,ds5,ds6)
7201  dsmax = max(ds1,ds2,ds3,ds4,ds5,ds6)
7202  go to 20
7203  10 dsmin = min(dsmin,ds1,ds2,ds3,ds4,ds5,ds6)
7204  dsmax = max(dsmax,ds1,ds2,ds3,ds4,ds5,ds6)
7205  20 CONTINUE
7206  dsmin = sqrt(dsmin)
7207  dsmax = sqrt(dsmax)
7208  WRITE (6,600) angmin,angmax,dsmin,dsmax
7209  RETURN
7210  600 FORMAT( 5x,'*************************************************'/ &
7211  5x,'* *'/ &
7212  5x,'* MINIMUM DIHEDRAL ANGLE IS ',f6.2,' DEGREES *'/ &
7213  5x,'* MAXIMUM DIHEDRAL ANGLE IS ',f6.2,' DEGREES *'/ &
7214  5x,'* *'/ &
7215  5x,'* MINIMUM EDGE DISTANCE IS ',f12.4,' *'/ &
7216  5x,'* MAXIMUM EDGE DISTANCE IS ',f12.4,' *'/ &
7217  5x,'* *'/ &
7218  5x,'*************************************************')
7219  END SUBROUTINE tetang
7220 
7221 
7222 
7223 
7224 
7225 
7226 !
7227 ! ******************************************************************
7228 !
7229  SUBROUTINE tetcof (N1,N2,N3,N4,XPT,YPT,ZPT,V1,V2,V3,V4,VTET,X)
7230 !
7231 ! ******************************************************************
7232 ! * *
7233 ! * DETERMINE VOLUME VTET OF TETRAHEDRON (N1,N2,N3,N4) AND THE *
7234 ! * VOLUMES OF THE FOUR TETRAHEDRA ASSOCIATED WITH ITS FACES *
7235 ! * AND THE POINT (XPT,YPT,ZPT). *
7236 ! * *
7237 ! ******************************************************************
7238 ! ******************************************************************
7239 ! * *
7240 ! * COPYRIGHT (C) TIM BAKER 1994 *
7241 ! * *
7242 ! ******************************************************************
7243 !
7244  IMPLICIT NONE
7245 
7246  DOUBLE PRECISION :: vtet,v1,v2,v3,v4,xpt,ypt,zpt
7247  DOUBLE PRECISION :: x(3,*)
7248 
7249  INTEGER :: n1,n2,n3,n4
7250  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,rnx,rny,rnz
7251 !
7252 ! ******************************************************************
7253 !
7254  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
7255  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
7256  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
7257  v4 = abs(rnx*(xpt -x(1,n1)) +rny*(ypt -x(2,n1)) &
7258  +rnz*(zpt -x(3,n1)))
7259  vtet = abs(rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
7260  +rnz*(x(3,n4) -x(3,n1)))
7261  rnx = cofact(x(2,n2),x(2,n3),x(2,n4),x(3,n2),x(3,n3),x(3,n4))
7262  rny = cofact(x(3,n2),x(3,n3),x(3,n4),x(1,n2),x(1,n3),x(1,n4))
7263  rnz = cofact(x(1,n2),x(1,n3),x(1,n4),x(2,n2),x(2,n3),x(2,n4))
7264  v1 = abs(rnx*(xpt -x(1,n2)) +rny*(ypt -x(2,n2)) &
7265  +rnz*(zpt -x(3,n2)))
7266  rnx = cofact(x(2,n3),x(2,n4),x(2,n1),x(3,n3),x(3,n4),x(3,n1))
7267  rny = cofact(x(3,n3),x(3,n4),x(3,n1),x(1,n3),x(1,n4),x(1,n1))
7268  rnz = cofact(x(1,n3),x(1,n4),x(1,n1),x(2,n3),x(2,n4),x(2,n1))
7269  v2 = abs(rnx*(xpt -x(1,n3)) +rny*(ypt -x(2,n3)) &
7270  +rnz*(zpt -x(3,n3)))
7271  rnx = cofact(x(2,n4),x(2,n1),x(2,n2),x(3,n4),x(3,n1),x(3,n2))
7272  rny = cofact(x(3,n4),x(3,n1),x(3,n2),x(1,n4),x(1,n1),x(1,n2))
7273  rnz = cofact(x(1,n4),x(1,n1),x(1,n2),x(2,n4),x(2,n1),x(2,n2))
7274  v3 = abs(rnx*(xpt -x(1,n4)) +rny*(ypt -x(2,n4)) &
7275  +rnz*(zpt -x(3,n4)))
7276  RETURN
7277  END SUBROUTINE tetcof
7278 
7279 
7280 
7281 
7282 
7283 
7284 
7285 !
7286 ! ******************************************************************
7287 !
7288  SUBROUTINE volcom (L,NPT,VDIFF,NCONT,X,NDC)
7289 !
7290 ! ******************************************************************
7291 ! * *
7292 ! * COMPUTE VOLUMES OF TETRAHEDRA (N1,N2,N3,N4), (N1,N2,N3,NPT) *
7293 ! * (N2,N3,N4,NPT), (N3,N4,N1,NPT) AND (N4,N1,N2,NPT). *
7294 ! * POINT NPT LIES INSIDE TETRAHEDRON (N1,N2,N3,N4) IF NCONT = 0 *
7295 ! * *
7296 ! ******************************************************************
7297 ! ******************************************************************
7298 ! * *
7299 ! * COPYRIGHT (C) TIM BAKER 1994 *
7300 ! * *
7301 ! ******************************************************************
7302 !
7303  IMPLICIT NONE
7304 
7305  DOUBLE PRECISION :: x(3,*)
7306  INTEGER :: l,n,ncnt,ncont,nend,npt,n1,n2,n3,n4
7307  INTEGER :: ndc(4,*)
7308 
7309  DOUBLE PRECISION :: a1,a2,a3,b1,b2,b3,ptot,rnx,rny,rnz,sc,sp,vdiff
7310  DOUBLE PRECISION :: v(4),vcell(4),ptest(4)
7311 !
7312 ! ******************************************************************
7313 !
7314  n1 = ndc(1,l)
7315  n2 = ndc(2,l)
7316  n3 = ndc(3,l)
7317  n4 = ndc(4,l)
7318 !
7319 ! COMPUTE VOLUMES OF COMPONENT TETRAHEDRA
7320 !
7321  nend = n4
7322  ncnt = 0
7323  10 ncnt = ncnt +1
7324  rnx = cofact(x(2,n1),x(2,n2),x(2,n3),x(3,n1),x(3,n2),x(3,n3))
7325  rny = cofact(x(3,n1),x(3,n2),x(3,n3),x(1,n1),x(1,n2),x(1,n3))
7326  rnz = cofact(x(1,n1),x(1,n2),x(1,n3),x(2,n1),x(2,n2),x(2,n3))
7327  v(ncnt) = rnx*(x(1,npt) -x(1,n1)) +rny*(x(2,npt) -x(2,n1)) &
7328  +rnz*(x(3,npt) -x(3,n1))
7329  vcell(ncnt) = rnx*(x(1,n4) -x(1,n1)) +rny*(x(2,n4) -x(2,n1)) &
7330  +rnz*(x(3,n4) -x(3,n1))
7331  sp = sign(1.0d0,v(ncnt))
7332  sc = sign(1.0d0,vcell(ncnt))
7333  v(ncnt) = sp*v(ncnt)
7334  vcell(ncnt) = sc*vcell(ncnt)
7335  ptest(ncnt) = sp*sc
7336  IF (n1.EQ.nend) go to 20
7337  n = n1
7338  n1 = n2
7339  n2 = n3
7340  n3 = n4
7341  n4 = n
7342  go to 10
7343 !
7344 ! COMPUTE DIFFERENCE BETWEEN SUM OF COMPONENT TETRAHEDRA VOLUMES AND
7345 ! VOLUME OF TETRAHEDRON THAT MAY CONTAIN POINT NPT
7346 !
7347  20 vdiff = v(1)+v(2)+v(3)+v(4) &
7348  -0.25d0*(vcell(1)+vcell(2)+vcell(3)+vcell(4))
7349  ptot = ptest(1)+ptest(2)+ptest(3)+ptest(4)
7350  ncont = 0
7351  IF (ptot.GT.3.0d0) RETURN
7352  ncont = 1
7353  IF (ptot.GT.-3.0d0) RETURN
7354  ncont = -1
7355 
7356  WRITE (6,900) n1,x(1,n1),x(2,n1),x(3,n1), &
7357  n2,x(1,n2),x(2,n2),x(3,n2), &
7358  n3,x(1,n3),x(2,n3),x(3,n3), &
7359  n4,x(1,n4),x(2,n4),x(3,n4), &
7360  npt,x(1,npt),x(2,npt),x(3,npt), &
7361  v(1),v(2),v(3),v(4), &
7362  vcell(1),vcell(2),vcell(3),vcell(4), &
7363  ptest(1),ptest(2),ptest(3),ptest(4)
7364  900 FORMAT('N1 ',i5,' X = ',f10.4,' Y = ',f10.4,'Z = ',f10.4/ &
7365  'N2 ',i5,' X = ',f10.4,' Y = ',f10.4,'Z = ',f10.4/ &
7366  'N3 ',i5,' X = ',f10.4,' Y = ',f10.4,'Z = ',f10.4/ &
7367  'N4 ',i5,' X = ',f10.4,' Y = ',f10.4,'Z = ',f10.4/ &
7368  'NPT ',i5,' X = ',f10.4,' Y = ',f10.4,'Z = ',f10.4/ &
7369  'V1 = ',e13.5,' V2 = ',e13.5,' V3 = ',e13.5,' V4 = ',e13.5/ &
7370  'VCELL = ',4(2x,e13.5)/ &
7371  'P1 = ',e13.5,' P2 = ',e13.5,' P3 = ',e13.5,' P4 = ',e13.5)
7372 
7373  RETURN
7374  END SUBROUTINE volcom
7375 
7376 
7377 ! ******************************************************************************
7378 ! Compute cofactor (extracted into own function)
7379 ! ******************************************************************************
7380 
7381  FUNCTION cofact(A1,A2,A3,B1,B2,B3)
7382 
7383  IMPLICIT NONE
7384 
7385  DOUBLE PRECISION :: cofact
7386 
7387  DOUBLE PRECISION, INTENT(IN) :: a1,a2,a3,b1,b2,b3
7388 
7389  cofact = (a2 -a1)*(b3 -b1) -(a3 -a1)*(b2 -b1)
7390 
7391  END FUNCTION cofact
7392 
7393 
7394  END MODULE rflu_modrepair3d
7395 
7396 ! ******************************************************************************
7397 !
7398 ! RCS Revision history:
7399 !
7400 ! $Log: RFLU_ModRepair3D.F90,v $
7401 ! Revision 1.4 2008/12/06 08:44:23 mtcampbe
7402 ! Updated license.
7403 !
7404 ! Revision 1.3 2008/11/19 22:17:34 mtcampbe
7405 ! Added Illinois Open Source License/Copyright
7406 !
7407 ! Revision 1.2 2003/07/09 22:38:56 haselbac
7408 ! Removed NREP (not used)
7409 !
7410 ! Revision 1.1 2002/10/05 19:16:17 haselbac
7411 ! Initial revision - NOT TESTED
7412 !
7413 ! ******************************************************************************
7414 
7415 
7416 
7417 
7418 
7419 
7420 
rflu_modrepair3d::tessel
subroutine tessel(IRING, NRING, NFAD, NBHKP, IEDKP, NEDK, IMEET, ITOUCH, X, IPOINT, NPOINT, DX, DY, DZ, DS, NP)
Definition: RFLU_ModRepair3D.F90:5999
by
*********************************************************************Illinois Open Source License ****University of Illinois NCSA **Open Source License University of Illinois All rights reserved ****Developed by
Definition: roccomf90.h:7
rflu_modrepair3d::dihed
double precision function dihed(N1, N2, N3, N4, X)
Definition: RFLU_ModRepair3D.F90:6801
kc
**********************************************************************Rocstar Simulation Suite Illinois Rocstar LLC All rights reserved ****Illinois Rocstar LLC IL **www illinoisrocstar com **sales illinoisrocstar com WITHOUT WARRANTY OF ANY **EXPRESS OR INCLUDING BUT NOT LIMITED TO THE WARRANTIES **OF FITNESS FOR A PARTICULAR PURPOSE AND **NONINFRINGEMENT IN NO EVENT SHALL THE CONTRIBUTORS OR **COPYRIGHT HOLDERS BE LIABLE FOR ANY DAMAGES OR OTHER WHETHER IN AN ACTION OF TORT OR **Arising OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE **USE OR OTHER DEALINGS WITH THE SOFTWARE **********************************************************************INTERFACE SUBROUTINE kc
Definition: RFLO_FindSourceCell.h:27
Color::r
unsigned char r() const
Definition: Color.h:68
Aff_transformation_2::m
FT m(int i, int j) const
Definition: Aff_transformation_2.h:228
cimg_library::CImg::sum
Tfloat sum() const
Return the sum of all the pixel values in an image.
Definition: CImg.h:13022
rflu_modrepair3d::tetar2
double precision function tetar2(M1, M2, M3, M4, X)
Definition: RFLU_ModRepair3D.F90:6936
rflu_modrepair3d::rflu_repair3d
subroutine rflu_repair3d(NBPTS, NBFACE, NNODE, NCELL, XI, NFCEI, NDCI, XBNDYI, modFlag)
Definition: RFLU_ModRepair3D.F90:76
ncol
const int ncol
Definition: ex1.C:95
sign
static SURF_BEGIN_NAMESPACE double sign(double x)
Definition: compute_curvature.C:31
rflu_modrepair3d::densfn
subroutine densfn(X, NNODE, NFCE, NBFACE, NEDGE, NDG, DENS, RESID, FVCNT)
Definition: RFLU_ModRepair3D.F90:2260
d
const NT & d
Definition: rational_rotation.h:73
k
j indices k indices k
Definition: Indexing.h:6
rflu_modrepair3d::volput
subroutine volput(X, ITYP, NBPTS, NNODE, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, VOL, XCEN, YCEN, ZCEN, RC, RAT, DENS, NPTET, NACPT, IDONE, NREF, NLINK, NOCTR, IOCTR, XFAR, YFAR, ZFAR, XOCTR, YOCTR, ZOCTR, XHOLD, YHOLD, ZHOLD, XKEEP, YKEEP, ZKEEP, KSRCH, NSRCH, IPOINT, NPOINT, IFLAG, NFLAG, NFILL, NEWCEL, NTRI, NCAV, NSHAKE, NEWNBH, NOLD, NCAVFC, IKEEP, LDEL, NEDGRM, XC, YC, ZC, V, RAD, RCRIN, LNKUP, LNKDN, JLAST, JFIRST, NTRACK, VOLMIN, RCMX, TOLV)
Definition: RFLU_ModRepair3D.F90:2788
dx
NT dx
Definition: rational_rotation.h:81
s
double s
Definition: blastest.C:80
max
Vector_n max(const Array_n_const &v1, const Array_n_const &v2)
Definition: Vector_n.h:354
p1
NT p1
Definition: rational_rotation.h:108
ic
**********************************************************************Rocstar Simulation Suite Illinois Rocstar LLC All rights reserved ****Illinois Rocstar LLC IL **www illinoisrocstar com **sales illinoisrocstar com WITHOUT WARRANTY OF ANY **EXPRESS OR INCLUDING BUT NOT LIMITED TO THE WARRANTIES **OF FITNESS FOR A PARTICULAR PURPOSE AND **NONINFRINGEMENT IN NO EVENT SHALL THE CONTRIBUTORS OR **COPYRIGHT HOLDERS BE LIABLE FOR ANY DAMAGES OR OTHER WHETHER IN AN ACTION OF TORT OR **Arising OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE **USE OR OTHER DEALINGS WITH THE SOFTWARE **********************************************************************INTERFACE SUBROUTINE ic
Definition: RFLO_FindSourceCell.h:27
rflu_modrepair3d::sliver
subroutine sliver(IRING, NRING, NA, NB, NFAIL, VORIG, X, DENS, ITYP, IPOINT, NNODE, NOCTR, IOCTR, NLINK, NREF, XFAR, YFAR, ZFAR, VLT)
Definition: RFLU_ModRepair3D.F90:6297
rflu_modrepair3d::tetmv
subroutine tetmv(X, XNEWBN, NNODE, NDC, NBH, NCELL, NFCE, NBFACE, NFAIL, ITYP, XCEN, YCEN, ZCEN, VOL, RC, RAT, NEDGE, NDG, IDGP, NDGP, IPOINT, FCOUNT, XC, RESID, SV, SIG1, SIG2, SIG3, XFAR, YFAR, ZFAR, TOLV)
Definition: RFLU_ModRepair3D.F90:796
rflu_modrepair3d::colaps
subroutine colaps(NA, NB, NCOL, NVERT, NFAIL, X, NDC, NBH, IPROT, ITYP, XCEN, YCEN, ZCEN, VOL, RC, RAT, NVCNT, IFLAG, NFLAG, NPTET, NDG, IDGP, NDGP, NOCTR, IOCTR, NLINK, XFAR, YFAR, ZFAR, IDONE, NREF, KSRCH, NSRCH, IRING, NTETKP, LNBR, ISHK, MNBR, KSHK, TOLV)
Definition: RFLU_ModRepair3D.F90:4527
sqrt
double sqrt(double d)
Definition: double.h:73
rflu_modrepair3d::facear
double precision function facear(X, N1, N2, N3)
Definition: RFLU_ModRepair3D.F90:6765
rflu_modrepair3d::smooth
subroutine smooth(X, ITYP, NNODE, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, VOL, XCEN, YCEN, ZCEN, RC, RAT, DENS, NPTET, NACPT, IDONE, NREF, NLINK, NOCTR, IOCTR, XFAR, YFAR, ZFAR, XOCTR, YOCTR, ZOCTR, XHOLD, YHOLD, ZHOLD, XKEEP, YKEEP, ZKEEP, KSRCH, NSRCH, IPOINT, NPOINT, IFLAG, NFLAG, DX, DY, DZ, DS, VLT, IRING, NTETKP, NFAD, NEWC, NBHKP, IEDKP, LNBR, ISHK, MNBR, KSHK, NPP, NFILL, NEWCEL, NTRI, NCAV, NSHAKE, NEWNBH, NOLD, NCAVFC, IKEEP, LDEL, NEDGRM, XC, YC, ZC, V, RAD, RCRIN, LNKUP, LNKDN, LISTF, VOLMIN, RCMX, TOLV)
Definition: RFLU_ModRepair3D.F90:5053
rflu_modrepair3d::angfnd
subroutine angfnd(NUM, IRING, IMIN, IMEET, ITOUCH, X, DX, DY, DZ, DS)
Definition: RFLU_ModRepair3D.F90:6197
v
*********************************************************************Illinois Open Source License ****University of Illinois NCSA **Open Source License University of Illinois All rights reserved ****Developed free of to any person **obtaining a copy of this software and associated documentation to deal with the Software without including without limitation the rights to and or **sell copies of the and to permit persons to whom the **Software is furnished to do subject to the following this list of conditions and the following disclaimers ****Redistributions in binary form must reproduce the above **copyright this list of conditions and the following **disclaimers in the documentation and or other materials **provided with the distribution ****Neither the names of the Center for Simulation of Advanced the University of nor the names of its **contributors may be used to endorse or promote products derived **from this Software without specific prior written permission ****THE SOFTWARE IS PROVIDED AS WITHOUT WARRANTY OF ANY **EXPRESS OR INCLUDING BUT NOT LIMITED TO THE WARRANTIES **OF FITNESS FOR A PARTICULAR PURPOSE AND **NONINFRINGEMENT IN NO EVENT SHALL THE CONTRIBUTORS OR **COPYRIGHT HOLDERS BE LIABLE FOR ANY DAMAGES OR OTHER WHETHER IN AN ACTION OF TORT OR **ARISING OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE **USE OR OTHER DEALINGS WITH THE SOFTWARE v
Definition: roccomf90.h:20
rflu_modrepair3d::cavbnd
subroutine cavbnd(NP, LCONT, NDEL, LDEL, NCNT, X, NDC, NBH, VOL, IFLAG, NFLAG, NFILL, NEWCEL, NTRI, NEWNBH, NOLD, TOLV)
Definition: RFLU_ModRepair3D.F90:3938
rflu_modrepair3d::fangle
subroutine fangle(J, X, NFCE, ANGL1, ANGL2, ANGL3, Q)
Definition: RFLU_ModRepair3D.F90:7039
rflu_modrepair3d
Definition: RFLU_ModRepair3D.F90:55
rflu_modrepair3d::octfnd
subroutine octfnd(NCODE, NCLOSE, XPT, YPT, ZPT, N1, N2, N3, DISMIN, X, NOCTR, NLINK, XFAR, YFAR, ZFAR, IDONE, XOCTR, YOCTR, ZOCTR, XHOLD, YHOLD, ZHOLD, XKEEP, YKEEP, ZKEEP, KSRCH, NSRCH)
Definition: RFLU_ModRepair3D.F90:1537
pi
static const double pi
Definition: smooth_medial.C:43
rflu_modrepair3d::tetang
subroutine tetang(X, NDC, NBH, IPROT, NCELL)
Definition: RFLU_ModRepair3D.F90:7133
rflu_modrepair3d::tetcof
subroutine tetcof(N1, N2, N3, N4, XPT, YPT, ZPT, V1, V2, V3, V4, VTET, X)
Definition: RFLU_ModRepair3D.F90:7229
rflu_modrepair3d::snglar
subroutine snglar(NNODE, X, XD, NCELL, NDC, NBH, SIGMN, SIGMX, SIG1, SIG2, SIG3, CNDMIN, CNDMAX)
Definition: RFLU_ModRepair3D.F90:1998
rflu_modrepair3d::cavity
subroutine cavity(NP, LCONT, NDEL, LDEL, X, NDC, NBH, IPROT, IFLAG, NFLAG, XCEN, YCEN, ZCEN, RC, NFILL, NEWCEL, TOLV)
Definition: RFLU_ModRepair3D.F90:3788
rflu_modrepair3d::radrat
subroutine radrat(X, NNODE, NDC, NBH, IPROT, NCELL, NFCE, NBFACE, ITYP, IPOINT, VOL, RC, RAT)
Definition: RFLU_ModRepair3D.F90:2609
rflu_modrepair3d::input
subroutine input(X, NNODE, NDC, NCELL, NFCE, NBPTS, NBFACE, ITYP, NPROP, XBNDY, XFAR, YFAR, ZFAR)
Definition: RFLU_ModRepair3D.F90:275
rflu_modrepair3d::putpnt
subroutine putpnt(J, NFAIL, X, ITYP, NNODE, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, VOL, XCEN, YCEN, ZCEN, RC, RAT, DENS, NPTET, NACPT, IDONE, NREF, NLINK, NOCTR, IOCTR, XFAR, YFAR, ZFAR, XOCTR, YOCTR, ZOCTR, XHOLD, YHOLD, ZHOLD, XKEEP, YKEEP, ZKEEP, KSRCH, NSRCH, IPOINT, NPOINT, IFLAG, NFLAG, NFILL, NEWCEL, NTRI, NCAV, NSHAKE, NEWNBH, NOLD, NCAVFC, IKEEP, LDEL, NEDGRM, XC, YC, ZC, V, RAD, RCRIN, LNKUP, LNKDN, VOLMIN, RCMX, TOLV)
Definition: RFLU_ModRepair3D.F90:3026
sin
NT & sin
Definition: rational_rotation.h:78
rflu_modrepair3d::edglen
subroutine edglen(X, NNODE, ITYP, NEDGE, NDG, DENS, NVCNT)
Definition: RFLU_ModRepair3D.F90:2392
rflu_modrepair3d::tetmod
subroutine tetmod(X, ITYP, NNODE, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, NFCE, NBFACE, VOL, XCEN, YCEN, ZCEN, RC, RAT, DENS, NPTET, NACPT, SIG1, SIG2, SIG3, NVCNT, RESID, COUNT, FAC, IDONE, NREF, NLINK, NOCTR, IOCTR, XFAR, YFAR, ZFAR, XOCTR, YOCTR, ZOCTR, XHOLD, YHOLD, ZHOLD, XKEEP, YKEEP, ZKEEP, KSRCH, NSRCH, IPOINT, NPOINT, IFLAG, NFLAG, DX, DY, DZ, DS, VLT, IRING, NTETKP, NFAD, NEWC, NBHKP, IEDKP, LNBR, ISHK, MNBR, KSHK, NPP, NFILL, NEWCEL, NTRI, NCAV, NSHAKE, NEWNBH, NOLD, NCAVFC, IKEEP, LDEL, NEDGRM, XC, YC, ZC, V, RAD, RCRIN, LNKUP, LNKDN, LISTF, VOLMIN, RCMX, TOLV)
Definition: RFLU_ModRepair3D.F90:1180
i
blockLoc i
Definition: read.cpp:79
rflu_modrepair3d::neighb
subroutine neighb(L1, N1, N2, N3, L2, K1, K2, NDC, NBH)
Definition: RFLU_ModRepair3D.F90:6597
rflu_modrepair3d::circum
subroutine circum(X, N1, N2, N3, N4, XCN, YCN, ZCN, VTET, RCIR, IFLAG, TOL)
Definition: RFLU_ModRepair3D.F90:6421
x
void int int REAL * x
Definition: read.cpp:74
rflu_modrepair3d::lock
subroutine lock(L1, L2, N1, N2, N3, N4, N5, K1, K2, NDC, NBH)
Definition: RFLU_ModRepair3D.F90:6679
rflu_modrepair3d::cavedg
subroutine cavedg(NCNT, NEDG, IPOINT, NPOINT, NTRI, NCAV, NEWNBH, NEWCEL)
Definition: RFLU_ModRepair3D.F90:4334
Rocblas::div
static void div(const Attribute *x, const Attribute *y, Attribute *z)
Operation wrapper for division.
Definition: op3args.C:269
n
const NT & n
Definition: rational_rotation.h:72
rflu_modrepair3d::octrmv
subroutine octrmv(N, X, NOCTR, NLINK, IDONE, NREF)
Definition: RFLU_ModRepair3D.F90:1782
rflu_modrepair3d::struct
subroutine struct(X, NNODE, NDC, NBH, IPROT, NCELL, NFCE, NBFACE, NEDGE, NDG, IDGP, NDGP, IPOINT, NPOINT, NPTET, XCEN, YCEN, ZCEN, VOL, RC, RAT, XFAR, YFAR, ZFAR, IOCTR, NLINK, NOCTR, IDONE, NREF, VOLMIN, RCMX)
Definition: RFLU_ModRepair3D.F90:496
rflu_modrepair3d::tetloc
subroutine tetloc(NP, NCLOSE, LBRK, LCONT, NFAIL, X, NDC, NBH, IPROT, DENS, VOL, IFLAG, NFLAG, NFILL, NEWCEL, TOLV)
Definition: RFLU_ModRepair3D.F90:3540
rflu_modrepair3d::tree
subroutine tree(PROP, NLEFT, NRIGHT, NBACK, LISTF, NACPT, NTOT, NBH, IPROT, NCELL)
Definition: RFLU_ModRepair3D.F90:1897
rflu_modrepair3d::volcom
subroutine volcom(L, NPT, VDIFF, NCONT, X, NDC)
Definition: RFLU_ModRepair3D.F90:7288
Direction_3::dz
RT dz() const
Definition: Direction_3.h:133
min
Vector_n min(const Array_n_const &v1, const Array_n_const &v2)
Definition: Vector_n.h:346
rflu_modrepair3d::cofact
double precision function cofact(A1, A2, A3, B1, B2, B3)
Definition: RFLU_ModRepair3D.F90:7381
j
j indices j
Definition: Indexing.h:6
dy
NT dy
Definition: rational_rotation.h:82
q
NT q
Definition: rational_rotation.h:105
rflu_modrepair3d::replace
subroutine replace(N1, N2, NA, NB, J, NRING, NPASS, NFAIL, X, DENS, ITYP, NNODE, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, IPOINT, NPOINT, VOL, XCEN, YCEN, ZCEN, RC, RAT, NPTET, NACPT, NOCTR, IOCTR, NLINK, NREF, XFAR, YFAR, ZFAR, IRING, NTETKP, LNBR, ISHK, MNBR, KSHK, NFAD, NBHKP, IEDKP, NEWC, DX, DY, DZ, DS, NP, VLT, TOLV)
Definition: RFLU_ModRepair3D.F90:5314
rflu_modrepair3d::tetar
double precision function tetar(L, X, NDC)
Definition: RFLU_ModRepair3D.F90:6886
rflu_modrepair3d::circum2
subroutine circum2(X, N1, N2, N3, XPT, YPT, ZPT, XCN, YCN, ZCN, VTET, RCIR, IFLAG, TOL)
Definition: RFLU_ModRepair3D.F90:6507
rflu_modrepair3d::octfil
subroutine octfil(N, X, NOCTR, IOCTR, NLINK, NREF, XFAR, YFAR, ZFAR)
Definition: RFLU_ModRepair3D.F90:1333
Element_node_enumerator::next
void next()
Go to the next element within the connectivity tables of a pane.
Definition: Element_accessors.C:79
nj
void int * nj
Definition: read.cpp:74
dist
long double dist(long double *coord1, long double *coord2, int size)
Definition: utilities/rc_cmp/util.cpp:305
rflu_modrepair3d::datsrf
subroutine datsrf(NP, NCNT, NEDG, NDG, IDGP, NDGP, NEDGE, IPOINT, NCAV, NEDGRM, IEDGRM)
Definition: RFLU_ModRepair3D.F90:4436
cos
NT & cos
Definition: rational_rotation.h:79
Pane::insert
void insert(Attribute *attr)
Insert an attribute onto the pane.
Definition: Pane.C:224
rflu_modrepair3d::coarsn
subroutine coarsn(LC, X, NNODE, NDC, NBH, IPROT, NCELL, ITYP, XCEN, YCEN, ZCEN, VOL, RC, RAT, NVCNT, DENS, IFLAG, NFLAG, NPTET, NEDGE, NDG, IDGP, NDGP, NOCTR, IOCTR, NLINK, XFAR, YFAR, ZFAR, IDONE, NREF, FAC, SIG1, SIG2, SIG3, KSRCH, NSRCH, IRING, NTETKP, LNBR, ISHK, MNBR, KSHK, TOLV)
Definition: RFLU_ModRepair3D.F90:2472
rflu_modrepair3d::triswp
subroutine triswp(NPT, N1, N2, N3, J, NFAIL, X, NDC, NBH, IPROT, NCELL, NDG, IDGP, NDGP, NEDGE, VOL, XCEN, YCEN, ZCEN, RC, RAT, NPTET, NACPT, TOLV)
Definition: RFLU_ModRepair3D.F90:5783
cimg_library::CImg::atan2
CImg< T > & atan2(const CImg< t > &img)
Compute the arc-tangent of each pixel.
Definition: CImg.h:12671
rflu_modrepair3d::recon
subroutine recon(LDEL, NDEL, NCNT, NDC, NBH, IPROT, NDG, IDGP, NDGP, NFLAG, NTRI, NCAVFC, IKEEP, NEDGRM, IEDGRM)
Definition: RFLU_ModRepair3D.F90:4151
Mesh::GenericCell_2::nvert
IndexType nvert() const
Definition: Mesh.H:565
rflu_modrepair3d::edgerm
subroutine edgerm(NEDG, NDG, IDGP, NDGP)
Definition: RFLU_ModRepair3D.F90:1839
rflu_modrepair3d::tetar3
double precision function tetar3(M1, M2, M3, XPT, YPT, ZPT, X)
Definition: RFLU_ModRepair3D.F90:6986