Sources Esope | Cast3M

blocos
C BLOCOS    SOURCE    PV        22/04/22    21:15:01     11344          
C     **********************************************************************
C     FICHIER  : BLOCOS.F
C
C           MAILLAGE D'UN DOMAINE DE 4 COTES
C
C     OBJET    :
C
C     OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
C     OBJET          LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
C     OBJET Q4CRGR : MAILLAGE EN GRILLE A PARTIR DE 4 COTES
C     OBJET          (MEME CARDINAUX SUR LES COTES OPPOSES).
C
C
C     AUTEUR   : O. STAB
C     DATE     : 06.96
C     MODIFICATIONS :
C        AUTEUR, DATE, OBJET :
C
C
C     **********************************************************************
C
C
      SUBROUTINE BLOCOS(IPOLY,N,
     >      COORD,IDIMC,NBCOOR,
     >      NBLIG,NBCOL,ICOIN,
     >      ITVL,NITMAX,
     >      IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
     >      NBE,NBP,NBEMAX,NBPMAX,
     >      ICOMPR,ILISS,EPSLIS,W,
     >      ITRACE,IERCOD,iarr)
C     **********************************************************************
C     OBJET BLOCOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
C     OBJET          LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
C
C     EN ENTREE   :
C       ------------- MAILLAGE LINEIQUE ------------
C       IPOLY    : TABLEAU DES NOEUDS DU CONTOUR FERME
C       N        : N(I) NOMBRE D'ELEMENTS SUR LE COTES I
C                  N(I) DOIVENT ETRE STRICTEMENT POSITIF
C                  LEUR SOMME DOIT ETRE PAIR.
C       COORD    : TABLEAU DES COORDONNEES DES POINTS
C       IDIMC    : DIMENSION DE L'ESPACE (>= 2)
C       ------------- TABLEAU DE TRAVAIL ------------
C       ITVL     : TABLEAU D'ENTIERS POUR LES CALCULS
C                T1 =  2*(NBCOL+NBLIG) POUR LE CONTOUR
C                T2 = (NBCOL*NBLIG)   POUR LA GRILLE
C                T3 = (NBLIG*NBCOL)*6 POUR LA STRUCTURE
C                ITVL >= T1+T3
C       NITMAX   : TAILLE DE ITVL
C                  SI NBEMAX = 0 NITMAX PEUT ETRE NUL
C                  SINON NITMAX >= T1+T3
c
C       NBNMAX   : NOMBRE DE NOEUDS PAR ELEMENT (>=4)
C       NBCMAX   : NOMBRE DE VOISINS A UN ELEMENT (>=4)
C       ------------- TAILLE DES TABLEAU DE SORTIE ------------
C       NBEMAX   : NOMBRE MAXIMUM D'ELEMENTS
C                  SI NBEMAX = 0 LE MAILLAGE N'EST PAS CALCULE
C                  SEULES LES INFORMATIONS SUR LA GRILLE SONT DONNEES
C                  SINON NBEMAX >= (NBLIG-1)*(NBCOL-1)
C       NBPMAX   : NOMBRE MAXIMUM DE POINTS
C                  NBPMAX >= NBLIG*NBCOL
C
C       ITRNOE : TAILLE >= NBEMAX*NBNMAX
C       ITRTRI : TAILLE >= NBEMAX*NBCMAX
C       NOETRI : TAILLE >= NBPMAX
C       COORD  : TAILLE >= NBPMAX*IDIMC
C
C       ------------- PARAMETRES DE POSTTRAITEMENT ------------
C       ICOMPR : ICOMPR = 1, COMPRESSION ACTIVE
C       ILISS  : LISSAGE DES NOEUDS INTERIEURS ACTIF
C       EPSLIS : DEPLACEMENT NEGLIGEABLE
C       W      : COEFFICIENT DE RIGIDITE DES ELEMENTS QUADRANGULAIRES
C                [0,1] (LISSAGE DE HERRMANN)
C
C     EN SORTIE   :
C       ------------- INFORMATIONS SUR LA GRILLE -----------
C       NBLIG, NBCOL, ICOIN : NOMBRE DE LIGNE ET NOMBRE DE COLONNES DE
C                 LA GRILLE AVEC LES VALEURS DES COUPER-COLLER AUX COINS.
C       ------------- LE MAILLAGE --------------------------
C       IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE,NBP : LE MAILLAGE
C                  EN QUADRANGLES LINEAIRES
C       COORD    : TABLEAU DES COORDONNEES DES POINTS (COMPLETE)
C       iarr     : TYPE D'ERREUR
C                  -1 SI DONNEES INCORRECTES
C                  -2 SI TABLEAUX INSUFFISANTS(COORD,ITRNOE OU ITVL)
C       IERCOD : CODE DETAILLE DE L'ERREUR
C         -100 : ERREUR NON REPERTORIEE
C         -101 : LE NOMBRE DE NOEUDS SUR LE CONTOUR EST IMPAIR
C         -102 : LA DIMENSION DES COORDONNEES EST INCORRECTE
C         -103 : LE CONTOUR N A PAS 4 COTES
C     APPELS : Q4CRGR
C     **********************************************************************
      IMPLICIT INTEGER(I-N)
      INTEGER IPOLY(*),N(*)
      REAL*8    COORD(*)
      INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
      INTEGER NBLIG,NBCOL,ICOIN(*)
      INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX
      INTEGER NBEMAX,NBPMAX,NBE,NBP
      INTEGER ICOMPR,ILISS
      REAL*8    EPSLIS,W
      INTEGER ITRACE,IERCOD,iarr
C
C     --- VARIABLES INTERNES ---
      INTEGER I,ICOURF,IND(4),NBEL2
      integer ibid(1)
C
      INTEGER INDICE,INCREM
      INTEGER NBCOAJ(2),INCOAJ(2),NBAJ
      INTEGER INDXYZ,ITRAV,NITMX2
      INTEGER ITBLOQ,IPARA,NPASMX,NCC,NBENUL,NBISOL
      REAL*8    RELAX,RTRAV(3)
C        =============================
C     --- 0. VERIFICATION DES ENTREES ---
C        =============================
      IERCOD = -100
      NBE = 0
      NBP = 0
      NBLIG = 0
      NBCOL = 0
      DO 5 I=1,4
        ICOIN(I) = 0
    5 CONTINUE
C
      IF( (N(1).LT.1).OR.(N(2).LT.1).OR.
     >    (N(3).LT.1).OR.(N(4).LT.1))THEN
        IERCOD = -103
        iarr = -1
        GOTO 9999
        ENDIF
      IF( MOD(N(1)+N(2)+N(3)+N(4),2) .NE.0 )THEN
        IERCOD = -101
        iarr = -1
        GOTO 9999
      ENDIF
      IF( IDIMC.LT.0 )THEN
        IERCOD = -102
        iarr = -1
        GOTO 9999
      ENDIF
C
C        ===========================
C     --- 0. ON DETERMINE LA MEMOIRE ---
C        ===========================
C
      CALL G2NBKK(N(1),N(2),N(3),N(4),
     >            ICOIN(1),ICOIN(2),ICOIN(3),ICOIN(4),iarr)
      IF( iarr.NE. 0 )GOTO 9999
C
      NBLIG = MAX(N(4)+ICOIN(4)+ICOIN(3),N(2)+ICOIN(2)+ICOIN(1)) + 1
      NBCOL = MAX(ICOIN(4)+N(1)+ICOIN(1),ICOIN(2)+N(3)+ICOIN(3)) + 1
      NBE = (NBLIG-1)*(NBCOL-1)
      NBP = NBCOL*NBLIG
C
      IF(NBEMAX.EQ.0)GOTO 9999
C
      IF(NBEMAX.LT.NBE)THEN
        iarr = -2
        CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
        CALL ESEINT(1,'PLACE NECESSAIRE POUR LES ELEMENTS',NBE*NBNMAX,1)
        GOTO 9999
      ENDIF
      IF(NBPMAX.LT.NBP)THEN
        iarr = -2
        CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
        CALL ESEINT(1,'PLACE NECESSAIRE POUR LES NOEUDS',NBP*IDIMC,1)
        GOTO 9999
      ENDIF
      IF(NITMAX.LT.(2*(NBCOL+NBLIG)+(NBCOL*NBLIG)))THEN
        iarr = -2
        CALL DSERRE(1,iarr,'BLOCOS',' POUR LE MAILLAGE 2D ')
        CALL ESEINT(1,'PLACE NECESSAIRE POUR LES CALCUL',
     >                (2*(NBCOL+NBLIG)+(NBCOL*NBLIG)),1)
      ENDIF
C
C        ===========================
C     --- 1. ON COMPLETE LES COURBES ---
C        ===========================
C
        IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'-> COURBES COMPLETEES',' ')
C
C
C     --- CONSTRUCTION D'UN MAILLAGE DE FRONTIERE SIMPLE :
C         DE 4 COTES (NBLIG,NBCOL,NBLIG,NBCOL)
C         NOEUDS RESPECTIVEMENT
C     --- INDICE DES NOEUDS DES COTES ---
      IND(1) = N(1) + 1
      DO 10 I=2,4
        IND(I)  = N(I) + IND(I-1)
   10 CONTINUE
      ICOURF = 1
C
      INDXYZ = NBCOOR+1
      INDICE = NBCOOR+1
      INCREM = 1
C
      NBAJ      = 2
      INCOAJ(1) = 1
      NBCOAJ(1) = ICOIN(4)
      NBCOAJ(2) = ICOIN(1)
      INCOAJ(2) = -N(1)-1
      CALL G2MOCO(IPOLY,1,N(1)+1,
     >            NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
     >            ITVL(ICOURF),NBLIG2,NBEL2)
C      PRINT *,'N1 = ',NBEL2
C      PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
      CALL G2POCO(IPOLY,1,N(1)+1,
     >            NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
     >            COORD,IDIMC)
C
      INCOAJ(1) = 1
      NBCOAJ(1) = ICOIN(1)
      NBCOAJ(2) = ICOIN(2)
      INCOAJ(2) = -N(2)-1
C      PRINT *,' IND =',ICOURF+NBCOL-1
      CALL G2MOCO(IPOLY(IND(1)),1,N(2)+1,
     >                  NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
     >                  ITVL(ICOURF+NBCOL),NBLIG2,NBEL2)
      CALL G2POCO(IPOLY(IND(1)),1,N(2)+1,
     >            NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
     >            COORD,IDIMC)
C      PRINT *,'N2 = ',NBEL2
C      PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
C
      INCOAJ(1) = 1
      NBCOAJ(1) = ICOIN(2)
      NBCOAJ(2) = ICOIN(3)
      INCOAJ(2) = -N(3)-1
C      PRINT *,' IND =',ICOURF+NBCOL+NBLIG-1
      CALL G2MOCO(IPOLY(IND(2)),1,N(3)+1,
     >                  NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
     >                  ITVL(ICOURF+NBCOL+NBLIG),NBLIG2,NBEL2)
      CALL G2POCO(IPOLY(IND(2)),1,N(3)+1,
     >            NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
     >            COORD,IDIMC)
C      PRINT *,'N3 = ',NBEL2
C      PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
C
      INCOAJ(1) = 1
      NBCOAJ(1) = ICOIN(3)
      NBCOAJ(2) = ICOIN(4)
      INCOAJ(2) = -N(4)-1
C      PRINT *,' IND =',ICOURF+2*NBCOL+NBLIG-1
      CALL G2MOCO(IPOLY(IND(3)),1,N(4)+1,
     >                  NBAJ,INCOAJ,NBCOAJ,INDICE,INCREM,
     >                  ITVL(ICOURF+2*NBCOL+NBLIG),NBLIG2,NBEL2)
      CALL G2POCO(IPOLY(IND(3)),1,N(4)+1,
     >            NBAJ,INCOAJ,NBCOAJ,INDXYZ,INCREM,
     >            COORD,IDIMC)
C
C      PRINT *,'N4 = ',NBEL2
C      PRINT *,'IPOLY = ',(IPOLY(I),I=1,N(1)+N(2)+N(3)+N(4))
C      PRINT *,'ICOURB = ',(ITVL(ICOURF-1+I),I=1,2*(NBCOL+NBLIG))
C      PRINT *,((COORD((I-1)*IDIMC+J),J=1,IDIMC),'+',I=1,INDXYZ)
C      PRINT *,'ITRACE =',ITRACE
C
C        ========================================
C     --- 2.CREATION DU PAVAGE  ---
C        ========================================
C
C
        IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'-> CREATION DU PAVAGE',' ')
C
      ITRAV = ICOURF + 2*(NBLIG+NBCOL)
      NITMX2 = NITMAX - ITRAV
      NBCOOR = INDXYZ - 1
C     ------- POUR LE TEST SANS COLLAGE ---
C      DO 20 I=1,4
C        ICOIN(I) = 0
C   20 CONTINUE
      CALL Q4CRGR(ITVL(ICOURF),ITVL(NBCOL+ICOURF),
     >      ITVL(ICOURF+NBCOL+NBLIG),
     >      ITVL(ICOURF+2*NBCOL+NBLIG),N,
     >      COORD,IDIMC,NBCOOR,
     >      NBLIG,NBCOL,ICOIN,
     >      ITVL(ITRAV),NITMX2,
     >      IDE,ITRNOE,NBNMAX,NBE,NBP,
     >      NBEMAX,NBPMAX,ITRACE,iarr)
C
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'BLOCOS',' APPEL Q4CRGR ')
        GOTO 9999
      ENDIF
C
C        ===================================================
C     --- 3. COMPRESSION DU MAILLAGE  ---
C        ===================================================
C
      IDE = 2
C
      IF(( (ICOIN(1)+ICOIN(2)+ICOIN(3)+ICOIN(4)).NE.0).AND.
     >     (ICOMPR.EQ.1))THEN
C
        IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'-> COMPRESSION DU MAILLAGE',' ')
C
        NBENUL = NBE
        NBISOL = NBP
        CALL NUGCNU(IDE,ITRNOE,NBNMAX,ibid,0,
     >            ibid,0,NBE,COORD,IDIMC,NBP,
     >            ITVL,NITMAX,iarr)
C
        IF(iarr.NE.0)THEN
          CALL DSERRE(1,iarr,'BLOCOS',' APPEL NUGCNU ')
          GOTO 9999
        ENDIF
C
        IF(ITRACE.GT.0)THEN
          CALL ESEINT(1,'NOMBRE D ELEMENTS SUPPRIMES : ',NBENUL-NBE,1)
          CALL ESEINT(1,'NOMBRE DE  POINTS SUPPRIMES : ',NBISOL-NBP,1)
        ENDIF
      ENDIF
C
C        ============================================
C     --- 4.CREATION DE LA STRUCTURE DE DONNEES  ---
C        ============================================
C
        IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'-> CREATION DE LA STRUCTURE',' ')
C
      CALL SMAOCR(IDE,ITRNOE,NBE,COORD,NBP,IDIMC,
     >            ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,
     >            ITVL,NITMAX,NCC,iarr)
C
      IF(iarr.NE.0)THEN
        CALL DSERRE(1,iarr,'BLOCOS',' APPEL SMAOCR ')
        GOTO 9999
      ENDIF
C
C        ============================================
C     --- 5.LISSAGE (BARYCENTRIQUE,ISOPARAMETRIQUE)  ---
C        ============================================
C
      IF( ILISS.EQ. 1)THEN
C
        IF(ITRACE.GT.0)
     >  CALL ESECHA(1,'-> LISSAGE',' ')
C
C        WRITE(6,*) 'ITRTRI = ',((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),
C     >  '/',I=1,NBE)
C        WRITE(6,*) 'NOETRI = ',(NOETRI(I),I=1,NBN)
        ITBLOQ = 1
        IPARA  = 0
        RELAX  = 1.5
        NPASMX = 100
*       CALL LISNOI(ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBP,
*    >              COORD,IDIMC,
*    >                  COORD,IDIMC,EPSLIS,COORD,
*    >                  ITBLOQ,0,0,
*    >                  IPARA,RELAX,NPASMX,
*    >                  W,RTRAV,ITRACE,iarr)
C
        IF(iarr.NE.0)THEN
          CALL DSERRE(1,iarr,'BLOCOS',' APPEL LISNOI ')
          GOTO 9999
        ENDIF
      ENDIF
C
 9999 END