Télécharger dallos.eso

Retour à la liste

Numérotation des lignes :

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

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