1 : C DEDU3 SOURCE PV 11/03/08 21:15:19 6888 2 : C 3 : SUBROUTINE DEDU3(IPCHPO,XERR1) 4 : ************************************************************************ 5 : * 6 : * DEDU3 7 : * 8 : * 9 : * FONCTION: 10 : * -appelé par PROPER.eso 11 : * -TESTE SI UN CHPOINT DE TRANSFORMATION U REPRESENTE UNE TRANSLATION 12 : * -calcule l'ecart relatif à une translation : 13 : * XERR1 = | max_x(IPOIN1(x)) - min_x(IPOIN1(x)) |_relatif 14 : * 15 : * CREATION,MODIFICATION: 16 : * - creation : 07/2009 (BP) 17 : * 18 : ************************************************************************ 19 : * 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8 (A-H,O-Z) 22 : -INC CCOPTIO 23 : -INC SMCHPOI 24 : -INC SMELEME 25 : -INC SMCOORD 26 : * 27 : * 28 : ***** INITIALISATIONS ************************************************** 29 : * 30 : * -ERREUR RELATIVE, LONGUEUR CARACTERISTIQUE 31 : XERR1 = 0.D0 32 : XREF1 = 0.D0 33 : 34 : * -ACTIVATION DU CHPOINT DE TRANSFORMATION 35 : MCHPOI = IPCHPO 36 : SEGACT,MCHPOI 37 : NSOUPO = IPCHP(/1) 38 : * 39 : * 40 : ***** RECHERCHE DU MAXIMUM par ZONE ************************************ 41 : 42 : *-----boucle sur les zones du chpoint 43 : DO 100 IB100=1,NSOUPO 44 : * 45 : * -sous-chpoint 46 : MSOUPO = IPCHP(IB100) 47 : SEGACT,MSOUPO 48 : 49 : * -ouverture du mpoval 50 : NC = NOCOMP(/2) 51 : MPOVAL = IPOVAL 52 : SEGACT,MPOVAL 53 : 54 : * -creation de mpova1 contenant le maxi et le mini 55 : N = 2 56 : segini,mpova1 57 : IDEB = 0 58 : 59 : * -ouverture du meleme pour avoir une distance de reference XREF100 60 : XREF100 = 0.D0 61 : IPT3 = IGEOC 62 : segact,IPT3 63 : N3 = IPT3.NUM(/2) 64 : 65 : *--------boucle sur les points 66 : N = VPOCHA(/1) 67 : * write(6,*) 'N3=N?',N3,N 68 : if (N.gt.0) then 69 : DO 110 IB110=1,N 70 : 71 : *----------1ere rencontre avec boucle sur les composantes 72 : IF(IDEB.eq.0) THEN 73 : IDEB = 1 74 : * -recup des coordonnées 75 : IP = IPT3.NUM(1,IB110) 76 : X1 = XCOOR((IP-1)*(IDIM+1) +1) 77 : Y1 = XCOOR((IP-1)*(IDIM+1) +2) 78 : XMAX1 = X1 79 : XMIN1 = X1 80 : YMAX1 = Y1 81 : YMIN1 = Y1 82 : if(IDIM.EQ.3) then 83 : Z1 = XCOOR((IP-1)*(IDIM+1) +3) 84 : ZMAX1 = Z1 85 : ZMIN1 = Z1 86 : endif 87 : * -boucle sur les composantes 88 : DO 120 IB120=1,NC 89 : XVAL = VPOCHA(IB110,IB120) 90 : mpova1.VPOCHA(1,IB120) = XVAL 91 : mpova1.VPOCHA(2,IB120) = XVAL 92 : 120 CONTINUE 93 : goto 110 94 : ENDIF 95 : 96 : *----------recup des coordonnées 97 : IP = IPT3.NUM(1,IB110) 98 : X1 = XCOOR((IP-1)*(IDIM+1) +1) 99 : Y1 = XCOOR((IP-1)*(IDIM+1) +2) 100 : if(X1.gt.XMAX1) XMAX1 = X1 101 : if(X1.lt.XMIN1) XMIN1 = X1 102 : if(Y1.gt.YMAX1) YMAX1 = Y1 103 : if(Y1.lt.YMIN1) YMIN1 = Y1 104 : if(IDIM.EQ.3) then 105 : Z1 = XCOOR((IP-1)*(IDIM+1) +3) 106 : if(Z1.gt.ZMAX1) ZMAX1 = Z1 107 : if(Z1.lt.ZMIN1) ZMIN1 = Z1 108 : endif 109 : 110 : *----------boucle sur les composantes 111 : DO 121 IB120=1,NC 112 : XVAL = VPOCHA(IB110,IB120) 113 : * -tests 114 : if(XVAL.gt.(mpova1.VPOCHA(1,IB120))) 115 : $ mpova1.VPOCHA(1,IB120) = XVAL 116 : if(XVAL.lt.(mpova1.VPOCHA(2,IB120))) 117 : $ mpova1.VPOCHA(2,IB120) = XVAL 118 : 121 CONTINUE 119 : 120 : 110 CONTINUE 121 : *--------fin de boucle sur les points 122 : 123 : *--------calcul de XREF100 124 : * write(6,*) 'MAX=',XMAX1,YMAX1,ZMAX1 125 : * write(6,*) 'MIN=',XMIN1,YMIN1,ZMIN1 126 : XREF100 = (XMAX1 - XMIN1) + (YMAX1 - YMIN1) + (ZMAX1 - ZMIN1) 127 : XREF100 = XREF100 / N 128 : *--------calcul de la norme XERR100 = |max(U_ib100) - min(U_ib100)|_1 129 : XERR100 = 0.D0 130 : DO 129 IB120=1,NC 131 : UMAX1 = mpova1.VPOCHA(1,IB120) 132 : UMIN1 = mpova1.VPOCHA(2,IB120) 133 : XERR100 = XERR100 + (UMAX1-UMIN1) 134 : 129 CONTINUE 135 : *--------moyenne des zones 136 : XREF1 = XREF1 + XREF100 137 : XERR1 = max(XERR1,XERR100) 138 : * write(6,*) 'XREF100,XERR100 = ',XREF100,XERR100 139 : 140 : endif 141 : *--------fin deu cas (N.ne.0) 142 : 143 : *--------quelques desactivations... 144 : segsup,mpova1 145 : segdes,IPT3,MPOVAL,MSOUPO 146 : 147 : 100 CONTINUE 148 : *-----fin de boucle sur les zones 149 : 150 : 151 : ***** ECART RELATIF A UNE TRANSLATION ********************************** 152 : * 153 : XREF1 = XREF1 / NSOUPO 154 : XERR1 = XERR1 / XREF1 155 : * write(6,*) '=> XREF1,XERR1 = ',XREF1,XERR1 156 : 157 : 158 : RETURN 159 : END 160 : 161 : 162 : 163 :
© Cast3M 2003 - All rights reserved.
Disclaimer