Esope source files

   1 : C Q4CRGR    SOURCE    CHAT      06/03/29    21:30:47     5360           
   2 : C
   3 :       SUBROUTINE Q4CRGR(IC1,IC2,IC3,IC4,N,
   4 :      >      COORD,IDIMC,NBCOOR,
   5 :      >      NBLIG,NBCOL,ICOIN,
   6 :      >      ITVL,NITMAX,
   7 :      >      IDE,ITRNOE,NBNMAX,NBE,NBP,
   8 :      >      NBEMAX,NBPMAX,ITRACE,iarr)
   9 : C     **********************************************************************
  10 : C     OBJET Q4CRGR : MAILLAGE EN GRILLE A PARTIR DE 4 COTES 
  11 : C     OBJET          (MEME CARDINAUX SUR LES COTES OPPOSES).
  12 : C
  13 : C     EN ENTREE  :
  14 : C       ------------- MAILLAGE LINEIQUE ------------
  15 : C       IC1      : INDICES DES NOEUDS DU COTE 1 COMPLETE A NBCOL
  16 : C       ...
  17 : C       IC4      : INDICES DES NOEUDS DU COTE 4 COMPLETE A NBLIG
  18 : C       N        : N(I) NOMBRE D'ELEMENTS SUR LE COTE I (INITIAL)
  19 : C       COORD    : TABLEAU DES COORDONNEES DES POINTS
  20 : C       NBCOOR   : NOMBRE DE POINTS
  21 : C       IDIMC    : DIMENSION DE L'ESPACE
  22 : C
  23 : C       ------------- INFORMATIONS SUR LA GRILLE -----------
  24 : C       NBLIG, NBCOL, ICOIN : NOMBRE DE LIGNE ET NOMBRE DE COLONNES DE
  25 : C                 LA GRILLE AVEC LES VALEURS DES COUPER-COLLER AUX COINS.
  26 : C
  27 : C       ------------- TABLEAU DE TRAVAIL -----------
  28 : C       ITVL     : TABLEAU D'ENTIERS POUR LES CALCULS
  29 : C                  (NBCOL*NBLIG)   POUR LA GRILLE
  30 : C       NITMAX   : TAILLE DE ITVL, NITMAX >= (NBCOL*NBLIG) 
  31 : C
  32 : C       ITRNOE   : TABLEAU DES ELEMENTS (A REMPLIR)
  33 : C       NBEMAX   : NOMBRE MAXIMUM D'ELEMENTS
  34 : C                  NBEMAX >= (NBLIG-1)*(NBCOL-1)
  35 : C       COORD    : TABLEAU DES COORDONNEES (A COMPLETER)
  36 : C       NBPMAX   : NOMBRE MAXIMUM DE POINTS
  37 : C                  NBPMAX >= (NBLIG*NBCOL)
  38 : C
  39 : C     EN SORTIE  :
  40 : C       ------------- LE MAILLAGE --------------------------
  41 : C       IDE,ITRNOE,ITRTRI,NBE,NBP,  : LE MAILLAGE EN QUADRANGLES
  42 : C       COORD    : TABLEAU DES COORDONNEES DES POINTS (COMPLETE)
  43 : C       iarr     : CODE D'ERREUR 
  44 : C                  -1 SI DONNEES INCORRECTES
  45 : C                  -2 SI TABLEAUX INSUFFISANTS(COORD,ITRNOE OU ITVL)
  46 : C     **********************************************************************
  47 :       IMPLICIT INTEGER(I-N)
  48 :       INTEGER IC1(*),IC2(*),IC3(*),IC4(*),N(*)
  49 :       REAL*8    COORD(*)
  50 :       INTEGER IDIMC,NBCOOR
  51 :       INTEGER NBLIG,NBCOL,ICOIN(*)
  52 :       INTEGER ITVL(*),NITMAX
  53 :       INTEGER IDE,ITRNOE(*),NBNMAX,NBE,NBP,NBEMAX,NBPMAX
  54 :       INTEGER ITRACE,iarr      
  55 : C
  56 :       INTEGER I,J,IGR,INDICE,INDXYZ,INUL
  57 : C
  58 : C        ========================================
  59 : C     --- 1. CREATION DE LA GRILLE 2D ET COLLAGE ---
  60 : C        ========================================
  61 : C
  62 :       IF(NITMAX.LT.(NBCOL*NBLIG))THEN
  63 :         iarr = -2
  63 :         CALL DSERRE(1,iarr,'Q4CRGR',' POUR LE CALCUL ')          
  63 :         CALL ESEINT(1,'PLACE NECESSAIRE POUR LES CALCUL',
  64 :      >                (NBCOL*NBLIG),1)        
  65 :       ENDIF
  66 : C
  67 :       IGR = 1
  68 :       INUL = 0
  68 : C      CALL  G2CRSP( NBLIG,NBCOL,INUL,INUL,ITVL(IGR) )
  69 :       DO 710 JG=1,NBLIG*NBCOL
  70 :  710  ITVL(JG)=0
  71 : 
  72 : C         -----------------------------------------
  73 : C      --- TRANSFERT DES COURBES DANS LA GRILLE 2D ----
  74 : C         -----------------------------------------
  75 : C     --- PREMIER LIGNE : J = 1
  76 : C
  77 :       DO 100 I=1,NBCOL
  78 :          ITVL(IGR+I-1) = IC1(I)
  79 :   100 CONTINUE
  80 : C
  81 : C     --- DERNIERE LIGNE : J = NBLIG
  82 :       DO 110 I=1,NBCOL
  83 :          ITVL((NBLIG-1)*NBCOL+IGR+I-1) = IC3(NBCOL-I+1)
  84 :   110 CONTINUE
  85 : C
  86 : C     --- PREMIERE COLONNE : I = 1
  87 :       DO 120 J=1,NBLIG
  88 :          ITVL((J-1)*NBCOL+IGR) = IC4(NBLIG-J+1)
  89 :   120 CONTINUE
  90 : C
  91 : C     --- DERNIERE COLONNE : I = NBCOL
  92 :       DO 130 J=1,NBLIG
  93 :          ITVL((J-1)*NBCOL+IGR+NBCOL-1) = IC2(J)
  94 :   130 CONTINUE
  95 : C
  96 : C       PRINT *,'ITRACE =',ITRACE
  97 : C       PRINT *,'GRILLE 2D GR : '
  98 : C       PRINT *,'--------------------'
  99 : C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
 100 : C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
 101 : 
 102 :        INDICE = NBCOOR + 1
 103 :        DO 140 I=1,(NBCOL*NBLIG) 
 104 :          IF( ITVL(I-1+IGR).EQ. 0 )THEN
 105 :            ITVL(I-1+IGR)= INDICE
 106 :            INDICE = INDICE + 1
 107 :          ENDIF
 108 :   140 CONTINUE  
 109 : C
 110 : C       PRINT *,'GRILLE 2D GR : '
 111 : C       PRINT *,'--------------------'
 112 : C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
 113 : C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
 114 : C
 115 : C         -------------------
 116 : C      --- COLLAGE DES COINS ----
 117 : C         -------------------
 118 : C     --- ON PASSE SUR LA STRUCTURE MAILLAGE ---
 118 :       CALL Q4CRSP( NBLIG-1,NBCOL-1, ITRNOE,NBNMAX,NBE,NBP,iarr)
 119 : C
 120 : C
 121 : C       PRINT *,'ITRACE =',ITRACE
 122 : C       PRINT *,'MAILLAGE 2D  : '
 123 : C       PRINT *,'--------------------'
 124 : C       PRINT *,'NBE,NBP = ',NBE,NBP
 125 : C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
 126 : C
 127 :       DO 10 I=1,4
 127 :         CALL G2GLKK( I,ICOIN(I), NBLIG-1,NBCOL-1,ITRNOE,NBNMAX,iarr)
 128 :         IF( iarr.NE. 0 )GOTO 999
 129 :    10 CONTINUE
 130 : C
 131 : C
 132 : C       PRINT *,'ITRACE =',ITRACE
 133 : C       PRINT *,'MAILLAGE 2D  : '
 134 : C       PRINT *,'--------------------'
 135 : C       PRINT *,'NBE,NBP = ',NBE,NBP
 136 : C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
 137 : C       PRINT *,'GRILLE 2D GR : '
 138 : C       PRINT *,'--------------------'
 139 : C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
 140 : C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
 141 : C
 142 : C
 143 : C     --- RENUMEROTATION DES NOEUDS DU MAILLAGE ----
 144 :       DO 150 I=1,NBE*NBNMAX
 145 :         IF(ITRNOE(I).GT.0)ITRNOE(I) = ITVL(IGR+ITRNOE(I)-1)
 146 :   150 CONTINUE
 147 : C
 148 : C       PRINT *,'ITRACE =',ITRACE
 149 : C       PRINT *,'MAILLAGE 2D  : '
 150 : C       PRINT *,'--------------------'
 151 : C       PRINT *,'NBE,NBP = ',NBE,NBP
 152 : C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
 153 : C   
 154 : C
 155 :        IF( iarr.NE.0 )THEN
 155 :         CALL DSERRE(1,iarr,'Q4CRGE',' CALCUL TOPOLOGIE')        
 156 :         GOTO 999
 157 :        ENDIF
 158 : C
 159 : C
 160 : C        ========================================
 161 : C     --- 2. CALCUL DES COORDONNEES DE LA GRILLE ---
 162 : C        ========================================
 163 : C
 164 : C       PRINT *,'IC1 = ',(IC1(J),J=1,NBCOL)
 165 : C       PRINT *,'IC2 = ',(IC2(J),J=1,NBLIG)
 166 : C       PRINT *,'IC3 = ',(IC3(J),J=1,NBCOL)
 167 : C       PRINT *,'IC4 = ',(IC4(J),J=1,NBLIG)
 168 : C       PRINT *,'NBCOOR = ',NBCOOR
 169 : C
 170 :       INDXYZ = NBCOOR + 1
 171 :       NBP = NBCOOR
 171 :       CALL G2PO4C(IC1,IC2,IC3,IC4,
 172 :      >            COORD,NBCOL,NBLIG,IDIMC,
 173 :      >            COORD,NBP,iarr)
 174 :       NBCOOR = NBP
 175 : C
 176 : C
 177 : C       PRINT *,'GRILLE 2D GR : '
 178 : C       PRINT *,'--------------------'
 179 : C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
 180 : C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
 181 : C       PRINT *,'NOMBRE DE NOEUD = ',NBP
 182 : C       PRINT *,((COORD((I-1)*IDIMC+J),J=1,IDIMC),'+',I=1,NBP)
 183 : C       PRINT *,'ITRACE =',ITRACE
 184 : C
 185 :       IF( iarr.NE.0 )THEN
 185 :         CALL DSERRE(1,iarr,'Q4CRGR',' CALCUL COORDONNEES')        
 186 :         GOTO 999
 187 :       ENDIF
 188 : C
 189 :   999 END        
 190 :  
 191 :  
 192 :