Télécharger arpale.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPALE SOURCE PV 20/05/14 21:15:01 10615
  2. SUBROUTINE ARPALE (IPRTRA,IPMAUP,QUAD)
  3.  
  4.  
  5.  
  6. ***********************************************************************
  7. *
  8. * A R P A L E
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * INITIALISATION DU VECTEUR RESIDUEL D'ARPACK
  14. * (Cinematiquement Admissible a 0)
  15. *
  16. *
  17. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  18. * -----------
  19. *
  20. *
  21. * IPRTRA ENTIER (E) POINTEUR DES OPERATEURS DE TRAVAIL
  22. *
  23. * IPMAUP ENTIER (E/S) POINTEUR DES ELEMENTS ARPACK
  24. *
  25. *
  26. * SOUS-PROGRAMMES APPELES:
  27. * ------------------------
  28. *
  29. * TDRAND,ARCORC,MUCPRI,RESOU1,LDMT,CHV3,ALEAT1
  30. *
  31. * AUTEUR, DATE DE CREATION:
  32. * -------------------------
  33. *
  34. * PASCAL BOUDA 29 JUIN 2015
  35. *
  36. * LANGAGE:
  37. * --------
  38. *
  39. * FORTRAN 77 & 90
  40. *
  41. ************************************************************************
  42.  
  43. IMPLICIT INTEGER(I-N)
  44. IMPLICIT REAL*8 (A-H,O-Z)
  45.  
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMCHPOI
  50. -INC SMRIGID
  51. -INC SMVECTD
  52. -INC TARWORK
  53.  
  54. SEGMENT idemen(0)
  55.  
  56. INTEGER IPRTRA
  57. INTEGER IPMAUP
  58. LOGICAL QUAD
  59.  
  60. INTEGER IPRIGI, IPMASS, IPKSIM
  61. REAL*8 VA
  62. INTEGER IPCHO
  63. INTEGER IPCHP1,IPCHP2
  64. INTEGER NOID,NOEN
  65.  
  66. SEGINI IDEMEN
  67. IDEMEN(**)=0
  68. NOID=0
  69. NOEN=1
  70.  
  71.  
  72. MAUP=IPMAUP
  73. SEGACT MAUP*MOD
  74.  
  75.  
  76. ************************************************************************
  77. * CAS QUADRATIQUE
  78. ************************************************************************
  79.  
  80. *pas de conditions particulières pour le vecteur initial
  81. *(pour l'instant ?)
  82.  
  83. IF (QUAD) THEN
  84.  
  85. DO i=1,resid(/1)
  86. CALL TDRAND(VA)
  87. resid(i)=VA
  88. ENDDO
  89.  
  90. GOTO 999
  91.  
  92. ENDIF
  93.  
  94.  
  95. ************************************************************************
  96. * CAS LINEAIRE
  97. ************************************************************************
  98.  
  99. MRITRA=IPRTRA
  100. SEGACT MRITRA
  101.  
  102. MRIGID=RIGI(1)
  103. SEGACT MRIGID
  104. IPCHO=ICHOLE
  105. SEGDES MRIGID
  106.  
  107. ****************************************
  108. *Creation d'un vecteur aleatoire primal*
  109. ****************************************
  110. IPRIGI=RIGI(1)
  111. IPMASS=RIGI(2)
  112. IPKSIM=RIGI(4)
  113. CALL ALEAT1(IPRIGI,IPCHP1)
  114.  
  115. ************************************************************
  116. *Calcul du nombre d'inconnues vraies (ddl's sans relations)*
  117. ************************************************************
  118.  
  119. NDDL = 0
  120. NDLX = 0
  121.  
  122. MCHPOI = IPCHP1
  123.  
  124.  
  125.  
  126. SEGACT MCHPOI
  127. NSOUS = IPCHP(/1)
  128.  
  129. DO ISOUS = 1, NSOUS
  130. MSOUPO = IPCHP(ISOUS)
  131. SEGACT MSOUPO
  132. MPOVAL = IPOVAL
  133. SEGACT MPOVAL
  134. NN = VPOCHA(/1)
  135. NC1 = VPOCHA(/2)
  136. NDDL = NDDL + NN*NC1
  137. DO INC = 1,NC1
  138. IF (NOCOMP(INC) .EQ. 'LX ') NDLX = NDLX + NN
  139. ENDDO
  140. SEGDES MSOUPO, MPOVAL
  141. ENDDO
  142.  
  143. SEGDES MCHPOI
  144.  
  145. NDDL = NDDL - NDLX - (NDLX/2)
  146.  
  147. IF (IIMPI.GE.1) THEN
  148. WRITE(IOIMP,*) NDDL, 'INCONNUES SONT SANS RELATIONS'
  149. ENDIF
  150.  
  151. *Ajustement de la taille des segments si necessaire (modification du
  152. *de la dimension de la base d'Arnoldi
  153.  
  154. IF (v(/2) .GT. NDDL) THEN
  155.  
  156. ndim=resid(/1)
  157. ncv=NDDL
  158. lipntr=ipntr(/1)
  159. lworkl=workl(/1)
  160. lnev=dr(/1)
  161.  
  162. SEGADJ MAUP
  163.  
  164. ENDIF
  165.  
  166. *****************************
  167. *Creation du residu initial *
  168. *****************************
  169.  
  170. MAUP=IPMAUP
  171. SEGACT MAUP*MOD
  172.  
  173. *en fonction du type de probleme, on realise une iteration d'Arnoldi;
  174. *voir documentation de ARPITL.ESO et ARPTIQ.ESO pour plus de details
  175.  
  176.  
  177. IF (iparam(7) .EQ. 3) THEN
  178.  
  179. CALL MUCPRI (IPCHP1,IPMASS,IPCHP2)
  180. *Mise a zero des inconnues en FPI : certainement inutile ?
  181. CALL ARCORC (IPCHP2,15)
  182.  
  183. ELSEIF (iparam(7) .EQ. 4) THEN
  184.  
  185. CALL MUCPRI (IPCHP1,IPRIGI,IPCHP2)
  186. *Mise a sero des inconnues en FLX
  187. CALL ARCORC (IPCHP2,10)
  188. *Mise a zero des inconnues en FPI : certainement inutile ?
  189. CALL ARCORC (IPCHP2,15)
  190.  
  191. ENDIF
  192.  
  193. IDEMEN(1)=IPCHP2
  194.  
  195.  
  196. IF (bmat .EQ. 'G') THEN
  197.  
  198. IF (SYME(4) .EQ. 0) THEN
  199. CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,1.D-18,0,0)
  200. ELSEIF (SYME(4) .EQ. 1) THEN
  201. CALL LDMT (IPKSIM,IDEMEN,NOID,NOEN,1.D-18,0)
  202. ENDIF
  203. IF (IERR.NE.0) RETURN
  204.  
  205. ELSEIF (bmat .EQ. 'I') THEN
  206.  
  207. IF (SYME(1) .EQ. 0) THEN
  208. CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,1.D-18,0,0)
  209. ELSEIF (SYME(1) .EQ. 1) THEN
  210. CALL LDMT (IPRIGI,IDEMEN,NOID,NOEN,1.D-18,0)
  211. ENDIF
  212. IF (IERR.NE.0) RETURN
  213. ENDIF
  214. C RESOU desactive IDEMEN on le reactive
  215. SEGACT,IDEMEN
  216.  
  217.  
  218. IPCHP1=IDEMEN(1)
  219.  
  220.  
  221.  
  222. *transformation en vecteur primal
  223. CALL CHV3 (IPCHO,IPCHP1,IPVEC,1)
  224.  
  225. MVECTD=IPVEC
  226. SEGACT MVECTD
  227. *Stockage du vecteur residu
  228. DO i=1,resid(/1)
  229. resid(i)=VECTBB(i)
  230. ENDDO
  231.  
  232. SEGSUP MVECTD
  233.  
  234.  
  235. SEGDES MRITRA
  236.  
  237.  
  238. 999 CONTINUE
  239.  
  240.  
  241.  
  242. IPMAUP=MAUP
  243. c SEGDES MAUP
  244.  
  245.  
  246. END
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  

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