Télécharger la plaquette Cast3M


fr en

Télécharger arpitl.eso

Retour à la liste

Numérotation des lignes : 

arpitl

  1. C ARPITL    SOURCE    MB234859  26/06/25    21:15:03     12580          
  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,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.  
  68. -INC PPARAM
  69. -INC CCOPTIO
  70. -INC CCHAMP
  71. -INC SMRIGID
  72. -INC TARWORK
  73. -INC CCREEL
  74. c -INC TARTRAK
  75.  
  76.       SEGMENT idemen(0)
  77.  
  78.       INTEGER IPRTRA
  79.       INTEGER IPMAUP
  80.       COMPLEX*16 SIGMA
  81.       LOGICAL INVER
  82.       LOGICAL SYM
  83.       REAL*8 EPSI
  84.       LOGICAL OUT
  85.  
  86.  
  87.       INTEGER IPRIGI,IPMASS,IPKSIM
  88.       INTEGER TEST
  89.       CHARACTER*1 SCAL
  90.       INTEGER OPT
  91.       INTEGER IPCTRA(4)
  92.       INTEGER NOID,NOEN
  93.       INTEGER ndim,ncv,lworkl
  94.  
  95.       xspetl = xspeti
  96.       SEGINI IDEMEN
  97.       IDEMEN(**)=0
  98.       NOID=0
  99.       NOEN=1
  100.  
  101.       OUT=.FALSE.
  102.  
  103.       MAUP=IPMAUP
  104.       SEGACT MAUP*MOD
  105.  
  106.       MRITRA=IPRTRA
  107.       SEGACT MRITRA
  108.  
  109. *Recuperation des operateurs de travail
  110.       IPRIGI=RIGI(1)
  111.       IPMASS=RIGI(2)
  112.       IPKSIM=RIGI(4)
  113.  
  114.  
  115. *Récupération de la dimension des tableaux
  116.       ndim=resid(/1)
  117.       ncv=v(/2)
  118.       lworkl=workl(/1)
  119.  
  120. *Si le probleme est symétrique, on appelle la routine spécifique aux
  121. *problemes symetriques, sinon on appelle celle pour les problemes
  122. *quelconques
  123.  
  124.       IF (SYM) THEN
  125.         CALL DSAUPD (ido,bmat,ndim,which,nev,EPSI,resid,
  126.      &      ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,ITRAK,info)
  127.  
  128.       ELSE
  129.  
  130.         CALL DNAUPD (ido,bmat,ndim,which,nev,EPSI,resid,
  131.      &      ncv,v,ldv,iparam,ipntr,workd,workl,lworkl,ITRAK,info)
  132.  
  133.       ENDIF
  134.  
  135. *Reverse communication: On récupère les paramètres de sortie et on
  136. *effectue des actions en fonction de leurs valeurs
  137.       TEST=ido
  138.       SCAL=bmat
  139.       OPT=iparam(7)
  140.  
  141.       IPMAUP=MAUP
  142. c       SEGDES MAUP
  143.  
  144. *On verifie si on doit stopper le processus
  145.       CALL ARPERR (IPMAUP,SYM,OUT)
  146.       IF (OUT) RETURN
  147.  
  148.  
  149. *Initialisation des chpoints de travail
  150.       DO i=1,4
  151.         IPCTRA(i)=0
  152.       ENDDO
  153.  
  154.  
  155. *SCAL: type de probleme
  156. *'I' si standard
  157. *'G' si generalise
  158.  
  159.       IF (SCAL .EQ. 'I') THEN
  160.  
  161.           IF (IIMPI.GE.10) WRITE(IOIMP,*) '*   PB AUX V.P. STANDARD  *'
  162.  
  163.           IF (TEST .EQ. -1 .OR. TEST .EQ. 1) THEN
  164.  
  165. *        &---------------------------------------------------&
  166. *        |          Calcul du produit matrice vecteur        |
  167. *        |           Y <---- inv(inv(B)*A-SIGMA*I)*X         |
  168. *        |                                                   |
  169. *        |               X : workd(ipntr(1))                 |
  170. *        |               Y : workd(ipntr(2))                 |
  171. *        &---------------------------------------------------&
  172.  
  173. ************************************************************************
  174. * 28/08/2015 : Dans ce cas, le shift est obligatoirement nul
  175. * decalage spectral avec une matrice identite non implemente
  176. ************************************************************************
  177.  
  178.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,3)
  179.  
  180.             CALL MUCPRI (IPCTRA(3),IPMASS,IPCTRA(2))
  181.  
  182.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),1,2)
  183.  
  184. *Mise a sero des inconnues en FLX
  185.             CALL ARCORC (IPCTRA(2),10)
  186. *Mise a zero des inconnues en PI  inutile ?
  187.             CALL ARCORC (IPCTRA(2),15)
  188.  
  189.             IDEMEN(1)=IPCTRA(2)
  190.  
  191.             INSYM=SYME(1)
  192.             CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0,1,INSYM,0)
  193.             IF(IERR.NE.0) RETURN
  194.  
  195.             IPCTRA(1)=IDEMEN(1)
  196.  
  197.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),2,1)
  198.  
  199.  
  200.           ENDIF
  201.  
  202.       ELSEIF (SCAL .EQ. 'G') THEN
  203.  
  204.         IF (IIMPI.GE.10) 
  205.      &  WRITE(IOIMP,*) '*   PB AUX V.P. GENERALISE  *',TEST,INVER
  206.  
  207.  
  208.         IF (TEST .EQ. -1)  THEN
  209.  
  210. *        &--------------------------------------------------&
  211. *        |          Calcul du produit matrice vecteur       |
  212. *        |                                                  |
  213. *        |        Y <---- inv(A-SIGMA*B)*B*X                |
  214. *        |                                                  |
  215. *        |              X : workd(ipntr(1))                 |
  216. *        |              Y : workd(ipntr(2))                 |
  217. *        &--------------------------------------------------&
  218.  
  219. c             WRITE(*,*) 'X1 :'
  220.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  221.  
  222.             CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(3))
  223. *Mise a sero des inconnues en FLX
  224.             CALL ARCORC (IPCTRA(3),10)
  225. *Mise a zero des inconnues en PI inutile ?
  226.             CALL ARCORC (IPCTRA(3),15)
  227.  
  228. c             WRITE(*,*) '{B*X1} :'
  229.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,2)        
  230.  
  231. c             WRITE(*,*) 'avant RESOU :',SYME(4)
  232.             IDEMEN(1)=IPCTRA(3)
  233.             INSYM=SYME(4)
  234.             CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0,1,INSYM,0)
  235.             IF (IERR.NE.0) RETURN
  236.  
  237. c             WRITE(*,*) 'Y1=[OP^-1]*{B*X1} :'
  238.             IPCTRA(2)=IDEMEN(1)
  239. cbp            CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  240.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  241.  
  242.  
  243.         ELSEIF (TEST .EQ. 1) THEN
  244.  
  245. *        &--------------------------------------------------&
  246. *        |        Calcul du produit matrice vecteur         |
  247. *        |                                                  |
  248. *        |        si INVER :                                |
  249. *        |        Y <---- inv(A-SIGMA*B)*B*X                |
  250. *        |                                                  |
  251. *        |              X : workd(ipntr(1))                 |
  252. *        |              Y : workd(ipntr(2))                 |
  253. *        |                                                  |
  254. *        |        sinon :                                   |
  255. *        |        Y <---- inv(A-SIGMA*B)*X                  |
  256. *        |                                                  |
  257. *        |              X : workd(ipntr(3))                 |
  258. *        |              Y : workd(ipntr(2))                 |
  259. *        &--------------------------------------------------&
  260.  
  261.           IF (INVER) THEN
  262.  
  263.               CALL ARPCH1(IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  264.  
  265.               CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(3))
  266. *Mise a sero des inconnues en FLX
  267.               CALL ARCORC (IPCTRA(3),10)
  268. *Mise a zero des inconnues en PI
  269.               CALL ARCORC (IPCTRA(3),15)
  270.  
  271.               CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),1,2)
  272.  
  273.           ELSE
  274.  
  275. c               WRITE(*,*) 'X2 :'
  276. cbp              CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(3),3,4)
  277.               CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(3),3,4)
  278.  
  279. *Mise a sero des inconnues en FLX
  280.               CALL ARCORC (IPCTRA(3),10)
  281. *Mise a zero des inconnues en PI
  282.               CALL ARCORC (IPCTRA(3),15)
  283. c               WRITE(*,*) '{X2} : uniquement le chpoint '
  284.  
  285.           ENDIF
  286.  
  287.           IDEMEN(1)=IPCTRA(3)
  288.  
  289.           INSYM=SYME(4)
  290.           CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0,1,INSYM,0)
  291.           IF (IERR.NE.0) RETURN
  292.  
  293. c           WRITE(*,*) 'Y2=[OP^-1]*{X2} :'
  294.           IPCTRA(2)=IDEMEN(1)
  295. cbp          CALL ARPCH1 (IPKSIM,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  296.           CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),2,1)
  297.  
  298.  
  299.         ELSEIF (TEST .EQ. 2) THEN
  300.  
  301. *        &-------------------------------------&
  302. *        |  Calcul du produit matrice vecteur  |
  303. *        |                                     |
  304. *        |    Si INVER                         |
  305. *        |        Y <---- A*X                  |
  306. *        |                                     |
  307. *        |    Sinon                            |
  308. *        |        Y <---- B*X                  |
  309. *        |                                     |
  310. *        |         X : workd(ipntr(1))         |
  311. *        |         Y : workd(ipntr(2))         |
  312. *        &-------------------------------------&
  313.  
  314.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(1),1,3)
  315.  
  316.             IF (.NOT. INVER) THEN
  317.  
  318.               CALL MUCPRI (IPCTRA(1),IPMASS,IPCTRA(2))
  319. c               WRITE(*,*) 'Y3=B*X3 :'
  320.  
  321.             ELSE
  322.  
  323.               CALL MUCPRI (IPCTRA(1),IPRIGI,IPCTRA(2))
  324.  
  325. *Mise a sero des inconnues en FLX
  326.               CALL ARCORC (IPCTRA(2),10)
  327. *Mise a zero des inconnues en PI
  328.               CALL ARCORC (IPCTRA(2),15)
  329. c               WRITE(*,*) 'Y3={B*X3} :'
  330.             ENDIF
  331.  
  332.             CALL ARPCH1 (IPRIGI,IPRIGI,IPMAUP,IPCTRA(2),2,2)
  333.  
  334.  
  335.           ENDIF
  336.  
  337.       ENDIF
  338.  
  339. *Destruction des chpoints de travail
  340.         DO i=1,4
  341.           IF (IPCTRA(i) .NE. 0) THEN
  342.             CALL DTCHPO (IPCTRA(i))
  343.           ENDIF
  344.         ENDDO
  345.  
  346.       SEGDES MRITRA
  347.  
  348.       END
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  

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