frmset.f

Go to the documentation of this file.
00001 C:\opentelemac\v7p0\sources\tomawac\frmset.f
00002 !
00050                         SUBROUTINE FRMSET
00051 !                       *****************
00052 !
00053      &( X     , Y     , NEIGB , NB_CLOSE, NPOIN2,MAXNSP, NRD, NELEM2,
00054      &  IKLE  , RK    , RX    , RY    , RXX   , RYY )
00055 !
00056 !***********************************************************************
00057 ! TOMAWAC   V6P2                                   25/06/2012
00058 !***********************************************************************
00059 !
00060 !
00061 !
00062 !
00063 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00064 !| IKLE           |-->| TRANSITION BETWEEN LOCAL AND GLOBAL NUMBERING
00065 !|                |   | OF THE 2D MESH
00066 !| MAXNSP         |-->| CONSTANT FOR MESHFREE TECHNIQUE
00067 !| NB_CLOSE       |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00068 !| NEIGB          |<->| NEIGHBOUR POINTS FOR MESHFREE METHOD
00069 !| NELEM2         |-->| NUMBER OF ELEMENTS IN 2D MESH
00070 !| NPOIN2         |-->| NUMBER OF POINTS IN 2D MESH
00071 !| NRD            |-->| CONSTANT FOR MESHFREE TECHNIQUE
00072 !| RK             |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00073 !| RX             |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00074 !| RXX            |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00075 !| RY             |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00076 !| RYY            |<->| ARRAY USED IN THE MESHFREE TECHNIQUE
00077 !| X              |-->| ABSCISSAE OF POINTS IN THE MESH
00078 !| Y              |-->| ORDINATES OF POINTS IN THE MESH
00079 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00080 !
00081       IMPLICIT NONE
00082 !
00083       INTEGER LNG,LU
00084       COMMON/INFO/LNG,LU
00085 
00086 !.....VARIABLES IN ARGUMENT
00087 !     """"""""""""""""""""
00088       INTEGER NPOIN2, MAXNSP, NRD, NELEM2
00089       INTEGER NB_CLOSE(NPOIN2), NEIGB(NPOIN2,MAXNSP)
00090       INTEGER IKLE(NELEM2,3)
00091       DOUBLE PRECISION X(NPOIN2), Y(NPOIN2)
00092       DOUBLE PRECISION RK(MAXNSP,NPOIN2)
00093       DOUBLE PRECISION RX(MAXNSP,NPOIN2), RY(MAXNSP,NPOIN2)
00094       DOUBLE PRECISION RXX(MAXNSP,NPOIN2),RYY(MAXNSP,NPOIN2)
00095 !
00096 !.....LOCAL VARIABLES
00097 !     """""""""""""""
00098       INTEGER IP, IPOIN, IP2, I
00099       INTEGER ICLM, J, IELEM,ILM
00100       INTEGER M, ICST, ICST2, NCST, IP_S, ILP, L(2)
00101       DOUBLE PRECISION AC,QUO,RAD1
00102       INTEGER,ALLOCATABLE:: ILM_POIN(:,:), CLM(:), KACC(:)
00103       INTEGER,ALLOCATABLE:: NB_C(:), SUR_P(:,:)
00104       INTEGER,ALLOCATABLE:: STACK(:), STACK2(:)
00105       LOGICAL,ALLOCATABLE:: ALREADY_POM(:)
00106       DOUBLE PRECISION,ALLOCATABLE:: MINDIST(:)
00107 
00108       LOGICAL DEJA
00109       DATA DEJA/.FALSE./
00110 
00111       SAVE
00112 !
00113 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
00114 !
00115       IF(.NOT.DEJA)THEN
00116         ALLOCATE(ILM_POIN(NPOIN2,8))
00117         ALLOCATE(CLM(NPOIN2))
00118         ALLOCATE(KACC(NPOIN2))
00119         ALLOCATE(NB_C(NPOIN2))
00120         ALLOCATE(SUR_P(NPOIN2,8))
00121         ALLOCATE(STACK(NPOIN2))
00122         ALLOCATE(STACK2(NPOIN2))
00123         ALLOCATE(ALREADY_POM(NPOIN2))
00124         ALLOCATE(MINDIST(NPOIN2))
00125         DEJA=.TRUE.
00126       ENDIF
00127 !
00128 ! ILM_POIN array with the elements to which a point belongs
00129 ! CLM(IP) array with the number of elements for each point
00130 !  for IP belong to the elements  ILM_POIN(CLM(IP-1)+1:CLM(IP))
00131 !
00132       DO IPOIN =1, NPOIN2
00133         ICLM=0
00134         DO  IELEM=1,NELEM2
00135           IF (IPOIN.EQ.IKLE(IELEM,1)) THEN
00136             ICLM=ICLM+1
00137             ILM_POIN(IPOIN,ICLM)=IELEM
00138           ELSEIF (IPOIN.EQ.IKLE(IELEM,2)) THEN
00139             ICLM=ICLM+1
00140             ILM_POIN(IPOIN,ICLM)=IELEM
00141           ELSEIF (IPOIN.EQ.IKLE(IELEM,3)) THEN
00142             ICLM=ICLM+1
00143             ILM_POIN(IPOIN,ICLM)=IELEM
00144           ENDIF
00145         ENDDO
00146         CLM(IPOIN)=ICLM
00147         IF(CLM(IPOIN).GT.8) WRITE(6,*) '**** OUPS ', IPOIN,CLM(IPOIN)
00148       ENDDO
00149 !
00150 ! searching for the points which are around the point IPOIN
00151 ! and add the to a look up array SUR_P(IPOIN,NB_C(IPOIN))
00152 !
00153 !    Initialize all the arrays  and logics for the new subdomain
00154       DO IP=1,NPOIN2
00155         ALREADY_POM(IP) =.FALSE.
00156       ENDDO
00157 !
00158       DO IPOIN=1,NPOIN2
00159         NB_C(IPOIN)=0
00160         MINDIST(IPOIN)=1.E+6
00161         DO ILM=1,CLM(IPOIN)
00162           IELEM=ILM_POIN(IPOIN,ILM)
00163 !         loop over 3 nodes of each triangle
00164           DO J=1,3
00165 !           test if the selected node belongs to the triangle
00166             IF (IKLE(IELEM,J).EQ.IPOIN) THEN
00167               IF (J.EQ.1) THEN
00168                 L(1)=IKLE(IELEM,2)
00169                 L(2)=IKLE(IELEM,3)
00170               ENDIF
00171               IF (J.EQ.2) THEN
00172                 L(1)=IKLE(IELEM,1)
00173                 L(2)=IKLE(IELEM,3)
00174               ENDIF
00175               IF (J.EQ.3) THEN
00176                 L(1)=IKLE(IELEM,1)
00177                 L(2)=IKLE(IELEM,2)
00178               ENDIF
00179             ENDIF
00180           ENDDO
00181 !
00182           DO M=1,2
00183             IF (.NOT.ALREADY_POM(L(M))) THEN
00184               NB_C(IPOIN)=NB_C(IPOIN)+1
00185               SUR_P(IPOIN,NB_C(IPOIN)) =L(M)
00186               ALREADY_POM(L(M)) =.TRUE.
00187             ENDIF
00188           ENDDO
00189 !
00190         ENDDO
00191 !
00192 !   CALCULATE DISTANCE of EVERY POINT TO THE NEIGHBOUR POINTS
00193         DO J=1,NB_C(IPOIN)
00194           IP=SUR_P(IPOIN,J)
00195           RAD1=SQRT((X(IP)-X(IPOIN))**2+(Y(IP)-Y(IPOIN))**2)
00196           IF(RAD1.LE.MINDIST(IPOIN)) MINDIST(IPOIN)=RAD1
00197           ALREADY_POM(IP) =.FALSE.
00198         ENDDO
00199 
00200       ENDDO
00201 !
00202 ! make the subdomain search over the nearest point of each point and
00203 !  add them in the NEIGB(IPOIN,MAXNSP) aray
00204       DO IPOIN=1,NPOIN2
00205         NB_CLOSE(IPOIN)=1
00206         NEIGB(IPOIN,1) =IPOIN
00207         ALREADY_POM(IPOIN) =.TRUE.
00208         NCST=1
00209         STACK(NCST)=IPOIN
00210 !       WRITE(6,*) (SUR_P(STACK(NCST),j),j=1,7)
00211 !
00212 ! ipoin is the main point of domain ipoin
00213 ! around the ipoin do a search in the elements it belongs
00214 ! loop around the point of Stack and do what you did before
00215 !
00216 ! while loop
00217         DO
00218           ICST2=0
00219           DO ICST =1,NCST
00220             IP= STACK(ICST)
00221 
00222             DO ILP=1,NB_C(IP)
00223               IP_S=SUR_P(IP,ILP)
00224               IF (.NOT.ALREADY_POM(IP_S)) THEN
00225                 NB_CLOSE(IPOIN)=NB_CLOSE(IPOIN)+1
00226                 NEIGB(IPOIN,NB_CLOSE(IPOIN)) =IP_S
00227                 ALREADY_POM(IP_S) =.TRUE.
00228                 IF(NB_CLOSE(IPOIN).GE.NRD) GOTO 222
00229                 ICST2=ICST2+1
00230                 STACK2(ICST2)=IP_S
00231               ENDIF
00232             ENDDO ! ILP
00233           ENDDO ! ICST
00234           NCST=ICST2
00235           STACK=STACK2
00236         ENDDO
00237 222   CONTINUE
00238 ! end of while loop
00239 !
00240 !subdomain (Ipoin) finish after initializing
00241 ! logic goto to the next subdomain
00242         DO J=1,NB_CLOSE(IPOIN)! initialize already for points logic
00243           IP2=NEIGB(IPOIN,J)
00244           ALREADY_POM(IP2) =.FALSE. ! initialize already for points logic
00245         ENDDO
00246       ENDDO  !1,NPOIN2
00247 !
00248 ! CALCULATE THE RADIAL FUNCTION OF RPI
00249 ! AND INVERSE MATRICES OF EACH SUB DOMAIN
00250 !
00251       QUO = 1.03D0
00252       AC = 8.D0
00253       DO I=1,NPOIN2
00254         CALL RPI_INVR(X, Y, NEIGB, NB_CLOSE,
00255      &     RK(1,I), RX(1,I), RY(1,I), RXX(1,I), RYY(1,I),
00256      &     NPOIN2, I, QUO, AC, MAXNSP, MINDIST)
00257 !
00258       ENDDO
00259 !
00260       RETURN
00261       END

Generated on Fri Aug 31 2013 18:12:58 by S.E.Bourban (HRW) using doxygen 1.7.0