Télécharger optnum.eso

Retour à la liste

Numérotation des lignes :

  1. C OPTNUM SOURCE PV 19/04/28 14:43:01 10210
  2. SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,
  3. > IDIFF,IPOME,ICPR,NODES,NOOPTI,ipd)
  4. *
  5. * renumérotation des noeuds en vue de la résolution
  6. * par la méthode de Cuthill Mac Kee inversée
  7. *
  8. * si ipd non nul, on 'n'inverse pas et on commence par ipd
  9. *
  10. *
  11. IMPLICIT INTEGER(I-N)
  12. -INC SMELEME
  13. -INC CCOPTIO
  14. SEGMENT MEMJT1(0)
  15. SEGMENT MEMJT2(0)
  16. SEGMENT IPOME(0)
  17. SEGMENT JNT (0)
  18. SEGMENT JMEM (0)
  19. SEGMENT NEWJT(0)
  20. SEGMENT JOINT(0)
  21. SEGMENT ICPR (0)
  22. C SEGMENT OU STOCKE LES ELEMENTS DEJA ESSAYES
  23. SEGMENT IDJFC(IDJFCL)
  24. SEGMENT IDJF(IDJFL)
  25. C SEGMENT OU STOCKER LES POINTS DE DEPARTS DEJA ESSAYES
  26. SEGMENT NPES(NODES)
  27. CHARACTER*4 MVAL(1)
  28. INTEGER IPASG
  29. SAVE IPASG
  30. DATA IPASG/0/
  31. DATA MVAL/'NOOP'/
  32. lasur0=0
  33. cout0=0.d0
  34. NOOPTI=0
  35. IPT1=MELEME
  36. CALL LIRMOT(MVAL,1,IRET,0)
  37. IF (IRET.EQ.0) GOTO 2
  38. NOOPTI=1
  39. DO 4 J=1,NODES
  40. JNT(J)=J
  41. 4 CONTINUE
  42. RETURN
  43. 2 CONTINUE
  44. nvoisl=16
  45. if (nucrou.eq.1) nvoisl=64
  46. SEGINI NPES
  47. DO 5 I=1,NODES
  48. NPES(I)=0
  49. 5 CONTINUE
  50. IDJFCL=MAX(1,LISOUS(/1))
  51. SEGINI IDJFC
  52. IPT1=MELEME
  53. DO 6 ISOUS=1,IDJFCL
  54. IF (LISOUS(/1).NE.0) IPT1=LISOUS(ISOUS)
  55. IDJFL=IPT1.NUM(/2)
  56. SEGINI IDJF
  57. IDJFC(ISOUS)=IDJF
  58. 6 CONTINUE
  59. MINMAX=500000
  60. ICON=1
  61. ITER=1
  62. IBOUT=1
  63. IK=1
  64. if (ipd.ne.0) ik=ipd
  65. NK5=1
  66. 1 CONTINUE
  67. NPES(IK)=1
  68. DO 230 IO=1,MAX(1,LISOUS(/1))
  69. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  70. IF(IPT1.ITYPEL.NE.22) GO TO 230
  71. DO 240 LA=1,IPT1.NUM(/2)
  72. NPES(ICPR(IPT1.NUM(1,LA)))=1
  73. NPES(ICPR(IPT1.NUM(2,LA)))=1
  74. 240 CONTINUE
  75. 230 CONTINUE
  76. DO 20 J=1,NODES
  77. JOINT(J)=0
  78. 20 NEWJT(J)=0
  79. LASURT=0
  80. MUX=0
  81. I=1
  82. NEWJT(1)=IK
  83. JOINT(IK)=1
  84. K=1
  85. 30 IND=NEWJT(I)
  86. IND1=IND
  87. K4=JMEM(IND)
  88. JSUB=IPOME(NEWJT(I))
  89. * tentative tc
  90. DO 40 JJ=k4,1,-1
  91. ** DO 40 JJ=1,k4
  92. IND=JSUB+JJ
  93. IAIA= memjt2(ind)
  94. K6=memjt1(ind)
  95. IDJF=IDJFC(MAX(1,IAIA))
  96. IF (IDJF(K6).EQ.1) GOTO 40
  97. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  98. IPOSL2=0
  99. * pour avoir dans le bon sens le super element
  100. DO 85 LT=1,IPT1.NUM(/1)
  101. l=lt
  102. IF(IPT1.ITYPEL.EQ.22) then
  103. l=lt+1
  104. if (lt.eq.1) l=1
  105. if (lt.eq.ipt1.num(/1)) l=2
  106. endif
  107. K5=ICPR(IPT1.NUM(l,K6))
  108. IF (JOINT(K5).GT.0) GO TO 85
  109. if (npes(k5).eq.0) nk5=k5
  110. K=K+1
  111. NEWJT(K)=K5
  112. JOINT(K5)=K
  113. NDIFF=ABS(I-K)
  114. MUX=MAX(MUX,NDIFF)
  115. IF(IPT1.ITYPEL.EQ.22.AND.IPT1.NUM(/1).NE.0) GO TO 86
  116. GOTO 85
  117. 86 CONTINUE
  118. * on insere le multiplicateur 1 avant i (deja atteint)
  119. * on insere le second apres le noeud le plus haut de l'element (type 22
  120. * on mettra celui-ci apres tous les autres
  121. IF (L.EQ.1) THEN
  122. DO 87 M=K,I+1,-1
  123. NEWJT(M)=NEWJT(M-1)
  124. JOINT(NEWJT(M))=M
  125. 87 CONTINUE
  126. NEWJT(I)=K5
  127. JOINT(K5)=I
  128. I=I+1
  129. ELSEIF (L.EQ.2) THEN
  130. IPOSL2=K
  131. ENDIF
  132. 85 CONTINUE
  133. IDJF(K6)=1
  134.  
  135. IF (IPT1.ITYPEL.EQ.22.AND.IPOSL2.NE.0) THEN
  136. * on s'occupe maintenant du 2eme multiplicateur de lagrange
  137. IHAUT=0
  138. DO 89 L=3,IPT1.NUM(/1)
  139. K3=ICPR(IPT1.NUM(L,K6))
  140. IHAUT=MAX(IHAUT,JOINT(K3))
  141. 89 CONTINUE
  142. NEWSAU=NEWJT(IPOSL2)
  143. IF(IHAUT+1.EQ.IPOSL2) GO TO 40
  144. IF (IHAUT.LT.IPOSL2) THEN
  145. DO 88 M=IPOSL2,IHAUT+2,-1
  146. NEWJT(M)=NEWJT(M-1)
  147. JOINT(NEWJT(M))=M
  148. 88 CONTINUE
  149. NEWJT(IHAUT+1)=NEWSAU
  150. JOINT(NEWSAU)=IHAUT+1
  151. ELSE
  152. DO 84 M=IPOSL2,IHAUT-1
  153. NEWJT(M)=NEWJT(M+1)
  154. JOINT(NEWJT(M))=M
  155. 84 CONTINUE
  156. NEWJT(IHAUT)=NEWSAU
  157. JOINT(NEWSAU)=IHAUT
  158. ENDIF
  159. ENDIF
  160. 40 CONTINUE
  161. IF(K.EQ.NODES) GO TO 50
  162. I=I+1
  163. IF (I.NE.K+1) GO TO 30
  164. K=K+1
  165. DO 23 L=1,NODES
  166. IF (JOINT(L).EQ.0) GO TO 24
  167. 23 CONTINUE
  168. CALL ERREUR(9)
  169. 24 CONTINUE
  170. NEWJT(K)=L
  171. JOINT(L)=K
  172. IBOUT=IBOUT+1
  173. GO TO 30
  174. 50 CONTINUE
  175. * 60 CONTINUE
  176. II=IK
  177. INTERR(1)=IBOUT
  178. IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN
  179. IF(LOCERR(1:4).EQ.'RESO') CALL ERREUR(754)
  180. IPASG = 1
  181. ENDIF
  182. LASURT=0
  183. LASURF=0
  184. DO 46 IB=1,NODES
  185. LONG=IB
  186. LANG=IB
  187. IC=NEWJT(IB)
  188. K4=JMEM(IC)
  189. JSUB=IPOME(IC)
  190. DO 43 JJB=1,K4
  191. IND=JSUB+JJB
  192. IAIA= memjt2(ind)
  193. IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  194. K6=memjt1(ind)
  195. DO 44 IKL=1,IPT1.NUM(/1)
  196. JKL=JOINT(ICPR(IPT1.NUM(IKL,K6)))
  197. LONG=MAX(LONG,JKL)
  198. LANG=MIN(LANG,JKL)
  199. 44 CONTINUE
  200. 43 CONTINUE
  201. LASURT=LASURT+LONG-IB
  202. LASURF=LASURF+IB-LANG
  203. 46 CONTINUE
  204. ** IF (MINMAX.LE.MUX) GOTO 60
  205. ** if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60
  206. cout=5.d0*log(real(mux+1))+log(real(lasurt+1))+log(real(lasurf+1))
  207. if (cout0.ne.0.d0.and.cout.ge.cout0) goto 60
  208. cout0=cout
  209.  
  210. MINMAX=MIN(MINMAX,MUX)
  211. lasur0=lasurt
  212. IF(IIMPI.EQ.3)
  213. 1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT
  214. 62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ',
  215. #I13,' SURF INV:',I13)
  216. DO 55 J=1,NODES
  217. 55 JNT(J)=JOINT(J)
  218. ICON=0
  219. NVOIS=0
  220. 60 CONTINUE
  221. IK=NK5
  222. DO 95 IO=1,IDJFC(/1)
  223. IDJF=IDJFC(IO)
  224. DO 97 LA=1,IDJF(/1)
  225. 97 IDJF(LA)=0
  226. 95 CONTINUE
  227. ICON=ICON+1
  228. ITER=ITER+1
  229. IF (ICON.LE.3.AND.NPES(IK).EQ.0) GOTO 1
  230. IF (NVOIS.GT.0) GO TO 101
  231. LH=0
  232. nvois=0
  233. 101 continue
  234. do i=1,nodes
  235. newjt(jnt(i))=i
  236. enddo
  237. 102 continue
  238. lh=lh+1
  239. if (lh.gt.nodes) goto 71
  240. if (nvois.gt.nvoisl) goto 71
  241. if (ipd.ne.0) goto 71
  242. ik=newjt(lh)
  243. if (nvois.ge.128) ik=newjt(nodes+129-lh)
  244. if (npes(ik).eq.1) goto 102
  245. nvois=nvois+1
  246. goto 1
  247. 71 CONTINUE
  248. IDIFF=MINMAX
  249. DO 105 J=1,IDJFC(/1)
  250. IDJF=IDJFC(J)
  251. SEGSUP IDJF
  252. 105 CONTINUE
  253. SEGSUP IDJFC
  254. SEGSUP NPES
  255. RETURN
  256. END
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  

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