Télécharger arpitl.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPITL SOURCE PV 15/11/25 21:15:03 8707
  2. SUBROUTINE ARPITL (IPRTRA,IPMAUP,SIGMA,INVER,SYM,EPSI,OUT)
  3.  
  4.  
  5. ***********************************************************************
  6. *
  7. * A R P I T L
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * STEP DE LA FACTORISATION D'ARNOLDI POUR UN PROBLEME LINEAIRE.
  13. *
  14.  
  15. * REMARQUE:
  16. * ---------
  17. *
  18. * ON NOTE:
  19. *
  20. * A=IPRIGI
  21. * B=IPMASS
  22. *
  23. * IPRIGI : RIGIDITE
  24. * IPMASS : MASSE OU KSIGMA
  25. *
  26. *
  27. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  28. * -----------
  29. *
  30. *
  31. * IPRTRA ENTIER (E) OPERATEURS DE TRAVAIL
  32. *
  33. * IPMAUP ENTIER (E/S) POINTEUR VARIABLES ARPACK
  34. *
  35. * SIGMA COMPLEX DP (E) VALEUR SU SHIFT (PEUT ETRE NUL)
  36. *
  37. * INVER LOGIQUE (E) .TRUE. -> PRODUIT SCALAIRE X'KX
  38. * .FALSE. -> PRODUIT SCALAIRE X'MX
  39. *
  40. * SYM LOGIQUE (E) PROBLEME SYMETRIQUE OU NON
  41. *
  42. * EPSI REEL DP (E) TOLERANCE EIGENPAIRS
  43. *
  44. * OUT LOGIQUE (S) FLAG DE CONVERGENCE
  45. *
  46. *
  47. * SOUS-PROGRAMMES APPELES:
  48. * ------------------------
  49. *
  50. * DSAUPD,DNAUPD,ARPCH1,MUCPRI,RESOU1,LDMT,DECALE,DTCHPO,ARPERR
  51. *
  52. * AUTEUR,DATE DE CREATION:
  53. * -------------------------
  54. *
  55. * PASCAL BOUDA 29 JUIN 2015
  56. *
  57. * LANGAGE:
  58. * --------
  59. *
  60. * FORTRAN 77 & 90
  61. *
  62. ***********************************************************************
  63.  
  64. IMPLICIT INTEGER(I-N)
  65. IMPLICIT REAL*8 (A-H,O-Z)
  66.  
  67. -INC CCOPTIO
  68. -INC CCHAMP
  69. -INC SMRIGID
  70. -INC TARWORK
  71. -INC TARTRAK
  72.  
  73. SEGMENT idemen(0)
  74.  
  75. INTEGER IPRTRA
  76. INTEGER IPMAUP
  77. COMPLEX*16 SIGMA
  78. LOGICAL INVER
  79. LOGICAL SYM
  80. REAL*8 EPSI
  81. LOGICAL OUT
  82.  
  83.  
  84. INTEGER IPRIGI,IPMASS,IPKSIM
  85. INTEGER TEST
  86. CHARACTER*1 SCAL
  87. INTEGER OPT
  88. INTEGER IPCTRA(4)
  89. INTEGER NOID,NOEN
  90. INTEGER ndim,ncv,lworkl
  91.  
  92.  
  93. SEGINI IDEMEN
  94. IDEMEN(**)=0
  95. NOID=0
  96. NOEN=1
  97.  
  98. OUT=.FALSE.
  99.  
  100. MAUP=IPMAUP
  101. SEGACT MAUP*MOD
  102.  
  103. MRITRA=IPRTRA
  104. SEGACT MRITRA
  105.  
  106. *Recuperation des operateurs de travail
  107. IPRIGI=RIGI(1)
  108. IPMASS=RIGI(2)
  109. IPKSIM=RIGI(4)
  110.  
  111.  
  112. *Récupération de la dimension des tableaux
  113. ndim=resid(/1)
  114. ncv=v(/2)
  115. lworkl=workl(/1)
  116.  
  117. *Si le probleme est symétrique, on appelle la routine spécifique aux
  118. *problemes symetriques, sinon on appelle celle pour les problemes
  119. *quelconques
  120.  
  121. IF (SYM) THEN
  122. CALL DSAUPD (ido,bmat,ndim,which,nev,EPSI,resid,
  123. & ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info)
  124.  
  125. ELSE
  126.  
  127. CALL DNAUPD (ido,bmat,ndim,which,nev,EPSI,resid,
  128. & ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,info)
  129.  
  130. ENDIF
  131.  
  132. *Reverse communication: On récupère les paramètres de sortie et on
  133. *effectue des actions en fonction de leurs valeurs
  134. TEST=ido
  135. SCAL=bmat
  136. OPT=iparam(7)
  137.  
  138. IPMAUP=MAUP
  139. SEGDES MAUP
  140.  
  141. *On verifie si on doit stopper le processus
  142. CALL ARPERR (IPMAUP,SYM,OUT)
  143. IF (OUT) RETURN
  144.  
  145.  
  146. *Initialisation des chpoints de travail
  147. DO i=1,4
  148. IPCTRA(i)=0
  149. ENDDO
  150.  
  151.  
  152. *SCAL: type de probleme
  153. *'I' si standard
  154. *'G' si generalise
  155.  
  156. IF (SCAL .EQ. 'I') THEN
  157.  
  158. IF (TEST .EQ. -1 .OR. TEST .EQ. 1) THEN
  159.  
  160. * &---------------------------------------------------&
  161. * | Calcul du produit matrice vecteur |
  162. * | Y <---- inv(inv(B)*A-SIGMA*I)*X |
  163. * | |
  164. * | X : workd(ipntr(1)) |
  165. * | Y : workd(ipntr(2)) |
  166. * &---------------------------------------------------&
  167.  
  168. ************************************************************************
  169. * 28/08/2015 : Dans ce cas, le shift est obligatoirement nul
  170. * decalage spectral avec une matrice identite non implemente
  171. ************************************************************************
  172.  
  173. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,3)
  174.  
  175. CALL MUCPRI (IPCTRA(3),IPMASS,IPCTRA(2))
  176.  
  177. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),1,2)
  178.  
  179. *Mise a sero des inconnues en FLX
  180. CALL ARCORC (IPCTRA(2),10)
  181. *Mise a zero des inconnues en PI inutile ?
  182. CALL ARCORC (IPCTRA(2),15)
  183.  
  184. IDEMEN(1)=IPCTRA(2)
  185.  
  186. IF (SYME(1) .EQ. 0) THEN
  187. CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,1.D-18,0)
  188. ELSEIF (SYME(1) .EQ. 1) THEN
  189. CALL LDMT (IPRIGI,IDEMEN,NOID,NOEN,1.D-18)
  190. ENDIF
  191. IF(IERR.NE.0) RETURN
  192.  
  193. IPCTRA(1)=IDEMEN(1)
  194.  
  195. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),2,1)
  196.  
  197.  
  198. ENDIF
  199.  
  200. ELSEIF (SCAL .EQ. 'G') THEN
  201.  
  202.  
  203. IF (TEST .EQ. -1) THEN
  204.  
  205. * &--------------------------------------------------&
  206. * | Calcul du produit matrice vecteur |
  207. * | |
  208. * | Y <---- inv(A-SIGMA*B)*B*X |
  209. * | |
  210. * | X : workd(ipntr(1)) |
  211. * | Y : workd(ipntr(2)) |
  212. * &--------------------------------------------------&
  213.  
  214. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  215.  
  216. CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(3))
  217.  
  218. *Mise a sero des inconnues en FLX
  219. CALL ARCORC (IPCTRA(3),10)
  220. *Mise a zero des inconnues en PI inutile ?
  221. CALL ARCORC (IPCTRA(3),15)
  222.  
  223. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,2)
  224.  
  225. IDEMEN(1)=IPCTRA(3)
  226.  
  227. IF (SYME(4) .EQ. 0) THEN
  228. CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,1.D-18,0)
  229. ELSEIF (SYME(4) .EQ. 1) THEN
  230. CALL LDMT (IPKSIM,IDEMEN,NOID,NOEN,1.D-18)
  231. ENDIF
  232. IF (IERR.NE.0) RETURN
  233.  
  234. IPCTRA(2)=IDEMEN(1)
  235. CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  236.  
  237.  
  238. ELSEIF (TEST .EQ. 1) THEN
  239.  
  240. * &--------------------------------------------------&
  241. * | Calcul du produit matrice vecteur |
  242. * | |
  243. * | si INVER : |
  244. * | Y <---- inv(A-SIGMA*B)*B*X |
  245. * | |
  246. * | X : workd(ipntr(1)) |
  247. * | Y : workd(ipntr(2)) |
  248. * | |
  249. * | sinon : |
  250. * | Y <---- inv(A-SIGMA*B)*X |
  251. * | |
  252. * | X : workd(ipntr(3)) |
  253. * | Y : workd(ipntr(2)) |
  254. * &--------------------------------------------------&
  255.  
  256. IF (INVER) THEN
  257.  
  258. CALL ARPCH1(IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  259.  
  260. CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(3))
  261.  
  262. *Mise a sero des inconnues en FLX
  263. CALL ARCORC (IPCTRA(3),10)
  264. *Mise a zero des inconnues en PI
  265. CALL ARCORC (IPCTRA(3),15)
  266.  
  267. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,2)
  268.  
  269. ELSE
  270.  
  271. CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(3),3,4)
  272.  
  273. *Mise a sero des inconnues en FLX
  274. CALL ARCORC (IPCTRA(3),10)
  275. *Mise a zero des inconnues en PI
  276. CALL ARCORC (IPCTRA(3),15)
  277.  
  278. ENDIF
  279.  
  280. IDEMEN(1)=IPCTRA(3)
  281.  
  282. IF (SYME(4) .EQ. 0) THEN
  283. CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,1.D-18,0)
  284. ELSEIF (SYME(4) .EQ. 1) THEN
  285. CALL LDMT (IPKSIM,IDEMEN,NOID,NOEN,1.D-18)
  286. ENDIF
  287. IF (IERR.NE.0) RETURN
  288.  
  289. IPCTRA(2)=IDEMEN(1)
  290. CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  291.  
  292. ELSEIF (TEST .EQ. 2) THEN
  293.  
  294. * &-------------------------------------&
  295. * | Calcul du produit matrice vecteur |
  296. * | |
  297. * | Si INVER |
  298. * | Y <---- A*X |
  299. * | |
  300. * | Sinon |
  301. * | Y <---- B*X |
  302. * | |
  303. * | X : workd(ipntr(1)) |
  304. * | Y : workd(ipntr(2)) |
  305. * &-------------------------------------&
  306.  
  307. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  308.  
  309. IF (.NOT. INVER) THEN
  310.  
  311. CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(2))
  312.  
  313. ELSE
  314.  
  315. CALL MUCPRI (IPCTRA(1),IPRIGI,IPCTRA(2))
  316.  
  317. *Mise a sero des inconnues en FLX
  318. CALL ARCORC (IPCTRA(2),10)
  319. *Mise a zero des inconnues en PI
  320. CALL ARCORC (IPCTRA(2),15)
  321. ENDIF
  322.  
  323. CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),2,2)
  324.  
  325.  
  326. ENDIF
  327.  
  328. ENDIF
  329.  
  330. *Destruction des chpoints de travail
  331. DO i=1,4
  332. IF (IPCTRA(i) .NE. 0) THEN
  333. CALL DTCHPO (IPCTRA(i))
  334. ENDIF
  335. ENDDO
  336.  
  337. SEGDES MRITRA
  338.  
  339. END
  340.  
  341.  
  342.  
  343.  

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