1 : C LICHPO SOURCE PV 11/03/07 21:17:25 6885 2 : SUBROUTINE LICHPO(NBAND,ITLACC,IMAX1,IRET,IFORM) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C======================================================================= 6 : C BUT : LECTURE D UN CHAMPOIN 7 : C APPELE PAR : LIPIL 8 : C APPELLE : LFCDIM LFCDIE LFCDI2 9 : C ECRIT PAR FARVACQUE -REPRIS PAR LENA 10 : C 11 : C======================================================================= 12 : C======================================================================= 13 : -INC SMCHPOI 14 : -INC CCOPTIO 15 : C 16 : C 17 : C======================================================================= 18 : SEGMENT/ITBBE1/( ITABE1(NN)) 19 : SEGMENT/ITBBE2/( ITABE2(NN)) 20 : SEGMENT/ITBBM1/( ITABM1(NM)) 21 : segment itbbc1 22 : character*4 itabc1(nm) 23 : endsegment 24 : * segment itbbc2 25 : * character*4 itabc2(nm2) 26 : * endsegment 27 : SEGMENT/ITBBM2/( ITABM2(NM2)) 28 : SEGMENT/ITLACC/( ITLAC(0)) 29 : DIMENSION ILENA(10) 30 : character*80 itabc2 31 : C-------------------------------------------------------------------- 32 : IRET=0 33 : IRETOU=0 34 : C **************************CHPOINT********************************* 35 : NN=0 36 : NM=0 37 : NM2=20 38 : ITBBM2 =0 39 : ITBBE1 =0 40 : ITBBM1 =0 41 : ITBBE2 =0 42 : SEGINI ITBBM2 43 : SEGINI ITBBM1,itbbc1 44 : * SEGINI ITBBM2 45 : * SEGINI ITBBM1 46 : SEGINI ITBBE2 47 : SEGINI ITBBE1 48 : C write(6,*)' lichpo imax1 iobnive iform' , imax1 ,ionive,iform 49 : DO 1101 IEL=1,IMAX1 50 : C 51 : C MODIF ATTRIBUT DANS CHPO PAR DEGAY 52 : IF ( IONIVE .GE. 6 ) THEN 53 : NTOTO=4 54 : ELSE 55 : NTOTO=3 56 : ENDIF 57 : MCHPOI=0 58 : do 36 k=1,4 59 : 36 ilena(k)=0 59 : CALL LFCDIE(NBAND,NTOTO,ILENA,IRETOU,IFORM) 60 : IF (IRETOU.NE.0) GO TO 1000 61 : NSOUPO = ILENA(1) 62 : NM = ILENA(2) 63 : J = ILENA(3) 64 : C write(6,*) ' ' 65 : C write(6,*) ' ' 66 : C write(6,*) ' chpoint ' ,iel , ' nsoupo ' , nsoupo, 'nm', nm 67 : IF ( IONIVE .GE. 6 ) THEN 68 : NAT = ILENA(4) 69 : ELSE 70 : C UN SEUL ATTRIBUT SUR LES VIEUX CHPO 71 : NAT = 1 72 : ENDIF 73 : * 74 : * JE NE SAIT PAS A QUOI NI A QUI CA SERT 75 : * MAIS MOI CA ME DESSERT - PV - 76 : * ITEST= NSOUPO+NM+J 77 : * IF (ITEST.EQ.0) GO TO 11 78 : SEGINI MCHPOI 79 : IFOPOI=J 80 : NN=3*NSOUPO 81 : SEGADJ ITBBE1 82 : SEGADJ ITBBM1,itbbc1 83 : SEGADJ ITBBM1 84 : C write(6,*) ' lichpo deuxieme appel a lfcdie nn ' , nn 84 : CALL LFCDIE(NBAND,NN,ITABE1,IRETOU,IFORM) 85 : C write(6,*) ' apres 2eme enreg iretou' , iretou 86 : IF(IRETOU.NE.0) GOTO 1000 87 : C write(6,*) ' av troisieme appel lfcdim nm',nm 87 : if (iform.ne.2) CALL LFCDIM(NBAND,NM,ITABM1,IRETOU,IFORM) 87 : if (iform.eq.2) call lfdien(nband,nm,itbbC1,iretou,iform) 88 : C write(6,*) ' apres 3eme enreg iretou' , iretou 89 : IF(IRETOU.NE.0) GOTO 1000 90 : NN=NM 91 : SEGADJ ITBBE2 92 : C write(6,*) ' av 4éme appel lfcdie nn ' , nn 92 : CALL LFCDIE(NBAND,NN,ITABE2,IRETOU,IFORM) 93 : C write(6,*) ' apres 4eme enreg iretou' , iretou 94 : IF(IRETOU.NE.0) GOTO 1000 95 : C write(6,*) ' av 5éme appel lfcdim nm2 ' , nm2 95 : if (iform.ne.2) CALL LFCDIM(NBAND,NM2,ITABM2,IRETOU,IFORM) 95 : if (iform.eq.2) call lfcdic(nband,itabc2(1:80),iretou,iform) 96 : C write(6,*) ' apres 5eme enreg iretou' , iretou 97 : IF(IRETOU.NE.0) GOTO 1000 98 : if (iform.ne.2) then 99 : WRITE (MTYPOI,FMT='(2A4)') ITABM2(1),ITABM2(2) 100 : WRITE (MOCHDE,FMT='(18A4)') (ITABM2(I+2),I=1,18) 101 : endif 102 : if (iform.eq.2) then 103 : mtypoi=itabc2(1:8) 104 : mochde=itabc2(9:80) 105 : endif 106 : C MODIF DES CHPO PAR DEGAY 107 : IF ( IONIVE .GE. 6 ) THEN 108 : C write(6,*) ' av 6eme appel lfcdie nat ' , nat 108 : CALL LFCDIE(NBAND,NAT,JATTRI,IRETOU,IFORM) 109 : C write(6,*) ' apres 6eme enreg iretou' , iretou 110 : IF (IRETOU .NE. 0) GOTO 1000 111 : ELSE 112 : C LE VIEUX CHPO RESTITUE EST INDETERMINE 113 : JATTRI(1) = 0 114 : ENDIF 115 : C--- 116 : ICC=0 117 : C write(6,*) ' nsoupo av boucle', nsoupo 118 : IF (NSOUPO.EQ.0) GO TO 13 119 : DO 1103 ISOU=1,NSOUPO 120 : NC=ITABE1(3*ISOU) 121 : SEGINI MSOUPO 122 : IPCHP(ISOU)=MSOUPO 123 : IGEOC=ITABE1(3*ISOU -2) 124 : N=ITABE1(3*ISOU -1) 125 : C write(6,*) ' isou nc n igeoc ', isou, nc, n , igeoc 126 : DO 1102 IC=1,NC 127 : ICC=ICC+1 128 : if (iform.ne.2) WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC) 129 : if (iform.eq.2) nocomp(ic)=itabc1(icc) 130 : * WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC) 131 : NOHARM(IC)=ITABE2(ICC) 132 : 1102 CONTINUE 133 : SEGINI MPOVAL 134 : IPOVAL=MPOVAL 135 : LMAX=N*NC 136 : C WRITE(6,*) ' ON APPELE LFCDIE AVEC LMAX = ' , LMAX 136 : CALL LFCDI2(NBAND,LMAX,VPOCHA,IRETOU,IFORM) 137 : IF(IRETOU.NE.0) GOTO 1000 138 : SEGDES MPOVAL 139 : segdes MSOUPO 140 : 1103 CONTINUE 141 : 13 CONTINUE 142 : SEGDES MCHPOI 143 : 11 ITLAC(**)=MCHPOI 144 : 1101 CONTINUE 145 : GO TO 1098 146 : 1000 CONTINUE 147 : C write(6,*) ' lihpo on tombe en 1000' 148 : IRETOU=1 149 : IF(MCHPOI.NE.0) SEGSUP MCHPOI 150 : 1098 CONTINUE 151 : IRET=IRETOU 152 : IF (ITBBM1.NE.0) SEGSUP ITBBM1,itbbc1 153 : IF (ITBBM2.NE.0) SEGSUP ITBBM2 154 : IF (ITBBE1.NE.0) SEGSUP ITBBE1 155 : IF (ITBBE2.NE.0) SEGSUP ITBBE2 156 : RETURN 157 : C ------------------------------------------------------- 158 : END 159 : 160 : 161 : 162 :
© Cast3M 2003 - All rights reserved.
Disclaimer