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  25/05/21    21:15:02     12273          
  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. C     On teste la syntaxe 2
  35.       call lirobj('MCHAML  ',IPIN,0,iretou)
  36.       if(ierr.ne.0) return
  37.       mchel3=0
  38.       if( iretou .EQ. 1) then
  39.         call actobj('MCHAML  ',IPIN,1)
  40.         CALL REDUAF(IPIN,mmodel,mchel3,0,IR,KER)
  41.         IF(IR   .NE. 1) CALL ERREUR(KER)
  42.         IF(IERR .NE. 0) RETURN
  43.          kmatr=0
  44.          call lirree(xval,0,iret)
  45.          if( iret.eq.1) then
  46.            errj= xval
  47.          else
  48.            errj=1.d-10
  49.          endif
  50.       endif
  51.  
  52.       nmod=kmodel(/1)
  53.       segini itrav
  54.       iresu=0
  55.       do io=1,nmod
  56.         if(itrav(io).eq.0) then
  57.           n1=nmod
  58.          imodel=kmodel(io)
  59.          itrav(io)=1
  60.          segini mmode2
  61.          ia=1
  62.          mmode2.kmodel(ia)=imodel
  63.          do 1 iy=io+1,kmodel(/1)
  64.             if(itrav(iy).ne.0) go to 1
  65.             imode2=kmodel(iy)
  66.             if(conmod.eq.imode2.conmod) then
  67.               itrav(iy)=1
  68.               ia=ia+1
  69.               mmode2.kmodel(ia)=imode2
  70.             endif
  71.     1    continue
  72.          n1=ia
  73.          if( n1.ne.mmode2.kmodel(/1)) segadj mmode2
  74.          call reduaf ( mchel1,mmode2,mche1r,1,iretr,kerre)
  75.          if( iretr.ne.1) then
  76.            call erreur (kerre)
  77.            return
  78.          endif
  79.          call reduaf ( mchel2,mmode2,mche2r,1,iretr,kerre)
  80.          if( iretr.ne.1) then
  81.            call erreur (kerre)
  82.            return
  83.          endif
  84.          mche3r=mchel3
  85.          if( mchel3.ne.0) then
  86.            call reduaf ( mchel3,mmode2,mche3r,1,iretr,kerre)
  87.            if( iretr.ne.1) then
  88.              call erreur (kerre)
  89.              return
  90.            endif
  91.          endif
  92.          call rayen(mmode2,mche1r,mche2r,mche3r,errj,ifact)
  93.          if (ierr .NE. 0) return
  94.          if(iresu.eq.0) then
  95.            iresu=ifact
  96.          else
  97.            call fuschl(iresu,ifact,ires)
  98.            iresu=ires
  99.          endif
  100.         endif
  101.       enddo
  102.       segsup itrav
  103.  
  104.       if( iresu.ne.0)then
  105.         call actobj('MCHAML  ',iresu,1)
  106.         call ecrobj('MCHAML  ',iresu)
  107.       endif
  108.       end
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  

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