Esope source files

   1 : C PRRAYE    SOURCE    CHAT      12/06/07    21:15:52     7389           
   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)
   8 :       call lirobj('MMODEL',mmodel,1,iretou)
   9 :       if(ierr.ne.0) return
   9 :       call lirobj('MCHAML',mchel1,1,iretou)
  10 :       if(ierr.ne.0) return
  10 :       call lirobj('MCHAML',mchel2,1,iretou)
  11 :       if(ierr.ne.0) return
  12 :       mchel3=0
  12 :       call lirobj('MCHAML',mchel3,0,iretou)
  13 :       if( mchel3.ne.0) then
  14 :          kmatr=0
  14 :          call lirree(xval,0,iret)
  15 :          if( iret.eq.1) then
  16 :            errj= xval
  17 :          else
  18 :            errj=1.d-10
  19 :          endif
  20 :        endif  
  21 :       segact mmodel
  22 :       nmod=kmodel(/1)
  23 :       segini itrav
  24 :       iresu=0
  25 :       do io=1,nmod
  26 :         if(itrav(io).eq.0) then
  27 :           n1=nmod
  28 :          imodel=kmodel(io)
  29 :          segact imodel
  30 :          itrav(io)=1
  31 :          segini mmode2
  32 :          ia=1
  33 :          mmode2.kmodel(ia)=imodel
  34 :          do 1 iy=io+1,kmodel(/1)
  35 :             if(itrav(iy).ne.0) go to 1  
  36 :             imode2=kmodel(iy)
  37 :             segact imode2     
  38 :             if(conmod.eq.imode2.conmod) then
  39 :               itrav(iy)=1
  40 :               ia=ia+1
  41 :               mmode2.kmodel(ia)=imode2
  42 :             endif
  43 :     1    continue
  44 :          n1=ia
  45 :          if( n1.ne.mmode2.kmodel(/1)) segadj mmode2
  45 :          call reduaf ( mchel1,mmode2,mche1r,1,iretr,kerre)
  46 :          if( iretr.ne.1) then
  46 :            call erreur (kerre)
  47 :            return
  48 :          endif
  48 :          call reduaf ( mchel2,mmode2,mche2r,1,iretr,kerre)
  49 :          if( iretr.ne.1) then
  49 :            call erreur (kerre)
  50 :            return
  51 :          endif
  52 :          mche3r=mchel3
  53 :          if( mchel3.ne.0) then
  53 :            call reduaf ( mchel3,mmode2,mche3r,1,iretr,kerre)
  54 :          endif
  54 :          call rayen(mmode2,mche1r,mche2r,mche3r,errj,ifact)
  55 :          if(iresu.eq.0) then
  56 :             iresu=ifact
  57 :          else
  57 :             call fuschl(iresu,ifact,ires)
  58 :             iresu=ires
  59 :          endif
  60 :           segsup mmode2
  61 :         endif
  62 :       enddo  
  63 :       segsup itrav 
  64 :       
  64 :       if( iresu.ne.0)call ecrobj('MCHAML',iresu) 
  65 :       return
  66 :       end      
  67 :      
  68 :