Télécharger q4crgr.eso

Retour à la liste

Numérotation des lignes :

  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