Esope source files

   1 : C RICRO1    SOURCE    KICH      11/08/11    21:15:48     7079           
   2 :       SUBROUTINE RICRO1(ipv1,ipv2,ibu,ibd,mot2,irig,iinc,idua,xr1)
   3 : * produit scalaire proprement dit
   4 :       IMPLICIT REAL*8(A-H,O-Z)
   5 : -INC CCOPTIO
   6 : -INC SMCHAML
   7 : -INC SMLMOTS
   8 : c
   9 :       SEGMENT MPTVAL
  10 :       INTEGER IPOS(NS),NSOF(NS)
  11 :       INTEGER IVAL(NCOSOU)
  12 :       CHARACTER*16 TYVAL(NCOSOU)
  13 :       ENDSEGMENT
  14 : C
  15 :       CHARACTER*4 mot2
  16 : 
  17 :       xr1 = 0.d0
  18 :       mptval = ipv1
  19 :       segact mptval
  20 :       if (irig.eq.1) then
  21 : *masse
  22 :        melval = ival(3)
  23 :        segact melval
  24 :        IBMN=MIN(IBU,IELCHE(/2))
  25 :        itreac = ielche(1,ibmn)
  26 :        segdes melval
  27 :       elseif (irig.eq.2) then
  28 : * rigidite
  29 :        melval = ival(2)
  30 :        segact melval
  31 :        IBMN=MIN(IBU,IELCHE(/2))
  32 :        itreac = ielche(1,ibmn)
  33 :        segdes melval
  34 : *
  35 :       elseif (irig.eq.3) then
  36 :          xamorsta = 0.
  37 :        if(ival(/1).gt.3) then
  38 :         melval = ival(4)
  39 :         if (melval.gt.0) then
  40 :           segact melval
  41 :           IBMN=MIN(IBU,VELCHE(/2))
  42 :           xamorsta = velche(1,ibmn)
  43 :           segdes melval
  44 : *comme pour masse
  45 :        melval = ival(3)
  46 :        segact melval
  47 :        IBMN=MIN(IBU,IELCHE(/2))
  48 :        itreac = ielche(1,ibmn)
  49 :        segdes melval
  50 :         endif
  51 :        endif
  52 : *
  53 :       endif
  54 : 
  55 :       if (ipv1.ne.ipv2) then
  56 :          segdes mptval
  57 :          mptval = ipv2
  58 :          segact mptval
  59 :       endif
  60 : 
  61 : *masse ou rigidite
  62 :        if (mot2.eq.'STAT') then
  63 :         melval = ival(1)
  64 :        elseif (mot2.eq.'MODA') then
  65 :         melval = ival(3)
  66 :        endif
  67 :        segact melval
  68 :        IBMN=MIN(IBD,IELCHE(/2))
  69 :        itdepl = ielche(1,ibmn)
  70 :        segdes melval
  71 : *
  72 :        if (irig.eq.3) then
  73 :           xamo2 = 0.
  74 :         if(ival(/1).gt.3) then
  75 :          melval = ival(4)
  76 :          if (melval.gt.0) then
  77 :           segact melval
  78 :           IBMN=MIN(IBD,VELCHE(/2))
  79 :           xamo2 = velche(1,ibmn)
  80 :           segdes melval
  81 :          endif
  82 :         endif
  83 :         xamo3 = xamorsta*xamo2
  84 :          if (xamo3.eq.0.) then
  85 :           xr1 = 0.
  86 :           return
  87 :          else
  88 :           xamo = dsqrt(dabs(xamo3))
  89 :           if (xamo3.lt.0) xamo = xamo * (-1.d0)
  90 :          endif
  91 :        endif
  92 : 
  93 : 
  94 : 
  94 :          CALL XTY1(itdepl,itreac,iinc,idua,XR1)  
  95 :          if (ierr.ne.0) return
  96 :          if (irig.eq.3) xr1 = xr1 * xamo
  97 : 
  98 :       RETURN
  99 :       END
 100 :  
 101 :  
 102 :