Télécharger dallos.eso

Retour à la liste

Numérotation des lignes :

  1. C DALLOS SOURCE CHAT 06/03/29 21:18:13 5360
  2. C
  3. C
  4. SUBROUTINE DALLOS(IREGIO,FER,XPROJ,NBLIG,NBCOL,NKCOIN,
  5. > IPT3,NBE,NBN,IERRDS)
  6. C **********************************************************************
  7. C OBJET DALLOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE
  8. C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME.
  9. C
  10. C EN ENTREE :
  11. C IREGIO : IREGIO(I) NOMBRE D'ELEMENTS SUR LE COTE I
  12. C FER : DESCRIPTION DU CONTOUR (NUMERO DES NOEUDS)
  13. C XPROJ : COORDONNEES DES POINTS DU CONTOUR (PROJETE DANS LE PLAN)
  14. C NBLIG : NOMBRE DE LIGNE DE LA GRILLE
  15. C NBCOL : NOMBRE DE COLONNES DE LA GRILLE
  16. C NKCOIN : NKCOIN(I) NOMBRE DE LIGNE ET DE COLONNES
  17. C A ENLEVER AU COIN I
  18. C EN SORTIE :
  19. C IPT3 : LE MAILLAGE QUADRANGULAIRE LINAIRE RESULTANT
  20. C NBE : NOMBRE D'ELEMENTS DU MAILLAGE
  21. C NBN : NOMBRE DE NOEUDS DU MAILLAGE (AVEC NOEUDS MILIEUX)
  22. C IERRDS : CODE D'ERREUR -1 DONNEES INCORRECTE, 0 OK
  23. C
  24. C **********************************************************************
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8 (A-H,O-Z)
  27. C
  28. INTEGER IREGIO(4),NBLIG,NBCOL,NKCOIN(4)
  29. INTEGER NBE,NBN,IERRDS
  30. -INC CCOPTIO
  31. -INC SMELEME
  32. SEGMENT ITRAVX
  33. INTEGER ITVL (ITOTAI)
  34. ENDSEGMENT
  35. SEGMENT RTRAVX
  36. REAL*8 RTVL (ITOTAR)
  37. ENDSEGMENT
  38. SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR),AFER.FER
  39. * ATTENTION SI XPROJ A 4 COMPOSANTES CE SONT X Y D Z
  40. SEGMENT XPROJ(N,1)
  41. C
  42. C WRITE (6,*) 'ON A LANCER DALL'
  43. C ====================================
  44. C --- ALLOCATION DES TABLEAUX DE TRAVAIL ---
  45. C ====================================
  46. ITRACE = 0
  47. IDIMC = XPROJ(/1)
  48. NBNMAX = 4
  49. NBCMAX = NBNMAX
  50. C write (6,*) 'idimc = ',idimc
  51. NBEMAX = (NBLIG-1)*(NBCOL-1)
  52. NBPMAX = NBLIG*NBCOL
  53. NBPOLY = IREGIO(1)+IREGIO(2)+IREGIO(3)+IREGIO(4)
  54. NITMAX = 8*NBEMAX +6*NBPMAX+NBPOLY+1
  55. NRTMAX = IDIMC * NBPMAX
  56. ITOTAI = NITMAX
  57. SEGINI ITRAVX
  58. ITOTAR = NRTMAX
  59. SEGINI RTRAVX
  60. C
  61. C =======================
  62. C --- TRANSFERT DU POLYGONE ---
  63. C =======================
  64. C ITVL(IPOLY) = REFERENCE DANS XPROJ
  65. C
  66. C ATTENTION LES NOEUDS MILIEUX SONT MIS AU DEBUT
  67. C
  68. IDEBUT = MAI(1) + 1
  69. C IF( ITOUR .NE.1 )THEN
  70. C WRITE(6,*) 'ATTENTION PLUS D UN CONTOUR '
  71. C ENDIF
  72. C IF( NBPOLY .NE. (MAI(ITOUR +1)-IDEBUT+1))THEN
  73. C WRITE(6,*) 'NBPOLY = ',NBPOLY
  74. C WRITE(6,*) 'MAI(1),MAI(ITOUR +1)=',
  75. C > MAI(1),MAI(ITOUR +1)
  76. C ENDIF
  77. C
  78. IPOLY = 1
  79. DO 10 I=1,NBPOLY
  80. ITVL(I-1+IPOLY) = I
  81. 10 CONTINUE
  82. ITVL(NBPOLY+IPOLY) = 1
  83. C
  84. ICOORD = 1
  85. DO 30 I=1,NBPOLY
  86. DO 20 J=1,IDIMC
  87. RTVL((I-1)*IDIMC+J-1+ICOORD) = XPROJ(J,I+IDEBUT-1)
  88. 20 CONTINUE
  89. 30 CONTINUE
  90. C
  91. C =====================================
  92. C --- ALLOCATION DES TABLEAUX DE DONNEES ---
  93. C =====================================
  94. C
  95. NBE = 0
  96. NBN = 0
  97. ITRNOE = NBPOLY + IPOLY + 1
  98. ITRTRI = NBEMAX*NBNMAX + ITRNOE
  99. NOETRI = NBEMAX*NBCMAX + ITRTRI
  100. NOEMAX = NBPMAX
  101. ITRAV = NBPMAX + NOETRI
  102. ITRVMX = NITMAX-ITRAV+1
  103. C
  104. IF( (NRTMAX-ICOORD+1).LT.(NBPMAX*IDIMC))THEN
  105. IERRDS = -2
  106. CALL ESERRO(1,IERRDS,'DALLOS',' RTVL TROP PETIT')
  107. GOTO 8888
  108. ENDIF
  109. C
  110. IF(ITRVMX.LT.(3*(NBLIG*NBCOL)))THEN
  111. IERRDS = -2
  112. C write(6,*) 'NITMAX =',NITMAX
  113. C write(6,*) 'ITRNOE =',ITRNOE
  114. C write(6,*) 'NBEMAX =',NBEMAX
  115. CALL ESERRO(1,IERRDS,'DALLOS',' ITVL TROP PETIT')
  116. GOTO 8888
  117. ENDIF
  118. C
  119. C
  120. IF(ITRACE.GT.0)THEN
  121. CALL ESECHA(1,'MAILLAGE D UN DOMAINE A 4 COTES',' ')
  122. ENDIF
  123. C
  124. C WRITE(6,*)'POLY =',(ITVL(IPOLY+I-1),I=1,NBPOLY+1)
  125. C WRITE(6,*)'COORD =',
  126. C > ((RTVL((I-1)*IDIMC+J),J=1,IDIMC),I=1,NBPOLY)
  127. C
  128. C ITRACE = 1
  129. C
  130. C =====================================
  131. C --- APPEL A L'ALGORITHME : BLOCOS ---
  132. C =====================================
  133. C
  134. ICOMPR = 1
  135. ILISS = 1
  136. W = 0.75
  137. EPSLIS = 0.0
  138. DO 50 I=1,NBPOLY
  139. N1 = ITVL(I-1+IPOLY)
  140. N2 = ITVL(I+IPOLY)
  141. DEPS = 0.0
  142. DO 40 J=1,IDIMC
  143. DEPS = DEPS + (RTVL((N1-1)*IDIMC+J-1+ICOORD) -
  144. > RTVL((N2-1)*IDIMC+J-1+ICOORD))**2
  145. 40 CONTINUE
  146. IF(EPSLIS.EQ.0.0)EPSLIS = DEPS
  147. IF(DEPS.LT.EPSLIS)EPSLIS = DEPS
  148. 50 CONTINUE
  149. EPSLIS = 0.001 * SQRT(EPSLIS)
  150. C WRITE(6,*) 'EPSLIS = ',EPSLIS
  151. C
  152. CALL BLOCOS(ITVL(IPOLY),IREGIO,
  153. > RTVL(ICOORD),IDIMC,NBPOLY,
  154. > NBLIG,NBCOL,NKCOIN,
  155. > ITVL(ITRAV),ITRVMX,
  156. > IDE,ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),
  157. > NBCMAX,ITVL(NOETRI),NOEMAX,
  158. > NBE,NBN,NBEMAX,NBPMAX,
  159. > ICOMPR,ILISS,EPSLIS,W,
  160. > ITRACE,IERCOD,IERRDS)
  161. C
  162. C CALL Q4CR4C(ITVL(IPOLY),IREGIO,
  163. C > RTVL(ICOORD),IDIMC,NBPOLY,
  164. C > NBLIG,NBCOL,NKCOIN,
  165. C > ITVL(ITRAV),NITMAX,
  166. C > IDE,ITVL(ITRNOE),NBNMAX,NBE,NBN,NBEMAX,NBPMAX,
  167. C > ITRACE,IERRDS)
  168. C
  169. IF(IERRDS.NE.0)THEN
  170. C WRITE(6,*) 'ERREUR DANS BLOCOS : ',IERRDS
  171. GOTO 8888
  172. ENDIF
  173. C
  174. C =====================================
  175. C --- TRANSFERT DES RESULTATS ---
  176. C =====================================
  177. C
  178. NBNN = 4
  179. NBREF = 0
  180. NBSOUS = 0
  181. NBELEM = NBE
  182. SEGINI IPT3
  183. C write(6,*) 'IPT3 =',IPT3
  184. C 8 = QUA4, 10 = QUA8
  185. IPT3.ITYPEL = 8
  186. C
  187. DO 100 I=1,NBE
  188. DO 100 J=1,NBNN
  189. IPT3.NUM(J,I) =ITVL((I-1)*NBNMAX+J-1+ITRNOE)+IDEBUT-1
  190. 100 CONTINUE
  191. C WRITE(6,*)'LE MAILLAGE AVANT SORTIE '
  192. C WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE)
  193. C WRITE(6,*) ((ITVL((I-1)*NBNMAX+J-1+ITRNOE),J=1,NBNN),I=1,NBE)
  194. C
  195. C
  196. ICOORD = 1
  197. DO 110 I=1,NBN
  198. XPROJ(1,I+IDEBUT-1) = RTVL((I-1)*IDIMC+ICOORD)
  199. XPROJ(2,I+IDEBUT-1) = RTVL((I-1)*IDIMC+1+ICOORD)
  200. C --- IL FAUX REVOIR LE CALCUL DE LA DENSITE ---
  201. XPROJ(3,I+IDEBUT-1) = RTVL((I-1)*IDIMC+2+ICOORD)
  202. IF( XPROJ(/1).EQ.4)THEN
  203. XPROJ(4,I+IDEBUT-1) = RTVL((I-1)*IDIMC+3+ICOORD)
  204. ENDIF
  205. 110 CONTINUE
  206. NBN = NBN + IDEBUT-1
  207. C
  208. 8888 CONTINUE
  209. SEGSUP ITRAVX,RTRAVX
  210. C write(6,*) 'IPT3 =',IPT3
  211. C WRITE(6,*)'LE MAILLAGE AVANT SORTIE '
  212. C WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE)
  213. 9999 END
  214.  
  215.  
  216.  
  217.  
  218.  

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