polyhedr.F File Reference

#include "implicit_f.inc"

Go to the source code of this file.

Functions/Subroutines
subroutine	polyhedr (ipoly, rpoly, polb, npolb, polh, npolh, nrpmax, nphmax, ibric, lmin, info, npolhmax, nppmax)

Function/Subroutine Documentation

polyhedr()

subroutine polyhedr	(	integer, dimension(6+nppmax,*)	ipoly,
			rpoly,
		integer, dimension(*)	polb,
		integer	npolb,
		integer, dimension(nphmax+2,*)	polh,
		integer	npolh,
		integer	nrpmax,
		integer	nphmax,
		integer	ibric,
			lmin,
		integer	info,
		integer	npolhmax,
		integer	nppmax )

Definition at line 28 of file polyhedr.F.

C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NPPMAX, IPOLY(6+NPPMAX,*), POLB(*), NPOLB, NPHMAX, 
     .        POLH(NPHMAX+2,*),NPOLH, NRPMAX, IBRIC, INFO, NPOLHMAX
      my_real
     .        rpoly(nrpmax,*), lmin
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER I, ITAG(NPOLB), ICMAX, ICUR, II, J, JJ, K, KK, ISTOP,
     .        L, LL, ICUR_OLD, ITY, JMIN, PMIN, POLD
      my_real
     .        x1, y1, z1, x2, y2, z2, xx1, yy1, zz1, xx2, yy2, zz2,
     .        dd11, dd12, dd21, dd22, tole
C
      my_real
     .        dlamch_rd
      EXTERNAL dlamch_rd
C
      tole=epsilon(zero)*0.5*lmin*lmin
C
      DO i=1,npolb
         itag(i)=0
      ENDDO
C
      icmax=0
      DO i=1,npolb
         IF (itag(i)==0) THEN
            icmax=icmax+1
            itag(i)=icmax
            icur=icmax
         ELSE
            icur=itag(i)
         ENDIF
         ii=polb(i)
         DO j=1,ipoly(2,ii)
            IF (j/=ipoly(2,ii)) THEN
               jj=j+1
            ELSE
               jj=1
            ENDIF
            x1=rpoly(4+3*(j-1)+1,ii)
            y1=rpoly(4+3*(j-1)+2,ii)
            z1=rpoly(4+3*(j-1)+3,ii)
            x2=rpoly(4+3*(jj-1)+1,ii)
            y2=rpoly(4+3*(jj-1)+2,ii)
            z2=rpoly(4+3*(jj-1)+3,ii)
            DO k=1,npolb
               IF (k==i) cycle
               kk=polb(k)
               istop=0
               l=0
               DO WHILE (istop==0.AND.l<ipoly(2,kk))
                  l=l+1
                  IF (l/=ipoly(2,kk)) THEN
                     ll=l+1
                  ELSE
                     ll=1
                  ENDIF
                  xx1=rpoly(4+3*(l-1)+1,kk)
                  yy1=rpoly(4+3*(l-1)+2,kk)
                  zz1=rpoly(4+3*(l-1)+3,kk)
                  xx2=rpoly(4+3*(ll-1)+1,kk)
                  yy2=rpoly(4+3*(ll-1)+2,kk)
                  zz2=rpoly(4+3*(ll-1)+3,kk)
                  dd11=(xx1-x1)**2+(yy1-y1)**2+(zz1-z1)**2
                  dd21=(xx2-x1)**2+(yy2-y1)**2+(zz2-z1)**2
                  dd12=(xx1-x2)**2+(yy1-y2)**2+(zz1-z2)**2
                  dd22=(xx2-x2)**2+(yy2-y2)**2+(zz2-z2)**2
                  IF ((dd11<=tole.AND.dd22<=tole).OR.
     .                (dd21<=tole.AND.dd12<=tole)) istop=l
               ENDDO
               IF (istop/=0) THEN
                  IF (itag(k)==0) THEN
                     itag(k)=icur
                  ELSE
                     icur_old=icur
                     icur=itag(k)
                     DO l=1,npolb
                        IF (itag(l)==icur_old) itag(l)=icur
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
      ENDDO
C
      npolh=0
      DO i=1,icmax
         ii=0
         DO j=1,npolb
            IF (itag(j)==i) ii=ii+1
         ENDDO
         IF (ii/=0) npolh=npolh+1
      ENDDO
      IF (npolh>npolhmax) THEN
         info=1
         npolhmax=npolh
         RETURN
      ENDIF
C
      npolh=0
      DO i=1,icmax
         ii=0
         DO j=1,npolb
            IF (itag(j)==i) ii=ii+1
         ENDDO
         IF (ii/=0) THEN
            npolh=npolh+1
            polh(1,npolh)=ii
            polh(2,npolh)=ibric
            ii=0
            DO j=1,npolb
               IF (itag(j)==i) THEN
                  ii=ii+1
                  jj=polb(j)
                  polh(2+ii,npolh)=jj
                  ity=ipoly(1,jj)
                  IF (ity==1) THEN
                     ipoly(5,jj)=npolh
                     cycle
                  ENDIF
                  IF (ipoly(5,jj)==0) THEN
                     ipoly(5,jj)=npolh
                  ELSE
                     ipoly(6,jj)=npolh
                  ENDIF
               ENDIF
            ENDDO
C Tri par ordre croissant de polh
            DO j=1,polh(1,npolh)
               jmin=j
               pmin=polh(2+j,npolh)
               DO k=j+1,polh(1,npolh)
                  IF (polh(2+k,npolh)<pmin) THEN
                     jmin=k
                     pmin=polh(2+k,npolh)
                  ENDIF
               ENDDO
               pold=polh(2+j,npolh)
               polh(2+j,npolh)=pmin
               polh(2+jmin,npolh)=pold
            ENDDO
         ENDIF
      ENDDO
C
      info=0
      RETURN