Télécharger prraye.eso

Retour à la liste

Numérotation des lignes :

  1. C PRRAYE SOURCE CB215821 16/12/05 22:04:18 9237
  2. subroutine prraye
  3. implicit real*8(a-h,o-z)
  4. implicit integer(i-n)
  5. -INC CCOPTIO
  6. -INC SMMODEL
  7. -INC SMCHAML
  8. segment itrav(nmod)
  9.  
  10. mchel1=0
  11. mchel2=0
  12. mchel3=0
  13.  
  14. call lirobj('MMODEL',mmodel,1,iretou)
  15. if(ierr.ne.0) return
  16.  
  17. call lirobj('MCHAML',IPIN,1,iretou)
  18. if(ierr.ne.0) return
  19. CALL REDUAF(IPIN,mmodel,mchel1,0,IR,KER)
  20. IF(IR .NE. 1) CALL ERREUR(KER)
  21. IF(IERR .NE. 0) RETURN
  22.  
  23. call lirobj('MCHAML',IPIN,1,iretou)
  24. if(ierr.ne.0) return
  25. CALL REDUAF(IPIN,mmodel,mchel2,0,IR,KER)
  26. IF(IR .NE. 1) CALL ERREUR(KER)
  27. IF(IERR .NE. 0) RETURN
  28.  
  29. call lirobj('MCHAML',IPIN,0,iretou)
  30. if(ierr.ne.0) return
  31. mchel3=0
  32. if( iretou .EQ. 1) then
  33. CALL REDUAF(IPIN,mmodel,mchel3,0,IR,KER)
  34. IF(IR .NE. 1) CALL ERREUR(KER)
  35. IF(IERR .NE. 0) RETURN
  36. kmatr=0
  37. call lirree(xval,0,iret)
  38. if( iret.eq.1) then
  39. errj= xval
  40. else
  41. errj=1.d-10
  42. endif
  43. endif
  44.  
  45. segact mmodel
  46. nmod=kmodel(/1)
  47. segini itrav
  48. iresu=0
  49. do io=1,nmod
  50. if(itrav(io).eq.0) then
  51. n1=nmod
  52. imodel=kmodel(io)
  53. segact imodel
  54. itrav(io)=1
  55. segini mmode2
  56. ia=1
  57. mmode2.kmodel(ia)=imodel
  58. do 1 iy=io+1,kmodel(/1)
  59. if(itrav(iy).ne.0) go to 1
  60. imode2=kmodel(iy)
  61. segact imode2
  62. if(conmod.eq.imode2.conmod) then
  63. itrav(iy)=1
  64. ia=ia+1
  65. mmode2.kmodel(ia)=imode2
  66. endif
  67. 1 continue
  68. n1=ia
  69. if( n1.ne.mmode2.kmodel(/1)) segadj mmode2
  70. call reduaf ( mchel1,mmode2,mche1r,1,iretr,kerre)
  71. if( iretr.ne.1) then
  72. call erreur (kerre)
  73. return
  74. endif
  75. call reduaf ( mchel2,mmode2,mche2r,1,iretr,kerre)
  76. if( iretr.ne.1) then
  77. call erreur (kerre)
  78. return
  79. endif
  80. mche3r=mchel3
  81. if( mchel3.ne.0) then
  82. call reduaf ( mchel3,mmode2,mche3r,1,iretr,kerre)
  83. if( iretr.ne.1) then
  84. call erreur (kerre)
  85. return
  86. endif
  87. endif
  88. call rayen(mmode2,mche1r,mche2r,mche3r,errj,ifact)
  89. if(iresu.eq.0) then
  90. iresu=ifact
  91. else
  92. call fuschl(iresu,ifact,ires)
  93. iresu=ires
  94. endif
  95. endif
  96. enddo
  97. segsup itrav
  98.  
  99. if( iresu.ne.0)call ecrobj('MCHAML',iresu)
  100. return
  101. end
  102.  
  103.  
  104.  

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