Télécharger g2llg2.eso

Retour à la liste

Numérotation des lignes :

  1. C G2LLG2 SOURCE CHAT 06/03/29 21:21:50 5360
  2. C
  3. C
  4. SUBROUTINE G2LLG2(IGR1,NBLIG1,NBCOL1,
  5. > IGR2,NBLIG2,NBCOL2,
  6. > COORD,NBCOOR,IDIMC,INDICE,RAPP,
  7. > ITVL,NITMAX,
  8. > IGRI,NBLIGI,NBCOLI,ITRACE,iarr)
  9. C **********************************************************************
  10. C OBJET G2LLG2 : CREER UNE GRILLE INTERMEDIAIRE (ENTRE 2 GRILLES)
  11. C
  12. C EN ENTREE :
  13. C
  14. C IGR1(NBLIG1,NBCOL1) : LA PREMIERE GRILLE
  15. C IGR CONTIENT LES NUMEROS DES NOEUDS
  16. C IGR2(NBLIG2,NBCOL2) : LA DEUXIEME GRILLE
  17. C COORD,NBCOORD,IDIMC : POSITION DES NOEUDS
  18. C
  19. C RAPP : RAPPORT DES DISTANCES ENTRE LES GRILLES
  20. C (IGRI-IGR1) / (IGR2-IGR1)
  21. C
  22. C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS
  23. C NITMAX : TAILLE DE ITVL
  24. C ON A BESOIN DU TABLEAU DE TRAVAIL POUR COMPLETER IGR1
  25. C LA PLACE NECESSAIRE EST DE : NBCOL1*NBLIG2
  26. C
  27. C EN SORTIE :
  28. C
  29. C IGRI(NBLIGI,NBCOLI) : GRILLE SURFACIQUE INTERMEDIAIRE
  30. C NBLIGI = NBLIG2, NBCOLI = NBCOL1
  31. C
  32. C INDICE : DU DERNIER NOEUD CREE
  33. C
  34. C iarr : CODE D'ERREUR -1 SI DONNEES INCORRECTES
  35. C -2 SI TABLEAUX INSUFFISANTS
  36. C
  37. C REMARQUES : LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON
  38. C AVEC UNE ORIGINE COMPATIBLE (VOIR G2ORIG, G2ORIE)
  39. C AVEC NBCOL2 >= NBCOL1 ET NBLIG2 <= NBLIG1
  40. C
  41. C **********************************************************************
  42. IMPLICIT INTEGER(I-N)
  43. INTEGER IGR1(*),NBLIG1,NBCOL1
  44. INTEGER IGR2(*),NBLIG2,NBCOL2
  45. REAL*8 COORD(*),RAPP
  46. INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
  47. INTEGER INDICE
  48. INTEGER IGRI(*),NBLIGI,NBCOLI,ITRACE,iarr
  49. C
  50. INTEGER NBCO11,NBLG11,IGR11
  51. INTEGER NBCOAJ(2),INCOAJ(2),NBLGAJ(2),INLGAJ(2),NBAJ(2)
  52. INTEGER INDXYZ,INCREM,ITRAV,I,J,K,NUM1,NUM2,IDECAL
  53. C REAL*8 COEF,CNBLG,CNBCO,
  54. REAL*8 XO,V12
  55. C
  56. C ===============================================
  57. C --- 0. VERIFICATIONS DES CONDITIONS D'APPLICATION ---
  58. C ===============================================
  59. IF(NBCOL1.GT.NBCOL2)THEN
  60. iarr = -1
  61. CALL DSERRE(1,iarr,'G2LLG2',' INVERSER LES 2 GRILLES ')
  62. GOTO 9999
  63. ENDIF
  64. C
  65. IF( ( MOD(NBCOL1+NBCOL2,2).NE.0 ).OR.
  66. > ( MOD(NBLIG1+NBLIG2,2).NE.0 ))THEN
  67. iarr = -1
  68. CALL DSERRE(1,iarr,'G2LLG2',' UNE COUCHE INSUFFISANTE ')
  69. GOTO 9999
  70. ENDIF
  71. C
  72. IF((NBCOL1.LE.NBCOL2).AND.(NBLIG1.GE.NBLIG2))THEN
  73. iarr = -1
  74. CALL DSERRE(1,iarr,'G2LLG2',' UNE COUCHE SUFFISANTE ')
  75. GOTO 9999
  76. ENDIF
  77. C
  78. IF(ITRACE.GT.0)
  79. > CALL ESECHA(1,'-> RACCORD EN 2 COUCHES',' ')
  80. C
  81. C ===============================================
  82. C --- 1. CALCUL DE LA SURFACE INTERMEDIAIRE : GRI ---
  83. C GRI -> GR2 : ON AUGMENTE SEULEMENT LES COLONNES
  84. C GR1 -> GRI : ON AUGMENTE SEULEMENT LES LIGNES
  85. C ===============================================
  86. NBLIGI = NBLIG2
  87. NBCOLI = NBCOL1
  88. C ------------------------------------
  89. C ---- 1.1 ON COMPLETE LES LIGNES DE GR1 ---
  90. C ------------------------------------
  91. NBAJ(1) = 0
  92. NBAJ(2) = 2
  93. INLGAJ(1) = 1
  94. NBLGAJ(1) = (NBLIG2-NBLIG1) / 2
  95. NBLGAJ(2) = (NBLIG2-NBLIG1) / 2
  96. INLGAJ(2) = -NBLIG1
  97. C
  98. IGR11 = 1
  99. ITRAV = 1
  100. IF( NITMAX.LT. (IGR11-1+ NBCOL1*NBLIG2))THEN
  101. iarr = -2
  102. CALL DSERRE(1,iarr,'G2LLG2',' POUR COMPLETER LA GRILLE ')
  103. CALL ESEINT(1,'PLACE NECESSAIRE ',NBCOL1*NBLIG2,1)
  104. GOTO 9999
  105. ENDIF
  106. C
  107. INDICE = NBCOOR+1
  108. INCREM = 1
  109. IF(ITRACE.GT.0)THEN
  110. CALL ESECHA(1,'-> NOUVEAUX NOEUDS',' ')
  111. CALL ESEINT(1,'A PARTIR DU NUMERO ',INDICE,1)
  112. ENDIF
  113. C
  114. CALL G2POLC(IGR1,NBLIG1,NBCOL1,
  115. > NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ,
  116. > INDICE,INCREM,COORD,NBCOOR,IDIMC,
  117. > ITVL(ITRAV),0,
  118. > ITVL(IGR11),NBLG11,NBCO11,iarr)
  119. C
  120. IF(iarr.NE.0)THEN
  121. CALL DSERRE(1,iarr,'G2LLG2',' APPEL G2POLC ')
  122. GOTO 9999
  123. ENDIF
  124. C
  125. IF(ITRACE.GT.0)THEN
  126. CALL ESECHA(1,'-> GRILLE 1 COMPLETEE',' ')
  127. CALL ESEINT(1,'COLONNES ',NBCO11,1)
  128. CALL ESEINT(1,'LIGNES ',NBLG11,1)
  129. ENDIF
  130. C
  131. C -----------------------------------------
  132. C --- 1.2 CREATION D'UNE GRILLE 2D ET COLLAGE ---
  133. C -----------------------------------------
  134. C
  135. IF(ITRACE.GT.0)
  136. > CALL ESECHA(1,
  137. > '2. CREATION DE LA GRILLES 3D ET COLLAGE : ',' ')
  138. C
  139. C CALL G2CRSP( NBLIGI,NBCOLI,INDICE,INCREM,IGRI )
  140. DO 710 JG=1,(NBLIGI*NBCOLI)
  141. IGRI(JG)=INDICE
  142. INDICE = INDICE + INCREM
  143. 710 CONTINUE
  144. C ----------------------------
  145. C --- 1.3 INTERPOLATION LINEAIRE
  146. C POUR LA GRILLE 2D ---
  147. C ----------------------------
  148. C
  149. INDXYZ = NBCOOR + 1
  150. IF(ITRACE.GT.0)
  151. > CALL ESECHA(1,'-> COORDONNEES GRILLE 2D ',' ')
  152. C
  153. IDECAL = ( NBCOL2 - NBCOL1 ) / 2
  154.  
  155. C
  156. C --- INTERPOLATION REMPLISSAGE PAR LIGNE ---
  157. C
  158. DO 110 I=1,NBLG11
  159. NUM1 = ITVL((I-1)*NBCO11+1+IGR11-1)
  160. NUM2 = IGR2((I-1)*NBCOL2+1)
  161. DO 70 K=1,IDIMC
  162. XO = COORD((NUM1-1)*IDIMC+K)
  163. V12 = COORD((NUM2-1)*IDIMC+K) - XO
  164. COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
  165. 70 CONTINUE
  166. INDXYZ = INDXYZ + 1
  167. DO 90 J=2,NBCOL1-1
  168. C CORRECTION DU BUG : 1 => J
  169. NUM1 = ITVL((I-1)*NBCO11+J+IGR11-1)
  170. NUM2 = IGR2((I-1)*NBCOL2+J+IDECAL)
  171. DO 80 K=1,IDIMC
  172. XO = COORD((NUM1-1)*IDIMC+K)
  173. V12 = COORD((NUM2-1)*IDIMC+K) - XO
  174. COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
  175. 80 CONTINUE
  176. INDXYZ = INDXYZ + 1
  177. 90 CONTINUE
  178. NUM1 = ITVL(I*NBCO11+IGR11-1)
  179. NUM2 = IGR2(I*NBCOL2)
  180. DO 100 K=1,IDIMC
  181. XO = COORD((NUM1-1)*IDIMC+K)
  182. V12 = COORD((NUM2-1)*IDIMC+K) - XO
  183. COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO
  184. 100 CONTINUE
  185. INDXYZ = INDXYZ + 1
  186. 110 CONTINUE
  187. C
  188. C
  189. 9999 END
  190.  
  191.  
  192.  
  193.  

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