1 : C KPRO SOURCE CHAT 05/01/13 01:05:02 5004 2 : C KRED SOURCE MAGN 93/12/20 22:56:40 1003 3 : SUBROUTINE KPRO 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C************************************************************************* 7 : C 8 : C Operateur KPRO 9 : C 10 : C OBJET : to project CHAMPOINT 11 : C SYNTAXE : CHR = KPRO CHP GEO ; 12 : C 13 : C CHP : CHPOINT 14 : C CHR : CHPOINT 15 : C GEO : MAILLAGE (SEG2 or SEG3) 16 : C 17 : C CHR is the projection of CHP following the connectivities GEO. 18 : C The value of CHP at point 1 of each element of GEO (if exists) 19 : C is projected to the point 2 of the same element of GEO thus to 20 : C constitute CHR. 21 : C 22 : C************************************************************************* 23 : CHARACTER*8 TYPE 24 : 25 : -INC CCOPTIO 26 : -INC SMCOORD 27 : -INC SMCHPOI 28 : POINTEUR MCHP.MCHPOI,MSPO.MSOUPO,MVAL.MPOVAL 29 : POINTEUR NCHP.MCHPOI,NSPO.MSOUPO,NVAL.MPOVAL 30 : -INC SMELEME 31 : POINTEUR MGEO.MELEME,MSPG.MELEME,NSPG.MELEME 32 : 33 : SEGMENT LOCSGM 34 : INTEGER ICHP(NPART) 35 : ENDSEGMENT 36 : 37 : C*** 38 : 39 : C Reading the CHPOINT 40 : 41 : TYPE='CHPOINT ' 41 : CALL LIROBJ(TYPE,MCHP,0,IRET) 42 : IF(IRET.EQ.0) THEN 43 : WRITE(6,*)'On attend un CHAMPOINT' 44 : RETURN 45 : ENDIF 46 : 47 : C Reading the MAILLAGE 48 : 49 : TYPE='MAILLAGE' 49 : CALL LIROBJ(TYPE,MGEO,0,IRET) 50 : IF(IRET.EQ.0) THEN 51 : WRITE(6,*)'On attend un MAILLAGE' 52 : RETURN 53 : ENDIF 54 : 55 : C Veryfing the MAILLAGE 56 : inoeu = 2 57 : SEGACT MGEO 58 : ITIPO=MGEO.ITYPEL 59 : IF(ITIPO.LT.2.OR.ITIPO.GT.3) THEN 60 : WRITE(6,*)'On attend un MAILLAGE compose de SEG2 ou SEG3' 61 : RETURN 62 : ENDIF 63 : if(itipo.eq.3) inoeu = 3 64 : NELGEO=MGEO.NUM(/2) 65 : NBNN =1 66 : NBSOUS=0 67 : NBREF =0 68 : 69 : SEGACT MCHP 70 : 71 : NPART=MCHP.IPCHP(/1) 72 : NAT =MCHP.JATTRI(/1) 73 : SEGINI LOCSGM 74 : 75 : IPART=0 76 : DO I=1,NPART 77 : 78 : MSPO=MCHP.IPCHP(I) 79 : SEGACT MSPO 80 : 81 : MSPG=MSPO.IGEOC 82 : MVAL=MSPO.IPOVAL 83 : SEGACT MSPG,MVAL 84 : 85 : NC =MVAL.VPOCHA(/2) 86 : NELSPG=MSPG.NUM(/2) 87 : N =NELGEO 88 : NBELEM=NELGEO 89 : SEGINI NSPG,NVAL 90 : NSPG.ITYPEL=1 91 : 92 : NPUNTO=0 93 : DO J=1,NELGEO 94 : DO K=1,NELSPG 95 : IELGEO=MGEO.NUM(1,J) 96 : IELSPG=MSPG.NUM(1,K) 97 : IF(IELGEO.EQ.IELSPG) THEN 98 : NPUNTO=NPUNTO+1 99 : NSPG.NUM(1,NPUNTO)=MGEO.NUM(inoeu,J) 100 : DO L=1,NC 101 : NVAL.VPOCHA(NPUNTO,L)=MVAL.VPOCHA(K,L) 102 : ENDDO 103 : GO TO 100 104 : ENDIF 105 : ENDDO 106 : 100 CONTINUE 107 : ENDDO 108 : 109 : IF(NPUNTO.EQ.0) THEN 110 : SEGSUP NSPG,NVAL 111 : SEGDES MSPG,MVAL,MSPO 112 : GO TO 200 113 : ELSEIF(NPUNTO.NE.NBELEM) THEN 114 : NBELEM=NPUNTO 115 : N =NPUNTO 116 : SEGADJ NSPG,NVAL 117 : ENDIF 118 : 119 : SEGINI NSPO 120 : NSPO.IGEOC =NSPG 121 : NSPO.IPOVAL=NVAL 122 : DO L=1,NC 123 : NSPO.NOCOMP(L)=MSPO.NOCOMP(L) 124 : NSPO.NOHARM(L)=MSPO.NOHARM(L) 125 : ENDDO 126 : 127 : NSOUPO=1 128 : SEGINI NCHP 129 : NCHP.MTYPOI =MCHP.MTYPOI 130 : NCHP.MOCHDE =MCHP.MOCHDE 131 : NCHP.IFOPOI =MCHP.IFOPOI 132 : NCHP.IPCHP(1)=NSPO 133 : DO L=1,NAT 134 : NCHP.JATTRI(L)=MCHP.JATTRI(L) 135 : ENDDO 136 : 137 : IPART=IPART+1 138 : ICHP(IPART)=NCHP 139 : 140 : SEGDES NCHP,NSPO,NSPG,NVAL,MSPG,MVAL,MSPO 141 : 142 : 200 CONTINUE 143 : 144 : ENDDO 145 : 146 : SEGDES MCHP 147 : 148 : IF(IPART.EQ.0) THEN 149 : WRITE(6,*)'Le CHPOINT e le MAILLAGE n''ont pas de point commun' 150 : SEGSUP LOCSGM 151 : RETURN 152 : ENDIF 153 : 154 : NCHP=ICHP(1) 154 : CALL ECROBJ('CHPOINT ',NCHP) 155 : 156 : IF(IPART.GT.1) THEN 157 : DO I=2,IPART 158 : NCHP=ICHP(I) 158 : CALL ECROBJ('CHPOINT ',NCHP) 158 : CALL PRFUSE 159 : ENDDO 160 : ENDIF 161 : 162 : SEGSUP LOCSGM 163 : 164 : RETURN 165 : END 166 : 167 :
© Cast3M 2003 - All rights reserved.
Disclaimer