Télécharger kres8.eso

Retour à la liste

Numérotation des lignes :

  1. C KRES8 SOURCE GOUNAND 19/07/03 21:15:07 10248
  2. SUBROUTINE KRES8(MRIGID,KSMBR,INORMU,
  3. $ KTYPI,ITER,RESID,ICALRS,IRSTRT,LBCG,BRTOL,IDDOT,IMVEC,
  4. $ KPREC,RXMILU,RXILUP,XLFIL,XDTOL,XSPIV,
  5. $ KTIME,LTIME,
  6. $ MCHSOL,LRES,LNMV,ICVG,IMPR)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM : KRES8
  11. C DESCRIPTION : - Assemblage par RESOU
  12. C - Conversion au format Morse de la matrice
  13. C - Conversion du second membre en MVECTD
  14. C - Construction du préconditionneur
  15. C - Appel des solveurs itératifs
  16. C - Conversion du résultat en CHPOINT
  17. C
  18. C
  19. C LANGAGE : ESOPE
  20. C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  21. C mél : gounand@semt2.smts.cea.fr
  22. C***********************************************************************
  23. C VERSION : v1, 04/08/2011, version initiale
  24. C HISTORIQUE : v1, 04/08/2011, création
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC SMCHPOI
  32. POINTEUR MCHSOL.MCHPOI
  33. -INC SMRIGID
  34. -INC SMVECTD
  35. POINTEUR ISMBR.MVECTD
  36. POINTEUR INCX.MVECTD
  37. POINTEUR IR.MVECTD
  38. -INC SMMATRI
  39. SEGMENT PMORS
  40. INTEGER IA (NTT+1)
  41. INTEGER JA (NJA)
  42. ENDSEGMENT
  43. POINTEUR PMS1.PMORS,PMS2.PMORS
  44. POINTEUR KMORS.PMORS
  45. C Segment de stokage
  46. SEGMENT IZA
  47. REAL*8 A(NBVA)
  48. ENDSEGMENT
  49. POINTEUR IZA1.IZA,IZA2.IZA,IZAU.IZA,IZAL.IZA,ISA.IZA
  50. POINTEUR KIZA.IZA
  51.  
  52. -INC SMLENTI
  53. POINTEUR KTYP.MLENTI
  54. -INC SMTABLE
  55. POINTEUR KTIME.MTABLE
  56. DIMENSION ITTIME(4)
  57. CHARACTER*8 CHARI
  58. CHARACTER*1 CCOMP
  59. LOGICAL LTIME,LOGII
  60. REAL*8 GNRM2
  61. C ..
  62. C .. External subroutines and functions..
  63. *inutile EXTERNAL GAXPY,GCOPY,GDOT,GNRM2
  64.  
  65. IVALI=0
  66. XVALI=0.D0
  67. LOGII=.FALSE.
  68. IRETI=0
  69. XVALR=0.D0
  70. *inutile IOBRE=0
  71. IRETR=0
  72. C
  73. C Executable statements
  74. C
  75. IF (LTIME) THEN
  76. CALL CRTABL(KTIME)
  77. call timespv(ittime,oothrd)
  78. ITI1=(ITTIME(1)+ITTIME(2))/10
  79. ELSE
  80. KTIME=0
  81. ENDIF
  82. C
  83. C CAS PARTICULIER : Si la matrice est vide (toutes les inconnues
  84. C éliminées, par exemple)
  85. C
  86. SEGACT MRIGID
  87. IF (IRIGEL(/2).EQ.0) THEN
  88. NSOUPO=0
  89. NAT=0
  90. SEGINI MCHSOL
  91. SEGDES MCHSOL
  92. ICVG=0
  93. LNMV=0
  94. LRES=0
  95. IF (LTIME) THEN
  96. call timespv(ittime,oothrd)
  97. ITI2=(ITTIME(1)+ITTIME(2))/10
  98. CHARI='MATVIDE'
  99. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  100. $ 'ENTIER ',ITI2-ITI1,XVALR,CHARR,LOGIR,IRETR)
  101. SEGDES KTIME
  102. ENDIF
  103. SEGDES MRIGID
  104. RETURN
  105. ENDIF
  106. C
  107. C - Assemblage par RESOU
  108. C
  109. C old INORMU=1 : Normalisation des mutiplicateurs de Lagrange
  110. * INORMU est transmis à la subroutine
  111. * Le problème est que si MRIGID est deja assemblée, INORMU n'est pas
  112. * pris en compte... mais où le stocker ??
  113. CALL KRES9(MRIGID,INORMU)
  114. IF (IERR.NE.0) RETURN
  115. IF (LTIME) THEN
  116. call timespv(ittime,oothrd)
  117. ITI2=(ITTIME(1)+ITTIME(2))/10
  118. ENDIF
  119. C
  120. C - Conversion au format Morse de la matrice
  121. C
  122. CALL KRES10(MRIGID,KMORS,KIZA)
  123. IF (IERR.NE.0) RETURN
  124. IF (LTIME) THEN
  125. call timespv(ittime,oothrd)
  126. ITI3=(ITTIME(1)+ITTIME(2))/10
  127. ENDIF
  128. C
  129. C On donne des infos sur la matrice
  130. C
  131. * SEGACT MRIGID
  132. * ICHOLX=ICHOLE
  133. ** INFDDL.ESO est dans ~/triou/p1nc
  134. ** CALL INFDDL(ICHOLX)
  135. C WRITE(IOIMP,*) 'IMPR=',IMPR
  136. CALL INFMAT(KMORS,KIZA,IMPR,IRET)
  137. C IF (IRET.NE.0) GOTO 9999
  138. C WRITE(IOIMP,*) 'Apres KRES10'
  139. C WRITE(IOIMP,*) 'KMORS=',KMORS
  140. C WRITE(IOIMP,*) 'KIZA=',KIZA
  141.  
  142. C
  143. C - Conversion du second membre en MVECTD
  144. C et initialisation du résultat
  145. C
  146. SEGACT MRIGID
  147. ICHOLX=ICHOLE
  148. ISECO=KSMBR
  149. C On ne vérifie pas que le second membre doit être dans le dual
  150. NOID=1
  151. CALL CHVNS(ICHOLX,ISECO,ISMBR,NOID)
  152. IF (IERR.NE.0) RETURN
  153. IF (LTIME) THEN
  154. call timespv(ittime,oothrd)
  155. ITI4=(ITTIME(1)+ITTIME(2))/10
  156. ENDIF
  157.  
  158. C SEGACT ISMBR
  159. C WRITE(IOIMP,*) 'Second membre sous forme vecteur'
  160. C INC=ISMBR.VECTBB(/1)
  161. C WRITE(IOIMP,*) ' ISMBR, INC=',INC
  162. C WRITE(IOIMP,2022) (ISMBR.VECTBB(II),II=1,ISMBR.VECTBB(/1))
  163. C
  164. C Gestion normalisation Lagrange (repris de MONDES)
  165. C
  166. * IF (INORMU.EQ.1) THEN
  167. SEGACT ISMBR*MOD
  168. MMATRI=ICHOLE
  169. SEGACT MMATRI
  170. IF(IDNORD.GT.0) THEN
  171. MDNO1=IDNORD
  172. ELSE
  173. MDNO1=IDNORM
  174. ENDIF
  175. SEGACT MDNO1
  176. INC=MDNO1.DNOR(/1)
  177. DO 45 I=1,INC
  178. ISMBR.VECTBB(I)=ISMBR.VECTBB(I)*MDNO1.DNOR(I)
  179. 45 CONTINUE
  180. SEGDES MDNO1
  181. SEGDES MMATRI
  182. SEGDES ISMBR
  183. * ENDIF
  184. C
  185. C - Construction du préconditionneur (repris sur kres5)
  186. C - Appel des solveurs itératifs
  187. C
  188. C Si solveur multigrille, il faut un segment permettant de distinguer
  189. C les inconnues
  190. IF (KTYPI.EQ.7.OR.KTYPI.EQ.8) THEN
  191. MMATRI=ICHOLE
  192. SEGACT MMATRI
  193. MINCPO=IINCPO
  194. SEGACT MINCPO
  195. NCOMP=INCPO(/1)
  196. NNOE=INCPO(/2)
  197. SEGACT ISMBR
  198. INC=ISMBR.VECTBB(/1)
  199. SEGDES ISMBR
  200. JG=INC
  201. SEGINI KTYP
  202. DO ICOMP=1,NCOMP
  203. DO INOE=1,NNOE
  204. IG=INCPO(ICOMP,INOE)
  205. IF (IG.GT.0) KTYP.LECT(IG)=ICOMP
  206. ENDDO
  207. ENDDO
  208. SEGDES KTYP
  209. SEGDES MINCPO
  210. SEGDES MMATRI
  211. ELSE
  212. KTYP=0
  213. ENDIF
  214. C
  215. C Warning KMORS, KIZA et KTYP sont détruits dans KRES11 et KRES12
  216. C si inodet=0
  217. INODET=1
  218. C CALL ECMORS(KMORS,KIZA,4)
  219. C SEGACT ISMBR
  220. C WRITE(IOIMP,*) 'Second membre sous forme vecteur'
  221. C INC=ISMBR.VECTBB(/1)
  222. C WRITE(IOIMP,*) ' ISMBR, INC=',INC
  223. C WRITE(IOIMP,2022) (ISMBR.VECTBB(II),II=1,ISMBR.VECTBB(/1))
  224. C Solveur Direct
  225. IF (KTYPI.EQ.1) THEN
  226. SEGINI,INCX=ISMBR
  227. CALL KRES12(KMORS,KIZA,INCX,
  228. C CALL KRES12(KMORS,KIZA,ISMBR,
  229. $ KTIME,LTIME,
  230. $ INCX,LRES,LNMV,ICVG,IMPR,INODET)
  231. ELSE
  232. C Solveur Itératif
  233. CALL KRES11(KMORS,KIZA,KTYP,ISMBR,
  234. $ KTYPI,ITER,RESID,ICALRS,IRSTRT,LBCG,BRTOL,IDDOT,IMVEC,
  235. $ KPREC,RXMILU,RXILUP,XLFIL,XDTOL,XSPIV,
  236. $ KTIME,LTIME,
  237. $ INCX,LRES,LNMV,ICVG,IMPR,INODET)
  238. C WRITE(IOIMP,*) 'Apres KRES11'
  239. ENDIF
  240. IF(IERR.NE.0) RETURN
  241. C SEGACT INCX
  242. C WRITE(IOIMP,*) 'Inconnue sous forme vecteur'
  243. C INC=INCX.VECTBB(/1)
  244. C WRITE(IOIMP,*) ' INCX, INC=',INC
  245. C WRITE(IOIMP,2022) (INCX.VECTBB(II),II=1,INCX.VECTBB(/1))
  246. C IF(IERR.NE.0) RETURN
  247. C r(0)=b
  248. C SEGINI,IR=ISMBR
  249. C SEGACT INCX
  250. C SEGACT KMORS
  251. C SEGACT KIZA
  252. CC r(0)=b-Ax
  253. C CALL GMOMV(IMVEC,'N',-1.D0,KMORS,KIZA,INCX,1.D0,IR)
  254. C RNRM2 = GNRM2(IR)
  255. C WRITE(IOIMP,*) '||R||=',RNRM2
  256. C
  257. C Gestion normalisation Lagrange (repris de MONDES)
  258. C + égalité multiplicateurs
  259. * IF (INORMU.EQ.1) THEN
  260. SEGACT INCX*MOD
  261. MMATRI=ICHOLE
  262. SEGACT MMATRI
  263. MDNOR=IDNORM
  264. SEGACT MDNOR
  265. INC=DNOR(/1)
  266. DO 35 I=1,INC
  267. INCX.VECTBB(I)=INCX.VECTBB(I)*DNOR(I)
  268. 35 CONTINUE
  269. SEGDES MDNOR
  270. MILIGN=IILIGN
  271. SEGACT,MILIGN
  272. DO 36 I = 1, INC
  273. if (ITTR(I).ne.0) then
  274. * write (6,*) ' dans mondes ',i,ittr(i)
  275. if (incx.vectbb(i).eq.0.d0
  276. $ .or.incx.vectbb(ittr(i)).eq.0.d0) then
  277. * write (6,*) ' mondes vectbbs ',vectbb(i+k),vectbb(ittr(i)+k)
  278. incx.vectbb(i)=0.d0
  279. incx.vectbb(ittr(i))=0.d0
  280. goto 36
  281. endif
  282. incx.vectbb(i)=(incx.vectbb(i)+incx.vectbb(ittr(i)))/2
  283. incx.vectbb(ittr(i))=incx.vectbb(i)
  284. endif
  285. 36 CONTINUE
  286. SEGDES MILIGN
  287. SEGDES MMATRI
  288. SEGDES INCX
  289. * ENDIF
  290. C
  291. C
  292. C SEGACT INCX
  293. C WRITE(IOIMP,*) 'Inconnue sous forme vecteur'
  294. C INC=INCX.VECTBB(/1)
  295. C WRITE(IOIMP,*) ' INCX, INC=',INC
  296. C WRITE(IOIMP,2022) (INCX.VECTBB(II),II=1,INCX.VECTBB(/1))
  297. C IF(IERR.NE.0) RETURN
  298.  
  299. IF (LTIME) THEN
  300. call timespv(ittime,oothrd)
  301. ITI5=(ITTIME(1)+ITTIME(2))/10
  302. ENDIF
  303. C
  304. C - Conversion du résultat en CHPOINT
  305. C
  306. CALL VCH1(ICHOLX,INCX,MCHSOL,MRIGID)
  307. C WRITE(IOIMP,*) 'Apres VCH1'
  308. IF(IERR.NE.0) RETURN
  309. IF (LTIME) THEN
  310. call timespv(ittime,oothrd)
  311. ITI6=(ITTIME(1)+ITTIME(2))/10
  312. CHARI='ASS+RENU'
  313. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  314. $ 'ENTIER ',ITI2-ITI1,XVALR,CHARR,LOGIR,IRETR)
  315. CHARI='CONVMORS'
  316. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  317. $ 'ENTIER ',ITI3-ITI2,XVALR,CHARR,LOGIR,IRETR)
  318. C CHARI='CONVSMB '
  319. C CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  320. C $ 'ENTIER ',ITI4-ITI3,XVALR,CHARR,LOGIR,IRETR)
  321. IF (KTYPI.EQ.1) THEN
  322. CHARI='FAC+RESO'
  323. ELSE
  324. CHARI='PRE+RESO'
  325. ENDIF
  326. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  327. $ 'ENTIER ',ITI5-ITI4,XVALR,CHARR,LOGIR,IRETR)
  328. C CHARI='CONVINC'
  329. C CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  330. C $ 'ENTIER ',ITI6-ITI5,XVALR,CHARR,LOGIR,IRETR)
  331. CHARI='TOTAL '
  332. CALL ECCTAB(KTIME,'MOT ',IVALI,XVALI,CHARI,LOGII,IRETI,
  333. $ 'ENTIER ',ITI6-ITI1,XVALR,CHARR,LOGIR,IRETR)
  334. SEGDES KTIME
  335. ENDIF
  336. C Le solveur direct surcharge le second membre
  337. IF (ISMBR.NE.INCX) SEGSUP ISMBR
  338. SEGSUP INCX
  339. SEGDES MRIGID
  340. C
  341. C Normal termination
  342. C
  343. RETURN
  344. C
  345. C Format handling
  346. C
  347. 2022 FORMAT(10(1X,1PG12.5))
  348. C
  349. C End of subroutine KRES8
  350. C
  351. END
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  

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