Télécharger q4org2.eso

Retour à la liste

Numérotation des lignes :

  1. C Q4ORG2 SOURCE CHAT 06/03/29 21:30:57 5360
  2. C
  3. C
  4. SUBROUTINE Q4ORG2(ITRNO1,NBNMX1,ITRTR1,NBCMX1,NBE1,
  5. > ITRNO2,NBNMX2,ITRTR2,NBCMX2,NBE2,N1,N2,
  6. > COORD,NBCOOR,IDIMC,
  7. > ITVL,NITMAX,
  8. > IGR1,NGRMX1,IGR2,NGRMX2,ICOIN,NBNL,ITRACE,iarr)
  9. C **********************************************************************
  10. C OBJET Q4ORG2 : TRANSFORME 2 MAILLAGES Q4 EN 2 GRILLES COMPATIBLES
  11. C
  12. C EN ENTREE :
  13. C
  14. C ITRNOE1 : INDICE DES NOEUDS DES ELEMENTS DU PREMIER MAILLAGE
  15. C NBNMX1 : NOMBRE MAX. DE NOEUDS PAR ELEMENTS (4 OU +)
  16. C NBE1 : NOMBRE D'ELEMENTS DU PREMIER MAILLAGE
  17. C
  18. C ITRNOE2,NBNMX2,NBE2 : DEUXIEME MAILLAGE
  19. C
  20. C N1,N2 : N1 EST LE NUMERO DU NOEUD DU PREMIER MAILLAGE QUI DOIT
  21. C ETRE CONNECTE AU NOEUD N2 DANS LE DEUXIEME MAILLAGE
  22. C
  23. C COORD : COORDONNEES DES NOEUDS
  24. C IDIMC : DIMENSION DE L'ESPACE
  25. C NBCOOR : NOMBRE DE NOEUDS
  26. C
  27. C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS
  28. C NTIMAX : TAILLE DU TABLEAU ITVL
  29. C ON A BESOIN DU TABLEAU DE TRAVAIL SEULEMENT SI ON CHANGE
  30. C SIMULTANEMENT L'ORIGINE ET L'ORIENTATION DU MAILLAGE.
  31. C LA PLACE NECESSAIRE EST ALORS DE : NBCOL*NBLIG = NBN
  32. C QUI EST TOUJOURS INFERIEUR A : 3+2*MAX(NBE1,NBE2)
  33. C
  34. C EN SORTIE :
  35. C
  36. C IGR1 : GRILLE ORIGINE
  37. C IGR2 : GRILLE DESTINATION
  38. C ICOIN : LES INDICES DES COINS DES 2 GRILLES
  39. C NBNL : NOMBRE DE COLONNES ET DE LIGNES DES 2 GRILLES
  40. C iarr : CODE D'ERREUR -1 SI DONNEES INCORRECTES
  41. C -2 SI TABLEAUX INSUFFISANTS
  42. C
  43. C REMARQUES : LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON
  44. C AVEC UNE ORIGINE COMPATIBLE,
  45. C AVEC NBCOL2 >= NBCOL1 ET NBLIG2 <= NBLIG1
  46. C
  47. C **********************************************************************
  48. IMPLICIT INTEGER(I-N)
  49. INTEGER ITRNO1(*),NBNMX1,ITRTR1(*),NBCMX1,NBE1
  50. INTEGER ITRNO2(*),NBNMX2,ITRTR2(*),NBCMX2,NBE2,N1,N2
  51. REAL*8 COORD(*)
  52. INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX
  53. INTEGER IGR1(*),NGRMX1,IGR2(*),NGRMX2
  54. INTEGER ICOIN(*),NBNL(*),ITRACE,iarr
  55. C
  56. REAL*8 VK(3),XNVK,ZERO
  57. INTEGER NBLIG1,NBCOL1,NBLIG2,NBCOL2,NBCOL,NBLIG
  58. INTEGER I,IOP,ITAMPO
  59. EXTERNAL XNORVE
  60. REAL*8 XNORVE
  61. C
  62. IF(ITRACE.GT.0)
  63. > CALL ESECHA(1,'* PRETRAITEMENT : ',
  64. > ' CALCUL DES GRILLES SURFACIQUES ')
  65. C
  66. DO 10 I=1,8
  67. ICOIN(I) = 0
  68. 10 CONTINUE
  69. DO 20 I=1,4
  70. NBNL(I) = 0
  71. 20 CONTINUE
  72. C
  73. C =========================
  74. C --- CALCUL DE L'ORIENTATION ---
  75. C =========================
  76. C
  77. ZERO = 1.E-6
  78. C CALL DIFFVE(COORD((N2-1)*IDIMC+1),
  79. C > COORD((N1-1)*IDIMC+1),
  80. C > IDIMC,VK)
  81. DO 730 JG=1,IDIMC
  82. 730 VK(JG)=COORD((N2-1)*IDIMC+JG) - COORD((N1-1)*IDIMC+JG)
  83. XNVK = XNORVE(VK,IDIMC)
  84. IF( XNVK.LT.ZERO )THEN
  85. iarr = -1
  86. CALL DSERRE(1,iarr,'Q4ORG2',
  87. > ' LES NOEUDS (N1,N2) SONT CONFONDUS ')
  88. GOTO 9999
  89. ENDIF
  90. C CALL MUSCVE( VK,XNVK,IDIMC, VK )
  91. DO 710 JG=1,IDIMC
  92. 710 VK(JG)=VK(JG)*XNVK
  93. C
  94. C ===========================
  95. C --- CALCUL DE LA 1IERE GRILLE ---
  96. C ===========================
  97. C
  98. CALL G2ORQ4(ITRNO1,NBNMX1,ITRTR1,NBCMX1,NBE1,
  99. > COORD,IDIMC,N1,VK,
  100. > ITVL,NITMAX,
  101. > IGR1,NBCOL1,NBLIG1,NGRMX1,
  102. > ICOIN,iarr )
  103. C
  104. NBNL(1) = NBCOL1
  105. NBNL(2) = NBLIG1
  106. C
  107. IF(ITRACE.GT.0)THEN
  108. CALL ESECHA(1,'-> DU MAILLAGE 1 A LA GRILLE 1',' ')
  109. CALL ESEINT(1,'NUMERO DES COINS : ',ICOIN,4)
  110. CALL ESEINT(1,'COLONNES,LIGNES : ',NBNL,2)
  111. ENDIF
  112. IF( iarr.NE. 0 )THEN
  113. CALL DSERRE(1,iarr,'Q4ORG2',' APPEL G2ORQ4')
  114. CALL DSERRE(1,iarr,'Q4ORG2',
  115. > ' PASSAGE PREMIER MAILLAGE EN GRILLE ')
  116. GOTO 9999
  117. ENDIF
  118. C
  119. C ===========================
  120. C --- CALCUL DE LA 2IERE GRILLE ---
  121. C ===========================
  122. C
  123. CALL G2ORQ4(ITRNO2,NBNMX2,ITRTR2,NBCMX2,NBE2,
  124. > COORD,IDIMC,N2,VK,
  125. > ITVL ,NITMAX,
  126. > IGR2,NBCOL2,NBLIG2,NGRMX2,
  127. > ICOIN(5),iarr )
  128. C
  129. NBNL(3) = NBCOL2
  130. NBNL(4) = NBLIG2
  131. C
  132. IF(ITRACE.GT.0)THEN
  133. CALL ESECHA(1,'-> DU MAILLAGE 2 A LA GRILLE 2',' ')
  134. CALL ESEINT(1,'NUMERO DES COINS : ',ICOIN(5),4)
  135. CALL ESEINT(1,'COLONNES,LIGNES : ',NBNL(3),2)
  136. ENDIF
  137. IF( iarr.NE. 0 )THEN
  138. CALL DSERRE(1,iarr,'Q4ORG2',' APPEL G2ORQ4')
  139. CALL DSERRE(1,iarr,'Q4ORG2',
  140. > ' PASSAGE DU DEUXIEME MAILLAGE EN GRILLE ')
  141. GOTO 9999
  142. ENDIF
  143. C
  144. C ====================================================
  145. C ---- INVERSION DES LIGNES ET DES COLONNES DES 2 GRILLES ----
  146. C ====================================================
  147. C
  148. IF((NBCOL1.GT.NBCOL2 ).AND.(NBLIG1.GT.NBLIG2))THEN
  149. iarr = -1
  150. NBNL(1) = NBCOL1
  151. NBNL(2) = NBLIG1
  152. NBNL(3) = NBCOL2
  153. NBNL(4) = NBLIG2
  154. GOTO 9999
  155. ENDIF
  156. C
  157. IF((NBCOL1.GT.NBCOL2 ).OR.(NBLIG2.GT.NBLIG1))THEN
  158. C
  159. IF(ITRACE.GT.0)
  160. > CALL ESECHA(1,' REORIENTATION : ',
  161. > ' ROTATION DES GRILLES SURFACIQUES ')
  162. C
  163. IF( ( (NITMAX - NBCOL1*NBLIG1).LT.0 ).OR.
  164. > ( (NITMAX - NBCOL2*NBLIG2).LT.0 ) )THEN
  165. iarr = -2
  166. CALL DSERRE(1,iarr,'Q4ORG2',
  167. > ' POUR LA REORIENTATION DES GRILLES ')
  168. GOTO 9999
  169. ENDIF
  170. C
  171. IOP = 2
  172. CALL G2COPY(IGR1,NBCOL1,NBLIG1,IOP,
  173. > ITVL,NBCOL,NBLIG )
  174. IOP = 1
  175. CALL G2COPY(ITVL,NBCOL,NBLIG,IOP,
  176. > IGR1,NBCOL1,NBLIG1 )
  177. ITAMPO = ICOIN(1)
  178. ICOIN(1) = ICOIN(4)
  179. ICOIN(4) = ICOIN(3)
  180. ICOIN(3) = ICOIN(2)
  181. ICOIN(2) = ITAMPO
  182. NBNL(1) = NBCOL1
  183. NBNL(2) = NBLIG1
  184. C
  185. IOP = 2
  186. CALL G2COPY(IGR2,NBCOL2,NBLIG2,IOP,
  187. > ITVL,NBCOL,NBLIG )
  188. IOP = 1
  189. CALL G2COPY(ITVL,NBCOL,NBLIG,IOP,
  190. > IGR2,NBCOL2,NBLIG2 )
  191. ITAMPO = ICOIN(5)
  192. ICOIN(5) = ICOIN(8)
  193. ICOIN(8) = ICOIN(7)
  194. ICOIN(7) = ICOIN(6)
  195. ICOIN(6) = ITAMPO
  196. NBNL(3) = NBCOL2
  197. NBNL(4) = NBLIG2
  198. C
  199. IF(ITRACE.GT.0)THEN
  200. CALL ESECHA(1,'-> GRILLE 1 REOREINTEE ',' ')
  201. CALL ESEINT(1,'COLONNES,LIGNES : ',NBNL,2)
  202. CALL ESECHA(1,'-> GRILLE 2 REORIENTEE ',' ')
  203. CALL ESEINT(1,'COLONNES,LIGNES : ',NBNL(3),2)
  204. ENDIF
  205. ENDIF
  206. C
  207. 9999 END
  208.  
  209.  
  210.  
  211.  

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