Télécharger la plaquette Cast3M


fr en

Télécharger prraye.eso

Retour à la liste

Numérotation des lignes : 

prraye

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

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