Sources Esope | Cast3M

dyvois
C DYVOIS    SOURCE    BP208322  20/09/18    21:16:28     10718          
        SUBROUTINE  DYVOIS(IPALB,IPLIB,XPALB,XPTB,IND,I,NLIAB,NPLB,
     &                  ILOCAL,IROLE)
      IMPLICIT INTEGER(I-N)
        IMPLICIT REAL*8(A-H,O-Z)
*-----------------------------------------------------------------------*
*                                                                       *
*     Opérateur DYNE : algorithme de Fu - de Vogelaere                  *
*     ________________________________________________                  *
*                                                                       *
*       Pour la liaison Ligne_Ligne ,ligne_cercle                       *
*     Donne le noeud du maillage maitre ,le plus proche de chaque  ,    *
*       point esclave                                                   *
*                                                                       *
*     Paramètres                                                        *
*                                                                       *
* e   IPALB   Renseigne sur la liaison.                                 *
* e   IPLIB   Tableau contenant les numéros "DYNE" de la liaison.       *
* e   XPALB   Tableau contenant les paramètres de la liaison.           *                                                       *
* e   XPTB    Tableau des d{placements des points                       *
* e   NLIAB   Nombre de liaisons sur la base B.                         *
* e   NPLB    Nombre total de points intervenant dans les liaisons.     *
* e   IND     Indice du pas.                                            *
* e   I       numéro de la liaison.                                     *
* e   ILOCAL  Indicateur d'une recherche locale (0) ou globale (1) sur  *
*             les noeuds du maillage.                                   *
* e   IROLE   Indique quel est le maillage maitre et le maillage        *
*             esclave                                                   *
*                                                                       *
*                                                                       *
*     Auteur, date de création:                                         *
*                                                                       *
*     Samuel DURAND      : le 08 Aout 1996 : Création                   *
*      Ibrahim Pinto, 05/97 , liaisons ligne_cercle                     *
*-----------------------------------------------------------------------*
*************************************************************************
*                                                                       *
        INTEGER IPALB(NLIAB,*),IPLIB(NLIAB,*)
        REAL*8  XPTB(NPLB,2,*),XPALB(NLIAB,*)
        REAL*8  XPCOM(3),XPCOB(3)
 
*
        ITYP = IPALB(I,1)
        IDIM = IPALB(I,3)
        IF (ITYP.EQ.35 .OR. ITYP.EQ.37 .OR. ITYP.EQ.39) THEN
           ID1 = 6
        ELSE
           ID1 = 7
        ENDIF
        IF (IROLE.EQ.0) THEN
           KMAI = 0
           IMAI = ID1 +4*IDIM
           IBUT = IMAI + (IPALB(I,21))*IDIM
           NNOEMA = IPALB(I,21)
           NNOEES = IPALB(I,22)
           IFERMA = IPALB(I,24)
           KBUT = IPALB(I,21)
           JVOI = 26
        ELSE
           KMAI = IPALB(I,21)
           IBUT = ID1 + 4*IDIM
           IMAI = IBUT + (IPALB(I,21))*IDIM
           NNOEMA = IPALB(I,22)
           NNOEES = IPALB(I,21)
           IFERMA = IPALB(I,25)
           KBUT = 0
           JVOI = 26+IPALB(I,22)
        ENDIF
*
        IF (ILOCAL.EQ.0) THEN
*
         DO 100 IESC=1,NNOEES
*
           IDESC = IBUT+(IESC-1)*IDIM
           IFMOIN = 1
           IFPLUS = 1
*   Recherche locale
           IM = IPALB(I,JVOI+IESC)
           XPOS = 0.D0
           DO 400 ID=1,IDIM
                IDM = IMAI + (IM-1)*IDIM + ID
                XPCOM(ID) = XPALB(I,IDM) +XPTB(IPLIB(I,KMAI+IM),1,ID)
           XPCOB(ID) = XPALB(I,IDESC+ID)+XPTB(IPLIB(I,KBUT+IESC),1,ID)
                XPOS = XPOS +(XPCOM(ID)-XPCOB(ID))*(XPCOM(ID)-XPCOB(ID))
 400       CONTINUE
           XPOS = SQRT(XPOS)
           XREF = XPOS
           IREF = IM
           IPLUS = IM+1
           IMOIN = IM-1
 410       CONTINUE
                IF (IMOIN.EQ.0) THEN
                    IF (IFERMA.EQ.0) THEN
                        IFMOIN = 0
                    ELSE
                        IMOIN = NNOEMA
                    ENDIF
                ENDIF
                IF (IPLUS.EQ.(NNOEMA+1)) THEN
                    IF (IFERMA.EQ.0) THEN
                        IFPLUS = 0
                    ELSE
                        IPLUS = 1
                    ENDIF
                ENDIF
                IF (IFMOIN.NE.0) THEN
                   XPOS = 0.D0
                   DO 412 ID=1,IDIM
                        IDL = IMAI + (IMOIN-1)*IDIM + ID
                        XPCOM(ID) = XPALB(I,IDL)
     &+XPTB(IPLIB(I,KMAI+IMOIN),1,ID)
                        XPCOB(ID) = XPALB(I,IDESC+ID)
     &+XPTB(IPLIB(I,KBUT+IESC),1,ID)
                        XPOS = XPOS +(XPCOM(ID)-XPCOB(ID))*
     &(XPCOM(ID)-XPCOB(ID))
 412                    CONTINUE
                   XPOS = SQRT(XPOS)
                        IF (XPOS.LT.XREF) THEN
                            XREF = XPOS
                            IREF = IMOIN
                            IMOIN = IMOIN-1
                        ELSE
                            IFMOIN = 0
                        ENDIF
                ENDIF
                IF (IFPLUS.NE.0) THEN
                   XPOS = 0.D0
                   DO 414 ID=1,IDIM
                        IDN = IMAI + (IPLUS-1)*IDIM + ID
                        XPCOM(ID) = XPALB(I,IDN)
     &+XPTB(IPLIB(I,KMAI+IPLUS),1,ID)
                        XPCOB(ID) = XPALB(I,IDESC+ID)
     &+XPTB(IPLIB(I,KBUT+IESC),1,ID)
                        XPOS = XPOS +(XPCOM(ID)-XPCOB(ID))*
     &(XPCOM(ID)-XPCOB(ID))
 414                    CONTINUE
                   XPOS = SQRT(XPOS)
                        IF (XPOS.LT.XREF) THEN
                            XREF = XPOS
                            IREF = IPLUS
                            IPLUS = IPLUS+1
                        ELSE
                            IFPLUS = 0
                        ENDIF
                ENDIF
                IF ((IFMOIN.EQ.0).AND.(IFPLUS.EQ.0)) GOTO 420
                GOTO 410
 420            CONTINUE
                IPALB(I,JVOI+IESC) = IREF
*
 100       CONTINUE
        ELSE
          DO 200 IESC=1,NNOEES
*   Recherche globale
           XPOS = 0.D0
*   Premier noeud du maillage
           IDESC = IBUT+(IESC-1)*IDIM
           DO 422 ID=1,IDIM
                IDM = IMAI + ID
                XPCOM(ID) = XPALB(I,IDM) +XPTB(IPLIB(I,KMAI+1),1,ID)
           XPCOB(ID) = XPALB(I,IDESC+ID)+XPTB(IPLIB(I,KBUT+IESC),1,ID)
                XPOS = XPOS +(XPCOM(ID)-XPCOB(ID))*(XPCOM(ID)-XPCOB(ID))
 422       CONTINUE
           XREF = XPOS
           IREF = 1
           DO 424 IM=2,NNOEMA
                XPOS = 0.D0
                DO 426 ID=1,IDIM
                   IDM = IMAI + (IM-1)*IDIM + ID
                   XPCOM(ID) = XPALB(I,IDM) +XPTB(IPLIB(I,KMAI+IM),1,ID)
                   XPCOB(ID) = XPALB(I,IDESC+ID)
     &+XPTB(IPLIB(I,KBUT+IESC),1,ID)
                   XPOS = XPOS +(XPCOM(ID)-XPCOB(ID))*
     &(XPCOM(ID)-XPCOB(ID))
 426               CONTINUE
                XPOS = SQRT(XPOS)
                IF (XPOS.LT.XREF) THEN
                   XREF = XPOS
                   IREF = IM
                ENDIF
 424       CONTINUE
           IPALB(I,JVOI+IESC) = IREF
 200      CONTINUE
        ENDIF
*
 
      END