Télécharger la plaquette Cast3M


fr en

Télécharger q4crgr.eso

Retour à la liste

Numérotation des lignes : 

q4crgr

  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
  64.         CALL DSERRE(1,iarr,'Q4CRGR',' POUR LE CALCUL ')
  65.         CALL ESEINT(1,'PLACE NECESSAIRE POUR LES CALCUL',
  66.      >                (NBCOL*NBLIG),1)
  67.       ENDIF
  68. C
  69.       IGR = 1
  70.       INUL = 0
  71. C      CALL  G2CRSP( NBLIG,NBCOL,INUL,INUL,ITVL(IGR) )
  72.       DO 710 JG=1,NBLIG*NBCOL
  73.  710  ITVL(JG)=0
  74.  
  75. C         -----------------------------------------
  76. C      --- TRANSFERT DES COURBES DANS LA GRILLE 2D ----
  77. C         -----------------------------------------
  78. C     --- PREMIER LIGNE : J = 1
  79. C
  80.       DO 100 I=1,NBCOL
  81.          ITVL(IGR+I-1) = IC1(I)
  82.   100 CONTINUE
  83. C
  84. C     --- DERNIERE LIGNE : J = NBLIG
  85.       DO 110 I=1,NBCOL
  86.          ITVL((NBLIG-1)*NBCOL+IGR+I-1) = IC3(NBCOL-I+1)
  87.   110 CONTINUE
  88. C
  89. C     --- PREMIERE COLONNE : I = 1
  90.       DO 120 J=1,NBLIG
  91.          ITVL((J-1)*NBCOL+IGR) = IC4(NBLIG-J+1)
  92.   120 CONTINUE
  93. C
  94. C     --- DERNIERE COLONNE : I = NBCOL
  95.       DO 130 J=1,NBLIG
  96.          ITVL((J-1)*NBCOL+IGR+NBCOL-1) = IC2(J)
  97.   130 CONTINUE
  98. C
  99. C       PRINT *,'ITRACE =',ITRACE
  100. C       PRINT *,'GRILLE 2D GR : '
  101. C       PRINT *,'--------------------'
  102. C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
  103. C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
  104.  
  105.        INDICE = NBCOOR + 1
  106.        DO 140 I=1,(NBCOL*NBLIG)
  107.          IF( ITVL(I-1+IGR).EQ. 0 )THEN
  108.            ITVL(I-1+IGR)= INDICE
  109.            INDICE = INDICE + 1
  110.          ENDIF
  111.   140 CONTINUE
  112. C
  113. C       PRINT *,'GRILLE 2D GR : '
  114. C       PRINT *,'--------------------'
  115. C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
  116. C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
  117. C
  118. C         -------------------
  119. C      --- COLLAGE DES COINS ----
  120. C         -------------------
  121. C     --- ON PASSE SUR LA STRUCTURE MAILLAGE ---
  122.       CALL Q4CRSP( NBLIG-1,NBCOL-1, ITRNOE,NBNMAX,NBE,NBP,iarr)
  123. C
  124. C
  125. C       PRINT *,'ITRACE =',ITRACE
  126. C       PRINT *,'MAILLAGE 2D  : '
  127. C       PRINT *,'--------------------'
  128. C       PRINT *,'NBE,NBP = ',NBE,NBP
  129. C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
  130. C
  131.       DO 10 I=1,4
  132.         CALL G2GLKK( I,ICOIN(I), NBLIG-1,NBCOL-1,ITRNOE,NBNMAX,iarr)
  133.         IF( iarr.NE. 0 )GOTO 999
  134.    10 CONTINUE
  135. C
  136. C
  137. C       PRINT *,'ITRACE =',ITRACE
  138. C       PRINT *,'MAILLAGE 2D  : '
  139. C       PRINT *,'--------------------'
  140. C       PRINT *,'NBE,NBP = ',NBE,NBP
  141. C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
  142. C       PRINT *,'GRILLE 2D GR : '
  143. C       PRINT *,'--------------------'
  144. C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
  145. C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
  146. C
  147. C
  148. C     --- RENUMEROTATION DES NOEUDS DU MAILLAGE ----
  149.       DO 150 I=1,NBE*NBNMAX
  150.         IF(ITRNOE(I).GT.0)ITRNOE(I) = ITVL(IGR+ITRNOE(I)-1)
  151.   150 CONTINUE
  152. C
  153. C       PRINT *,'ITRACE =',ITRACE
  154. C       PRINT *,'MAILLAGE 2D  : '
  155. C       PRINT *,'--------------------'
  156. C       PRINT *,'NBE,NBP = ',NBE,NBP
  157. C       PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),'+',I=1,NBE)
  158. C
  159. C
  160.        IF( iarr.NE.0 )THEN
  161.         CALL DSERRE(1,iarr,'Q4CRGE',' CALCUL TOPOLOGIE')
  162.         GOTO 999
  163.        ENDIF
  164. C
  165. C
  166. C        ========================================
  167. C     --- 2. CALCUL DES COORDONNEES DE LA GRILLE ---
  168. C        ========================================
  169. C
  170. C       PRINT *,'IC1 = ',(IC1(J),J=1,NBCOL)
  171. C       PRINT *,'IC2 = ',(IC2(J),J=1,NBLIG)
  172. C       PRINT *,'IC3 = ',(IC3(J),J=1,NBCOL)
  173. C       PRINT *,'IC4 = ',(IC4(J),J=1,NBLIG)
  174. C       PRINT *,'NBCOOR = ',NBCOOR
  175. C
  176.       INDXYZ = NBCOOR + 1
  177.       NBP = NBCOOR
  178.       CALL G2PO4C(IC1,IC2,IC3,IC4,
  179.      >            COORD,NBCOL,NBLIG,IDIMC,
  180.      >            COORD,NBP,iarr)
  181.       NBCOOR = NBP
  182. C
  183. C
  184. C       PRINT *,'GRILLE 2D GR : '
  185. C       PRINT *,'--------------------'
  186. C       PRINT *,'NBCOL,NBLIG = ',NBCOL,NBLIG
  187. C       PRINT *,((ITVL((I-1)*NBCOL+J+IGR-1),J=1,NBCOL),'+',I=1,NBLIG)
  188. C       PRINT *,'NOMBRE DE NOEUD = ',NBP
  189. C       PRINT *,((COORD((I-1)*IDIMC+J),J=1,IDIMC),'+',I=1,NBP)
  190. C       PRINT *,'ITRACE =',ITRACE
  191. C
  192.       IF( iarr.NE.0 )THEN
  193.         CALL DSERRE(1,iarr,'Q4CRGR',' CALCUL COORDONNEES')
  194.         GOTO 999
  195.       ENDIF
  196. C
  197.   999 END
  198.  
  199.  
  200.  
  201.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales