1 : C MOCA SOURCE CHAT 05/01/13 01:46:52 5004 2 : subroutine moca 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC SMLREEL 7 : pointeur mlree4.mlreel, mlree5.mlreel 8 : character*4 mot(1) 9 : segment itra 10 : integer ipoi(m),npara,ibon(m) 11 : endsegment 12 : segment itrav 13 : real*8 a(n,n),b(n),c(n),bb(n,n) 14 : integer is(n) 15 : endsegment 16 : data MOT /'POID'/ 17 : * lecture de la valeur de depart des paramatres 17 : call lirobj ('LISTREEL',mlpar,1,iretou) 18 : mlreel=mlpar 19 : segact mlreel 20 : nparr = prog(/1) 21 : * lecture de la valeur theorique 21 : call lirobj('LISTREEL',mlreel,1,iretou) 22 : if(ierr.ne.0) return 23 : segact mlreel 24 : npmes=prog(/1) 25 : * lecture de la valeur de depart 25 : call lirobj('LISTREEL',mlree1,1,iretou) 26 : if(ierr.ne.0) return 27 : segact mlree1 28 : if(mlree1.prog(/1).ne.npmes) then 29 : write(6,*)' erreur 0 npmes mlree1.prog', npmes,mlree1.prog(/1) 29 : call erreur (19) 30 : return 31 : endif 32 : m=100 33 : segini itra 34 : * write(6,*) ' nb de parametres ',nparr 35 : do 1 i=1,nparr 36 : * lecture des sensibilité par rapport au n parametres 36 : call lirobj('LISTREEL',mlree2,1,iretou) 37 : if(ierr.ne.0) then 38 : write(6,*) ' erreur 1' 38 : call erreur (19) 39 : return 40 : endif 41 : segact mlree2 42 : do iy=1,mlree2.prog(/1) 43 : if( mlree2.prog(iy).ne.0.d0) go to 10 44 : enddo 45 : go to 1 46 : 10 continue 47 : ibon(i)=1 48 : if(mlree2.prog(/1).ne.npmes) then 49 : write(6,*)' erreur 2 npmes mlree2.prog', npmes,mlree2.prog(/1) 49 : call erreur (19) 50 : return 51 : endif 52 : npara=npara+1 53 : ipoi(npara)=mlree2 54 : 1 continue 55 : if( npara.eq.0) then 56 : write(6,*) ' erreur 3 npara ',npara 56 : call erreur (19) 57 : return 58 : endif 59 : * lecture de l'option POIDS 59 : call lirmot(mot,1,itrou,0) 60 : if( itrou.eq.0) then 61 : jg=npmes 62 : isup=1 63 : segini mlree5 64 : do io=1,npmes 65 : mlree5.prog(io)=1.d0 66 : enddo 67 : else 68 : * lecture du poids 68 : call lirobj('LISTREEL',mlree5,1,iretou) 69 : if(ierr.ne.0)return 70 : segact mlree5 71 : isup=0 72 : endif 73 : n = npara 74 : segini itrav 75 : do 3 i=1,npmes 76 : do 4 j=1,npara 77 : mlree3=ipoi(j) 78 : x1=mlree3.prog(i)*2. *mlree5.prog(i)*mlree5.prog(i) 79 : do 5 k=1,npara 80 : mlree4=ipoi(k) 81 : xk=mlree4.prog(i) 82 : a(j,k)=a(j,k)+x1*xk 83 : 5 continue 84 : b(j) = b(j) + x1 * ( mlreel.prog(i)-mlree1.prog(i)) 85 : 4 continue 86 : 3 continue 87 : * 88 : ** appel a l'inversion 89 : * 90 : * write(6,*) ' avant inversion' 91 : * write(6,*) ( a(1,it),it=1,npara) 92 : * write(6,*) ( a(2,it),it=1,npara) 93 : * write(6,*) ( a(3,it),it=1,npara) 94 : 95 : diamax=0. 96 : do io=1,npara 97 : if( abs(a(io,io)).gt.diamax) diamax=abs(a(io,io)) 98 : enddo 99 : eps = diamax / 1.e10 99 : call inver (A,npara,icrit,c,is,eps) 100 : if(icrit.ne.0) then 100 : call erreur(21) 101 : return 102 : endif 103 : * write(6,*) ' apres inversion' 104 : * write(6,*) ( a(1,it),it=1,npara) 105 : * write(6,*) ( a(2,it),it=1,npara) 106 : * write(6,*) ( a(3,it),it=1,npara) 107 : 108 : * write(6,*) ' b ' 109 : * write(6,*) ( b(it),it=1,npara) 110 : if(isup.eq.1) then 111 : segsup mlree5 112 : else 113 : segdes mlree5 114 : endif 115 : jg=npara 116 : segini mlree5 117 : do 50 io=1,npara 118 : mlree5.prog(io)=0.d0 119 : do 6 iu=1,npara 120 : mlree5.prog(io)=mlree5.prog(io)+a(io,iu)*b(iu) 121 : 6 continue 122 : 50 continue 123 : * write(6,*) 'valeur trouvées dans moca' 124 : * write(6,*) (mlree5.prog(io),io=1,npara) 125 : segdes mlreel,mlree1 126 : do io=1,npara 127 : mlree3=ipoi(io) 128 : segdes mlree3 129 : enddo 130 : jg=nparr 131 : segini mlreel 132 : ia=1 133 : mlree2=mlpar 134 : do ib=1,nparr 135 : if(ibon(ib).eq.1)then 136 : prog(ib)=mlree5.prog(ia) + mlree2.prog(ib) 137 : ia=ia+1 138 : else 139 : prog(ib)=mlree2.prog(ib) 140 : endif 141 : enddo 142 : segdes mlreel,mlree2 143 : segsup mlree5 143 : call ecrobj('LISTREEL',mlreel) 144 : segsup itrav,itra 145 : return 146 : end 147 : 148 : 149 : 150 : 151 : 152 : 153 : 154 :
© Cast3M 2003 - All rights reserved.
Disclaimer