***************************************************************** * Программа расчета показателей загрязнения атмосферы города ***************************************************************** DIMENSION KO(20),CBI(20),CBP(20),AI(20),BI(20), *DI(20),AP(20),BP(20),DP(20) DIMENSION CPI(20,20),SI(20),CI(20),CP(20),SP(20) COMMON /ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 INTEGER GODP,MECP,GOD1,MEC1 character stat1*3, f_name*4,INGR*6,II(20)*1 character*17 POST1(20),POST2(20) INTEGER D1 INTEGER CPR,CN DIMENSION S3(2000) INTEGER D3(2000) COMMON/UR/CBI,CBP,INGR(80),POST1,POST2 COMMON/URN/AI,AP,A INTEGER Q(20,20),PDK(20) INTEGER QM(20) INTEGER SICP(20),SPCP(20),SCP INTEGER SUM INTEGER P,C INTEGER PH(20),GOD,MEC,DATA,CPOK COMMON GOD, MECP, godp, gorod, bt(20) character gorod*12 ! название города в родительном падеже INTEGER SCCP, kon(20,20) logical log1 data k8,k9/0,0/ * --------------------------- * open system file 5 and 6 open(5, file='input.zag') open(6, file='output.zag') * DEFINE FILE 1(1,7200,E,II) inquire(file ='scuzaim',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(1, file='scuzaim', access='direct',recl=7200,status=stat1, & form='unformatted') * DEFINE FILE2(1,7200,E,II1) inquire(file ='scuzapm',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(2, file='scuzapm', access='direct',recl=7200,status=stat1, & form='unformatted') * DEFINE FILE3(1,960,E,K1) inquire(file ='scuzcbim',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(3, file='scuzcbim', access='direct',recl=960 ,status=stat1, & form='unformatted') * DEFINE FILE4(1,960,E,K2) inquire(file ='scuzcbpm',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(4, file='scuzcbpm', access='direct',recl=960 ,status=stat1, & form='unformatted') * DEFINE FILE10(1,960,E,K3) inquire(file ='scuzcim',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(10, file='scuzcim', access='direct',recl=960 ,status=stat1, & form='unformatted') * DEFINE FILE11(1,912,E,K4) inquire(file ='scuzcpm',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(11, file='scuzcpm', access='direct',recl=912 ,status=stat1, & form='unformatted') * DEFINE FILE12(1,12,E,K5) inquire(file ='scuzgkm',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(12, file='scuzgkm', access='direct',recl=20 ,status=stat1, & form='unformatted') * DEFINE FILE13(2000,8,E,K6) inquire(file ='siozdis',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(13, file='siozdis', access='direct',recl=8,status=stat1, & form='unformatted') * DEFINE FILE14(9,1620,E,K7) inquire(file ='siozcdg',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(14, file='siozcdg', access='direct',recl=1620,status=stat1, & form='unformatted') inquire(file ='mecdan',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(15, file='mecdan',status=stat1) inquire(file ='zamer',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(21, file='zamer',status=stat1,form='unformatted') READ(5,27)I,P,C,L4,L6,L8 READ(5,301)GOROD DO 303 L=1,4 READ(5,300) (INGR(K),II(K),K=(L-1)*I+1,L*I) 303 CONTINUE DO 304 M=1,P READ(5,302)POST1(M),PH(M) 304 READ(5,305)POST2(M) READ(5,100)CB,CB1,A,B,D,R,R1,C7,C8,C9,C10,C11,C12,C13 READ(5,101)(CBI(K),K=1,I) READ(5,101)(CBP(M),M=1,P) READ(5,101)(AI(K),K=1,I) READ(5,101)(BI(K),K=1,I) READ(5,125)(DI(K),K=1,I) READ(5,101)(AP(M),M=1,P) READ(5,101)(BP(M),M=1,P) READ(5,101)(DP(M),M=1,P) READ(5,102)(PDK(K),K=1,I) read(5,202)(bt(k), k = 1, i) READ(5,104)(QM(K),K=1,I) READ(5,103)(KO(K),K=1,I) READ(5,103)SUM 202 format(20f6.5) C OPГAHИЗAЦИЯ ЦИKЛA ПO CPOKAM C2=0.0 L2=0 C9N=C9 CPR=0 IF(C.GT.9) GO TO 44 IF(C11.EQ.1.) GO TO 44 if(l6 .ne. 0) go to 44 30 K7=1 READ(14,rec=K7,end=44)CPR,GOD,MEC,DATA,CPOK,((Q(M,K),M=1,P),K=1,I) 44 IF(L6.LE.1) GO TO 28 DO 26 J1=1,L6-1 26 READ(21,END=136,ERR=137)GOD,MEC,DATA,CPOK,((Q(M,K),M=1,P),K=1,I) 28 CN=C+CPR DO 1 J=1,CN IF(L6.EQ.0) GO TO 24 READ(21,END=158,ERR=159)GOD,MEC,DATA,CPOK,((Q(M,K),M=1,P),K=1,I) GO TO 29 24 IF(CPR.EQ.0) GO TO 45 C9=0. IF(J.GT.CPR) GO TO 45 K7=J READ(14,rec=K7)CPR,GOD,MEC,DATA,CPOK,((Q(M,K),M=1,P),K=1,I) GO TO 29 45 READ(5,120)GOD,MEC,DATA,CPOK IF(L8.EQ.1) GO TO 205 DO 18 K=1,I 18 READ(5,104)(Q(M,K),M=1,P) GO TO 206 205 DO 207 M=1,P 207 READ (5,104) (Q(M,K),K=1,I) 206 IF(C.GT.9) GO TO 29 C8=0. C9=C9N K7=J-CPR IF(K7.GT.9) GO TO 29 WRITE(14,rec=K7)C,GOD,MEC,DATA,CPOK,((Q(M,K),M=1,P),K=1,I) 29 K5=1 READ(12,rec=K5,end = 10000)GODP,MECP,K6,K8,K9 10000 continue !!!!!!! IF(K6.EQ.2001) K6=1 IF(MEC.EQ.0.OR.MEC.GT.12) GO TO 122 IF(GOD.LT.1970.OR.GOD.GT.2100) GO TO 122 IF(DATA.LE.31) GO TO 208 WRITE(6,*)'Ошибка даты в следующем сроке' WRITE (*,*) CHAR(7) 208 IF(C8.NE.1.) GO TO 201 IF(MEC.NE.MECP) GO TO 200 IF(GOD.NE.GODP) GO TO 156 201 GODP=GOD MECP=MEC L3=0 C3=0 C5=0. C6=0. DO 3 K=1,I L=0 C1=0.0 DO 2 M=1,P IF(Q(M,K).EQ.9999) GO TO 4 L5=Q(M,K) IF(Q(M,K).GT.QM(K).AND.L4.EQ.0) GO TO 124 CPI(M,K)=(Q(M,K)*1.0)/(PDK(K)*KO(K)**R) IF(CPI(M,K).EQ.9.99) CPI(M,K)=9.98 IF(CPI(M,K).LT.C5) GO TO 106 C5=CPI(M,K) M5=M K1=K 106 L=L+1 C1=C1+CPI(M,K) GO TO 2 4 CPI(M,K)=9.99 2 CONTINUE IF(L.EQ.0) CI(K)=9.99 IF(L.EQ.0) GO TO 3 CI(K)=C1/L L3=L3+L C3=C3+C1 3 continue * Расчет загрязненности города if(l3 .eq. 0) go to 11 IF(C3.EQ.0) GO TO 107 IF(C5*L3/C3.LT.C7) GO TO 107 C71=C7*C3/L3 C3=C3-C5+C71 C6=1. L=0 DO 108 M=1,P IF(CPI(M,K1).EQ.9.99) GO TO 108 L=L+1 C1=C1+CPI(M,K1) 108 CONTINUE CI(K1)=(C1+C71-C5)/L IF(CI(K1).EQ.9.99) CI(K1)=9.98 107 IF(CB.EQ.0.) GO TO 119 write(*,*)' Расчет загрязненности города' S=C3/(CB*L3) GO TO 37 119 S=C3/L3 IF(S.EQ.9.99) S=9.98 GO TO 37 11 S=9.99 37 DO 5 K=1,I IF(CI(K).EQ.9.99) GO TO 9 IF(L.EQ.0) SI(K)=9.99 IF(CBI(K).EQ.0.) GO TO 131 SI(K)=CI(K)/CBI(K) IF(SI(K).EQ.9.99) SI(K)=9.98 GO TO 5 131 SI(K)=CI(K) GO TO 5 9 SI(K)=9.99 5 CONTINUE IF(SUM.EQ.0) GO TO 16 DO 20 M=1,P KP=0 C Суммация для г.Тюмени IF((CPI(M,2).EQ.9.99).OR.(CPI(M,2).EQ.0.0)) GO TO 7 IF((CPI(M,5).NE.9.99).AND.(CPI(M,5).NE.0.0)) KP=KP+1 IF((CPI(M,6).NE.9.99).AND.(CPI(M,6).NE.0.0)) KP=KP+1 IF((CPI(M,7).NE.9.99).AND.(CPI(M,7).NE.0.0)) KP=KP+1 7 L=0 C1=0.0 DO 21 K=1,I IF(CPI(M,K).EQ.9.99) GO TO 21 L=L+1 C1=C1+CPI(M,K) 21 CONTINUE IF(L.NE..0) GO TO 23 CP(M)=9.99 SP(M)=9.99 GO TO 20 23 CP(M)=C1/(L-KP) IF(C6.EQ.0.) GO TO 109 IF(M.NE.M5) GO TO 109 CP(M)=(C1-C5+C71)/(L-KP) IF(CP(M).EQ.9.99) CP(M)=9.98 109 IF(CBP(M).EQ.0.) GO TO 132 SP(M)=CP(M)/CBP(M) IF(SP(M).EQ.9.99) SP(M)=9.98 GO TO 20 132 SP(M)=CP(M) 20 CONTINUE GO TO 66 16 DO 6 M=1,P L=0 C1=0.0 DO 10 K=1,I IF(CPI(M,K).EQ.9.99) GO TO 10 L=L+1 C1=C1+CPI(M,K) 10 CONTINUE IF(L.NE.0) GO TO 22 CP(M)=9.99 SP(M)=9.99 GO TO 6 22 CP(M)=C1/L IF(C6.EQ.0.) GO TO 118 IF(M.NE.M5) GO TO 118 CP(M)=(C1-C5+C71)/L IF(CP(M).EQ.9.99) CP(M)=9.98 118 IF(CBP(M).EQ.0.) GO TO 134 SP(M)=CP(M)/CBP(M) IF(SP(M).EQ.9.99) SP(M)=9.98 GO TO 6 134 SP(M)=CP(M) 6 CONTINUE 66 L=0 C1=0.0 DO 12 M=1,P IF(CP(M).EQ.9.99) GO TO 12 L=L+1 C1=C1+CP(M) 12 CONTINUE IF(L.EQ.0) GO TO 112 IF(CB1.EQ.0.) GO TO 126 S1=C1/(CB1*L) IF(S1.EQ.9.99) S1=9.98 GO TO 113 126 S1=C1/L IF(S1.EQ.9.99) S1=9.98 GO TO 113 112 S1=9.99 113 CONTINUE C CPABHEHИE ПO ИHГPEДИEHTAM DO 13 K=1,I IF(CBI(K).EQ.0.) GO TO 67 IF(SI(K).EQ.9.99) GO TO 67 IF(SI(K).LT.1) SICP(K)=99 IF((SI(K).GE.1).AND.(SI(K).LT.AI(K))) SICP(K)=9 IF((SI(K).GE.AI(K)).AND.(SI(K).LT.BI(K))) SICP(K)=1 IF((SI(K).GE.BI(K)).AND.(SI(K).LT.DI(K))) SICP(K)=2 IF(SI(K).GE.DI(K)) SICP(K)=3 GO TO 13 67 SICP(K)=90 13 CONTINUE C CPABHEHИE ПO ПУHKTAM DO 14 M=1,P IF(CBP(M).EQ.0.) GO TO 68 IF(SP(M).EQ.9.99) GO TO 68 IF(SP(M).LT.1) SPCP(M)=99 IF((SP(M).GE.1).AND.(SP(M).LT.AP(M))) SPCP(M)=9 IF((SP(M).GE.AP(M)).AND.(SP(M).LT.BP(M))) SPCP(M)=1 IF((SP(M).GE.BP(M)).AND.(SP(M).LT.DP(M))) SPCP(M)=2 IF(SP(M).GE.DP(M)) SPCP(M)=3 GO TO 14 68 SPCP(M)=90 14 CONTINUE C CPABHEHИE ПO ГOPOДУ IF(S.EQ.9.99) GO TO 114 IF(S.LT.1) SCP=99 IF((S.GE.1).AND.(S.LT.A)) SCP=9 IF((S.GE.A).AND.(S.LT.B)) SCP=1 IF((S.GE.B).AND.(S.LT.D)) SCP=2 IF(S.GE.D) SCP=3 GO TO 121 114 SCP=90 121 CONTINUE IF(S.EQ.9.99) GO TO 115 C2=C2+S L2=L2+1 115 CONTINUE DO 35 J1=3,CN,3 IF(J-J1) 40,33,35 35 CONTINUE 33 IF(L2.EQ.0) GO TO 116 SC=C2/L2 IF(SC.LT.1) SCCP=99 IF((SC.GE.1).AND.(SC.LT.A)) SCCP=9 IF((SC.GE.A).AND.(SC.LT.B)) SCCP=1 IF((SC.GE.B).AND.(SC.LT.D)) SCCP=2 IF(SC.GE.D) SCCP=3 GO TO 117 116 SC=9.99 SCCP=90 117 L2=0 C2=0.0 40 CONTINUE * Печать суточных показателей call PECPOK(s1,i,k,m,p,s,mec,sc,data,scp,sccp,cpok, & c2,c5,c6,c9,cpi,ph,si,sicp,sp,spcp) D1=CPOK+100*DATA+10000*MEC+1000000*GOD D3(J)=D1 S3(J)=S IF(C8.NE.1.) GO TO 1 IF(C13.EQ.1) GO TO 133 IF(K6.EQ.O) K6=1 WRITE(13,rec=K6)D1,S k6 = k6 + 1 133 CONTINUE * Запись данных за срок в файл MECDAN if(c8 .ne. 1 ) go to 6700 write(*,*) 'Запись данных за срок в MECDAN ','k9=',k9,'k8=',k8 if(k9.eq.0) go to 6702 rewind 15 do j1 = 1, k9 read(15,120,end=6702,err=146) kod, kec, kata, kpok do k = 1, i read(15,104,end=6702,err=147) (kon(m,k), m = 1,p) end do! k end do! j1 go to 6702 145 FORMAT(' В сроке с датой ',I12, ' обнаружен'/ & ' КОНЕЦ в файле MECDAN.'/ ) go to 6702 146 WRITE(6,148)D1 148 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА ДАТЫ в файле MECDAN.'/) DO J1=1,3 WRITE (*,*) CHAR(7) END DO go to 6702 147 WRITE(6,149)D1 149 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА КОНЦЕНТРАЦИИ в файле MECDAN.'/) DO J1=1,3 WRITE (*,*) CHAR(7) END DO 6702 continue if(k9.eq.0) rewind 15 write(15,120) god,mec,data,cpok do k = 1, i write(15,104) (q(m,k) , m = 1, p) end do! k k9=k9+1 rewind 15 6700 continue K5=1 WRITE(12,rec=K5)GODP,MECP,K6,K8,K9 DACP=DATA+0.01*CPOK CALL ZAPIS(I,P,SI,SP,S,S1,DACP) * ----------------------------- GO TO 1 200 CALL SCHETM(I,P,MEC,CBI,CBP,CB,CB1) * ------------------------------------------ call mecstat(i, p, pdk,pH) * ________________________ MEC1=MECP+1 IF(MEC1.EQ.13) MEC1=1 IF(MEC1.EQ.MEC) GO TO 209 WRITE(6,*)'Нарушена последовательность месяцев' WRITE(6,*)'в следующем сроке' WRITE (*,*) CHAR(7) * Перепись месячного файла MECDAN в файл с именем GOD 209 if(c8 .ne. 1) go to 6705 write(*,*) 'Перепись MECDAN в файл GOD','k8=',k8,'k9=',k9 write(f_name,'(i4)') god IF(GOD.NE.GODP) write(f_name,'(i4)') godp inquire(file =f_name,exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(16, file=f_name,status=stat1,form='unformatted') if(k8 .eq. 0) go to 6709 J12=0 do j1 = 1, k8 J12=J12+1 read (16, end = 6706, err = 142)kod,kec, kata, kpok, & ((kon(m,k), m=1,p), k = 1, i) end do! j1 go to 6709 6706 WRITE(6,141)D1,f_name 141 FORMAT(' После срока с датой ',I12, ' обнаружен'/ & ' КОНЕЦ в файле ',A4/ ) DO J1=1,3 WRITE (*,*) CHAR(7) END DO BACKSPACE 16 k8=j12-1 6709 continue rewind 15 do j1 = 1, k9 read(15,120, end=150, err =152) kod, kec, kata, kpok do k = 1, i read(15,104, end=150, err =153) (kon(m,k) , m=1,p) end do! k write(16) kod, kec, kata, kpok,((kon(m,k), m=1,p),k=1,i) k8 = k8 + 1 end do! j1 go to 6708 142 WRITE(6,143)D1,f_name DO J1=1,3 WRITE (*,*) CHAR(7) END DO 143 FORMAT(' После срока с датой ',I12, ' обнаружена'/ & ' ОШИБКА в файле ',A4/ ) go to 6708 150 WRITE(6,151)D1 151 FORMAT(' После срока ',I12, ' обнаружен'/ & ' КОНЕЦ в файле MECDAN при записи в файл GOD.'/ ) go to 6708 152 WRITE(6,154)D1 DO J1=1,3 WRITE (*,*) CHAR(7) END DO 154 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА ДАТЫ в файле MECDAN при записи в файл GOD.'/ ) go to 6708 153 WRITE(6,155)D1 DO J1=1,3 WRITE (*,*) CHAR(7) END DO 155 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА КОНЦЕНТРАЦИИ в файле MECDAN при записи в файл GOD.'/) 6708 continue k9=0 k5=1 WRITE(12,rec=K5)GODP,MECP,K6,K8,K9 rewind 15 rewind 16 6705 continue ********************* DO 7070 L=1,90 DO 70 M=1,20 70 AIM(M,L)=99.99 7070 continue DO 71 L=1,90 DO 71 M=1,20 71 APM(M,L)=99.99 I1=1 WRITE(1,rec=I1)AIM II1=1 WRITE(2,rec=II1)APM IF(GOD.EQ.GODP) GO TO 201 CALL SCHETG(I,P,CB,CB1) GOD1=GODP+1 IF(GOD1.EQ.GOD) GO TO 210 WRITE (6,*)'Нарушена последовательность года' WRITE(6,*)'в следующем сроке' WRITE (*,*) CHAR(7) 210 DO 72 L=1,12 DO 72 M=1,20 72 CBIM(M,L)=99.99 DO 73 L=1,12 DO 73 M=1,20 73 CBPM(M,L)=99.99 DO 74 L=1,12 DO 74 M=1,20 74 CIM(M,L)=99.99 DO 75 L=1,12 DO 75 M=1,19 75 CPM(M,L)=99.99 K1=1 WRITE(3,rec=K1)CBIM K2=1 WRITE(4,rec=K2)CBPM K3=1 WRITE(10,rec=K3)CIM K4=1 WRITE(11,rec=K4)CPM ***************************** call godstat(i,p,pH) k8 = 0 k5 = 1 WRITE(12,rec=K5)GODP,MECP,K6,K8,K9 ***************************** GO TO 201 1 CONTINUE GO TO 123 122 WRITE(6,42)D1 DO J1=1,3 WRITE (*,*) CHAR(7) END DO GO TO 123 137 J11=J1-1 WRITE(6,138)D1,J11 DO J1=1,3 WRITE (*,*) CHAR(7) END DO GO TO 123 158 J11=J+L6-1 WRITE(6,139)D1,J11 DO J1=1,3 WRITE (*,*) CHAR(7) END DO GO TO 123 159 J11=J+L6-1 WRITE(6,138)D1,J11 DO J1=1,3 WRITE (*,*) CHAR(7) END DO GO TO 123 136 J11=J1-1 WRITE(6,139)D1,J11 DO J1=1,3 WRITE (*,*) CHAR(7) END DO GO TO 123 124 WRITE(6,43)D1,k, m, L5, k, qm(k) DO J1=1,3 WRITE (*,*) CHAR(7) END DO go to 123 156 WRITE(6,157)D1 DO J1=1,3 WRITE (*,*) CHAR(7) END DO 157 FORMAT(' После срока ',I12, 'произошла смена'/ & ' GODa без смены месяца.'/ ) 123 CONTINUE IF(C10.EQ.1.) WRITE(6,39)(D3(L),S3(L),L=1,J) 27 FORMAT(2I3,I5,I3,I5,I3) 39 FORMAT(8(' ',I10,F5.2)) 138 FORMAT(' После срока с датой ',I12, ' с номером '/ & I5,' обнаружена ОШИБКА в файле ZAMER.'/ ) 139 FORMAT(' После срока с датой ',I12, ' с номером '/ & I5,' обнаружен КОНЕЦ файла ZAMER.'/ ) 42 FORMAT(' После срока с датой ',I12, ' обнаружена'/ & ' ОШИБКА даты следующего срока.'/ & ' Необходимо исправить ошибку и пересчитать '/ & ' (при с < 10 с ключом повтора)') 43 FORMAT(' После срока с датой ', i12,' в следующем'/ & ' сроке обнаружена концентрация ', i2, ' инградиента'/ & ' на ', i2, ' посту Q = ', i4, ' , которая превышает'/ & ' максимальную QM(', i2, ') =', i4,'. Необходимо'/ & ' проверить, исправить концентрацию и пересчитать'/ & ' (при с < 10 с ключом повтора).'/ & ' Если проверка затруднена, то пересчитать'/ & ' с ключом снятия контроля.'/ & ' Если значение концентрации Q верно,'/ & ' то изменить максимальную QM этого инградиента') 100 FORMAT(7F3.2,7F3.1) 101 FORMAT(20F3.2) 102 FORMAT(20I3) 103 FORMAT(20I1) 104 FORMAT(20I4) 125 FORMAT(20F4.2) 120 FORMAT(I4,I2,I2,I2) 300 FORMAT(20(A6,A1)) 301 FORMAT(A12) 302 FORMAT(A17,I4) 305 FORMAT(A17) END SUBROUTINE HMAX(I,A,SMAX) DIMENSION A(20,90),SMAX(20) SMAX(I)=-1 DO 1 J=1,90 IF(A(I,J).EQ.9.99.OR.A(I,J).EQ.99.99) GO TO 1 IF(A(I,J).GT.SMAX(I)) SMAX(I)=A(I,J) 1 CONTINUE IF(SMAX(I).EQ.-1)SMAX(I)=9.99 RETURN END SUBROUTINE HMAX1(I,A,SMAX) DIMENSION A(20,12),SMAX(20) SMAX(I)=-1 DO 1 J=1,12 IF(A(I,J).EQ.9.99.OR.A(I,J).EQ.99.99) GO TO 1 IF(A(I,J).GT.SMAX(I)) SMAX(I)=A(I,J) 1 CONTINUE IF(SMAX(I).EQ.-1) SMAX(I)=9.99 RETURN END SUBROUTINE ZAPIS(I,P,SI,SP,S,S1,DACP) DIMENSION SI(20),SP(20) COMMON /ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 INTEGER P I1=1 READ(1,rec=I1)AIM II1=1 READ(2,rec=II1)APM DO 1 J=1,90 IF(AIM(1,J).EQ.99.99) GO TO 2 GO TO 1 2 DO 3 K=1,I 3 AIM(K,J)=SI(K) AIM(19,J)=DACP AIM(20,J)=S GO TO 4 1 CONTINUE 4 CONTINUE I1=1 WRITE(1,rec=I1)AIM I1=1 READ(1,rec=I1)AIM DO 7 J=1,90 IF(APM(1,J).EQ.99.99) GO TO 8 GO TO 7 8 DO 9 M=1,P 9 APM(M,J)=SP(M) APM(19,J)=DACP APM(20,J)=S1 GO TO 10 7 CONTINUE 10 CONTINUE II1=1 WRITE(2,rec=II1)APM II1=1 READ(2,rec=II1)APM RETURN END *********************************************************************** * Программа расчета месячных данных *********************************************************************** SUBROUTINE SCHETM(I,P,MEC,CBI,CBP,CB,CB1) DIMENSION SIB(20),SPB(20),SIMAX(20),SPMAX(19) DIMENSION CBI(20),CBP(20) REAL M1(20),M2(20),M3(20),M4(19) COMMON/ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 INTEGER MEC,MECP,GOD,GODP COMMON GOD, MECP, godp, gorod, bt(20) INTEGER P MECRL=MECP*1.0 I1=1 READ(1,rec=I1,end=44,err=44)AIM K1=1 READ(3,rec=K1)CBIM K3=1 READ(10,rec=K3)CIM DO 1 K=1,I N1=0 S3=0.0 DO 2 J=1,90 IF(AIM(K,J).EQ.99.99) GO TO 2 IF(AIM(K,J).EQ.9.99) GO TO 2 S3=S3+AIM(K,J) N1=N1+1 2 CONTINUE SIB(K)=9.99 IF(N1.EQ.0) GO TO 34 SIB(K)=S3/N1 IF(SIB(K).EQ.9.99) SIB(K)=9.98 34 M1(K)=SIB(K)*CBI(K) IF(M1(K).EQ.9.99) M1(K)=9.98 IF(CBI(K).EQ.0.) M1(K)=SIB(K) IF(SIB(K).EQ.9.99) M1(K)=9.99 DO 4 J=1,12 IF(CBIM(K,J).EQ.99.99) GO TO 5 GO TO 4 5 CBIM(K,J)=M1(K) GO TO 10 4 CONTINUE 10 CONTINUE CALL HMAX(K,AIM,SIMAX) M3(K)=SIMAX(K)*CBI(K) IF(M3(K).EQ.9.99) M3(K)=9.98 IF(CBI(K).EQ.0.) M3(K)=SIMAX(K) IF(M1(K).EQ.9.99) M3(K)=9.99 DO 9 J=1,12 IF(CIM(K,J).NE.99.99) GO TO 9 CIM(K,J)=M3(K) GO TO 15 9 CONTINUE 15 CONTINUE 1 CONTINUE N2=0 S4=0.0 DO 3 J2=1,90 IF(AIM(20,J2).EQ.99.99) GO TO 3 IF(AIM(20,J2).EQ.9.99) GO TO 3 S4=S4+AIM(20,J2) N2=N2+1 3 CONTINUE SIB(20)=9.99 IF(N2.EQ.0) GO TO 35 SIB(20)=S4/N2 IF(SIB(20).EQ.9.99) SIB(20)=9.98 35 M1(20)=SIB(20)*CB IF(M1(20).EQ.9.99) M1(20)=9.98 IF(CB.EQ.0.) M1(20)=SIB(20) IF(SIB(20).EQ.9.99) M1(20)=9.99 DO 14 J=1,12 IF(CBIM(20,J).NE.99.99) GO TO 14 CBIM(20,J)=M1(20) CBIM(19,J)=MECRL GO TO 6 14 CONTINUE 6 CONTINUE K1=1 WRITE(3,rec=K1)CBIM CALL HMAX(20,AIM,SIMAX) M3(20)=SIMAX(20)*CB IF(M3(20).EQ.9.99) M3(20)=9.98 IF(CB.EQ.0.) M3(20)=SIMAX(20) IF(SIMAX(20).EQ.9.99) M3(20)=9.99 DO 12 J=1,12 IF(CIM(20,J).NE.99.99) GO TO 12 CIM(20,J)=M3(20) CIM(19,J)=MECRL GO TO 13 12 CONTINUE 13 CONTINUE K3=1 WRITE(10,rec=K3)CIM K1=1 READ(3,rec=K1)CBIM K3=1 READ(10,rec=K3)CIM II1=1 READ(2,rec=II1)APM K2=1 READ(4,rec=K2)CBPM K4=1 READ(11,rec=K4)CPM DO 17 M=1,P N1=0 S3=0.0 DO 28 J=1,90 IF(APM(M,J).EQ.99.99) GO TO 28 IF(APM(M,J).EQ.9.99) GO TO 28 S3=S3+APM(M,J) N1=N1+1 28 CONTINUE SPB(M)=9.99 IF(N1.GT.0) SPB(M)=S3/N1 M2(M)=SPB(M)*CBP(M) IF(M2(M).EQ.9.99) M2(M)=9.98 IF(CBP(M).EQ.0.) M2(M)=SPB(M) IF(SPB(M).EQ.9.99) M2(M)=9.99 DO 18 J=1,12 IF(CBPM(M,J).NE.99.99) GO TO 18 CBPM(M,J)=M2(M) GO TO 19 18 CONTINUE 19 CONTINUE CALL HMAX(M,APM,SPMAX) M4(M)=SPMAX(M)*CBP(M) IF(M4(M).EQ.9.99) M4(M)=9.98 IF(CBP(M).EQ.0.) M4(M)=SPMAX(M) IF(M2(M).EQ.9.99) M4(M)=9.99 DO 20 J=1,12 IF(CPM(M,J).NE.99.99) GO TO 20 CPM(M,J)=M4(M) CPM(19,J)=MECRL GO TO 21 20 CONTINUE 21 CONTINUE 17 CONTINUE N2=0 S4=0.0 DO 22 J=1,90 IF(APM(20,J).EQ.99.99) GO TO 22 IF(APM(20,J).EQ.9.99) GO TO 22 S4=S4+APM(20,J) N2=N2+1 22 CONTINUE SPB(20)=9.99 IF(N2.GT.0) SPB(20)=S4/N2 M2(20)=SPB(20)*CB1 IF(M2(20).EQ.9.99) M2(20)=9.98 IF(CB1.EQ.0.) M2(20)=SPB(20) IF(SPB(20).EQ.9.99) M2(20)=9.99 DO 23 J=1,12 IF(CBPM(20,J).EQ.99.99) GO TO 33 GO TO 23 33 CBPM(20,J)=M2(20) CBPM(19,J)=MECRL GO TO 24 23 CONTINUE 24 CONTINUE K2=1 WRITE(4,rec=K2)CBPM K4=1 WRITE(11,rec=K4)CPM IF(C12.EQ.1) GO TO 44 * Печать месячных данных call PEMEC(I,P,m1,m2,m3,m4) 44 CONTINUE RETURN END *********************************************************************** * Программа расчета годовых данных *********************************************************************** SUBROUTINE SCHETG(I,P,CB,CB1) COMMON/ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 COMMON/UR/CBI(20),CBP(20),INGR(80),POST1,POST2 COMMON/URN/AI(20),AP(20),A DIMENSION CBIG(20),CBPG(20),CIMG(20),CPMG(19),AIG(20),BIG(20), *DIG(20),APG(20),BPG(20),DPG(20),CIMAX(20),DEI(20),DEP(20) character*4 char1(4), char2(4) character*6 INGR character*17 POST1(20),POST2(20) INTEGERP,GOD1,GOD2,GODP,GOD3 INTEGER GOD COMMON GOD, MECP, godp, gorod, bt(20) char1(1) = 'CBIG' char1(2) = 'AIG ' char1(3) = 'BIG ' char1(4) = 'DIG ' char2(1) = 'CBPG' char2(2) = 'APG ' char2(3) = 'BPG ' char2(4) = 'DPG ' K1=1 READ(3,rec=K1,end=15,err=15)CBIM DO 1 K=1,I S3=0.0 N1=0 DO 2 J=1,12 IF(CBIM(K,J).EQ.99.99) GO TO 2 IF(CBIM(K,J).EQ.9.99) GO TO 2 S3=S3+CBIM(K,J) N1=N1+1 2 CONTINUE IF(N1.GT.0) CBIG(K)=S3/N1 IF(CBIG(K).EQ.9.99) CBIG(K)=9.98 IF(N1.EQ.0) CBIG(K)=9.99 1 CONTINUE S3=0.0 N1=0 DO 3 J=1,12 IF(CBIM(20,J).EQ.99.99) GO TO 3 IF(CBIM(20,J).EQ.9.99) GO TO 3 S3=S3+CBIM(20,J) N1=N1+1 3 CONTINUE IF(N1.GT.0) CBIG(20)=S3/N1 IF(CBIG(20).EQ.9.99) CBIG(20)=9.98 IF(N1.EQ.0) CBIG(20)=9.99 K2=1 READ(4,rec=K2)CBPM DO 4 M=1,P S2=0.0 N2=0 DO 5 J=1,12 IF(CBPM(M,J).EQ.99.99) GO TO 5 IF(CBPM(M,J).EQ.9.99) GO TO 5 S2=S2+CBPM(M,J) N2=N2+1 5 CONTINUE IF(N2.GT.0)CBPG(M)=S2/N2 IF(CBPG(M).EQ.9.99) CBPG(M)=9.98 IF(N2.EQ.0) CBPG(M)=9.99 4 CONTINUE S2=0.0 N2=0 DO 6 J=1,12 IF(CBPM(20,J).EQ.99.99) GO TO 6 IF(CBPM(20,J).EQ.9.99) GO TO 6 S2=S2+CBPM(20,J) N2=N2+1 6 CONTINUE IF(N2.GT.0) CBPG(20)=S2/N2 IF(CBPG(20).EQ.9.99) CBPG(20)=9.98 IF(N2.EQ.0) CBPG(20)=9.99 K3=1 READ(10,rec=K3)CIM DO 7 K=1,I CALL HMAX1(K,CIM,CIMAX) CIMG(K)=CIMAX(K) 7 CONTINUE CALL HMAX1(20,CIM,CIMAX) CIMG(20)=CIMAX(20) K4=1 READ(11,rec=K4)CPM DO 8 M=1,P CPMG(M)=-1. DO 13 J=1,12 IF(CPM(M,J).EQ.9.99.OR.CPM(M,J).EQ.99.99) GO TO 13 IF(CPM(M,J).GT.CPMG(M)) CPMG(M)=CPM(M,J) 13 CONTINUE IF(CPMG(M).EQ.-1) CPMG(M)=9.99 8 CONTINUE GOD2=GODP GOD1=GODP-1 GOD3=GOD * Печать годовых данных call PEGOD(I,P,CB,CB1,god1,god2,cbpg,cimg,cpmg,cbig) DO 9 K=1,I IF(CBIG(K).EQ.0..OR.CBIG(K).EQ.9.99) GO TO 60 IF(CBI(K).EQ.0.) GO TO 64 CBIG(K)=(CBIG(K)+CBI(K))/2 64 IF(CIMG(K).GT.11*CBIG(K)) CIMG(K)=11.*CBIG(K) IF(CBI(K).EQ.0.) GO TO 65 CIMG(K)=(CIMG(K)+(4*AI(K)-3)*CBI(K))/2 65 DEI(K)=((CIMG(K)/CBIG(K))-1)/4 GO TO 9 60 DEI(K)=.75 9 CONTINUE DO 10 M=1,P IF(CBPG(M).EQ.0..OR.CBPG(M).EQ.9.99) GO TO 61 IF(CBP(M).EQ.0.) GO TO 66 CBPG(M)=(CBPG(M)+CBP(M))/2 66 IF(CPMG(M).GT.11*CBPG(M)) CPMG(M)=11.*CBPG(M) IF(CBP(M).EQ.0.) GO TO 67 CPMG(M)=(CPMG(M)+(4*AP(M)-3)*CBP(M))/2 67 DEP(M)=((CPMG(M)/CBPG(M))-1)/4 GO TO 10 61 DEP(M)=.75 10 CONTINUE IF(CBIG(20).EQ.0..OR.CBIG(20).EQ.9.99) GO TO 62 IF(CB.EQ.0.) GO TO 68 CBIG(20)=(CBIG(20)+CB)/2 CBPG(20)=(CBPG(20)+CB1)/2 68 IF(CIMG(20).GT.11*CBIG(20)) CIMG(20)=11.*CBIG(20) IF(CB.EQ.0.) GO TO 69 CIMG(20)=(CIMG(20)+(4*A-3)*CB)/2 69 DE=((CIMG(20)/CBIG(20))-1)/4 GO TO 63 62 DE=.75 63 CONTINUE DO 11 K=1,I AIG(K)=1+DEI(K)*R1 BIG(K)=AIG(K)+DEI(K) DIG(K)=BIG(K)+DEI(K) 11 CONTINUE DO 12 M=1,P APG(M)=1+DEP(M)*R1 BPG(M)=APG(M)+DEP(M) DPG(M)=BPG(M)+DEP(M) 12 CONTINUE AG=1+DE*R1 BG=AG+DE DG=BG+DE WRITE(6,29)GOD3 WRITE(6,20) WRITE(6,22) WRITE(6,30)char1(1),(CBIG(K),K=1,I) WRITE(6,30)char1(2),(AIG(K),K=1,I) WRITE(6,30)char1(3),(BIG(K),K=1,I) WRITE(6,30)char1(4),(DIG(K),K=1,I) WRITE(6,2020) WRITE(6,24) WRITE(6,30)char2(1),(CBPG(M),M=1,P) WRITE(6,30)char2(2),(APG(M),M=1,P) WRITE(6,30)char2(3),(BPG(M),M=1,P) WRITE(6,30)char2(4),(DPG(M),M=1,P) WRITE(6,2020) WRITE(6,31) WRITE(6,3030)CBIG(20),CBPG(20),AG,BG,DG WRITE(6,20) 2020 FORMAT(' ') 20 FORMAT(' ',127('*')/) 21 FORMAT(40X,'Cреднегодовые нормировочные концентрации'/) 22 FORMAT(10X,'По инградиентам') 23 FORMAT(' ','*',1X,I4,1X,'*',19F6.3/) 24 FORMAT(10X,'По пунктам') 25 FORMAT(55X,'По городу'/26X,'Без суммации',52X, *'C учетом суммации'/) 26 FORMAT(' ','*',I5,1X,'*',30X,F6.3,50X,F6.3) 27 FORMAT(35X,'Mаксимальные нормировочные концентрации'/) 28 FORMAT(10X,'По городу без учета суммации',1X,I4,1X,'C мах=',F6.3 */) 29 FORMAT(10X,'Hормировочные параметры на',1X,I4,1X,'год'/) 30 FORMAT(' ',a4,20F6.2/) 3030 FORMAT(' ',20F6.2/) 31 FORMAT(' ',2X,'По городу CBG,CB1G,AG, BG, DG') 52 FORMAT(' ',20F6.3) 101 FORMAT(25X,'CBi мес CB мес') 102 FORMAT(26X,'CI мах C мах') 103 FORMAT(25X,'CBP мес CB1 мес') WRITE(6,20) 104 FORMAT(26X,'CP мах') 178 FORMAT(' ',40X,'Годовой архив за год ',I4/) 15 CONTINUE RETURN END *********************************************************************** * Программа печати месячных данных 2:09:91 *********************************************************************** SUBROUTINE PEMEC(I,P,m1,m2,m3,m4) REAL M1(20),M2(20),M3(20),M4(19) COMMON/ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 INTEGER MECP,GOD,GODP COMMON GOD, MECP, godp, gorod, bt(20) INTEGER P ********* конец данных ********** WRITE(6,177) WRITE(6,105)MECP,GODP DO 40 J=1,90 IF(AIM(1,J).EQ.99.99) GO TO 44 40 WRITE(6,41)(AIM(K,J),K=1,I),AIM(19,J),AIM(20,J) 44 CONTINUE WRITE(6,43)(M1(K),K=1,I),M1(20) WRITE(6,43)(M3(K),K=1,I),M3(20) WRITE(6,177) WRITE(6,106)MECP,GODP DO 42 J=1,90 IF(APM(1,J).EQ.99.99) GO TO 45 42 WRITE(6,41)(APM(M,J),M=1,P),APM(19,J),APM(20,J) 45 CONTINUE WRITE(6,43)(M2(M),M=1,P),M2(20) WRITE(6,43)(M4(M),M=1,P) WRITE(6,177) 41 FORMAT(' ',20(F5.2,1X)) 43 FORMAT(' ',20F6.3) 105 FORMAT(15X,'Mесячный архив Si , S за ',i2,' месяц',I6,' года') 106 FORMAT(15X,'Mесячный архив Sp , S1 за 'i2,' месяц',I6,' года') 177 FORMAT(' ',65('*')/) RETURN END *********************************************************************** * Программа печати годовых данных 2:09:91 *********************************************************************** SUBROUTINE PEGOD(I,P,CB,CB1,god1,god2,cbpg,cimg,cpmg,cbig) COMMON/ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 COMMON/UR/CBI(20),CBP(20),INGR(80),POST1,POST2 COMMON/URN/AI(20),AP(20),A DIMENSION CBIG(20),CBPG(20),CIMG(20),CPMG(19) character*17 POST1(20),POST2(20) character*6 INGR INTEGERP,GOD1,GOD2,GODP INTEGER GOD COMMON GOD, MECP, godp, gorod, bt(20) ******************** конец данных ************ WRITE(6,20) WRITE(6,178)GODP WRITE(6,20) WRITE(6,101) DO 50 J=1,12 50 WRITE(6,52)(CBIM(K,J),K=1,I),CBIM(19,J),CBIM(20,J) WRITE(6,20) WRITE(6,102) DO 51 J=1,12 51 WRITE(6,52)(CIM(K,J),K=1,I),CIM(19,J),CIM(20,J) WRITE(6,20) WRITE(6,103) DO 53 J=1,12 53 WRITE(6,52)(CBPM(M,J),M=1,P),CBPM(19,J),CBPM(20,J) WRITE(6,20) WRITE(6,104) DO 54 J=1,12 54 WRITE(6,52)(CPM(M,J),M=1,P),CPM(19,J) WRITE(6,20) WRITE(6,21) WRITE(6,20) WRITE(6,22) WRITE(6,23)GOD1,(CBI(K),K=1,I) WRITE(6,23)GOD2,(CBIG(K),K=1,I) WRITE(6,2020) WRITE(6,24) WRITE(6,23)GOD1,(CBP(M),M=1,P) WRITE(6,23)GOD2,(CBPG(M),M=1,P) WRITE(6,2020) WRITE(6,25) WRITE(6,26)GOD1,CB,CB1 WRITE(6,26)GOD2,CBIG(20),CBPG(20) WRITE(6,20) WRITE(6,27) WRITE(6,20) WRITE(6,2222) WRITE(6,23)GOD2,(CIMG(K),K=1,I) WRITE(6,2020) WRITE(6,2424) WRITE(6,23)GOD2,(CPMG(M),M=1,P) WRITE(6,28)GOD2,CIMG(20) WRITE(6,2020) WRITE(6,20) 20 FORMAT(' ',65('*')/) 2020 FORMAT(' ') 21 FORMAT(10X,'Cреднегодовые нормированные концентрации'/) 22 FORMAT(10X,'По инградиентам CBI(k), CBIG(k)') 2222 FORMAT(10X,'По инградиентам CIMG(k)') 23 FORMAT(' ','*',1X,I4,1X,'*',19F6.3/) 2424 FORMAT(' ',10X,'По пунктам CPMG(m)') 24 FORMAT(' ',10X,'По пунктам CBP(m), CBPG(m)') 25 FORMAT(25X,'По городу'/10X,'Без суммации CB, CBIG(20)',6X, *'C учетом суммации CB1, CBPG(20)') 26 FORMAT(' ','*',I5,1X,'*',10X,F6.3,17X,F6.3) 27 FORMAT(10X,'Mаксимальные нормированные концентрации'/) 28 FORMAT(10X,'По городу без учета суммации',1X,I4,1X,'C мах=',F6.3) 52 FORMAT(' ',20F6.3) 101 FORMAT(25X,'CBi мес, CB мес') 102 FORMAT(26X,'Ci мax, C мax') 103 FORMAT(25X,'CBp мес, CB1 мес') WRITE(6,20) 104 FORMAT(26X,'Cp мах') 178 FORMAT(' ',20X,'Годовой архив за ',I4,' год'/) RETURN END ***************************************************************** * Программа печати данных за 1 срок * ***************************************************************** subroutine PECPOK(s1,i,k,m,p,s,mec,sc,data,scp,sccp,cpok, & c2,c5,c6,c9,cpi,ph,si,sicp,sp,spcp) DIMENSION CPI(20,20),SI(20),SP(20) COMMON /ARX/AIM(20,90),APM(20,90),CBIM(20,12),CBPM(20,12), *CIM(20,12),CPM(19,12),C12,R1 INTEGER MECP COMMON/UR/CBI(20),CBP(20),INGR(80),POST1,POST2 COMMON/URN/AI(20),AP(20),A INTEGER SICP(20),SPCP(20),SCP INTEGER P INTEGER PH(20),GOD,MEC, *DATA,CPOK character INGR*6,GOROD*12 ? COMMON GOD, MECP, godp, gorod, bt(20) INTEGER SCCP character*17 POST1(20),POST2(20) character*136 string character*6 srf1 character*7 ZVEZD(20),CHERT(20),PROB(20),PROBI(20) ******************** конец данных ************ DO 1 K=1,I ZVEZD(K)='*******' CHERT(K)='-------' PROB(K)= ' ' 1 PROBI(K)=' I' IF(C9.NE.1.) GO TO 41 ? WRITE(6,52)(ZVEZD(K),K=6,I) WRITE(6,5201)(PROB(K),K=7,I) WRITE(6,51)GOROD,DATA,MEC,GOD,CPOK,(PROB(K),K=7,I) WRITE(6,5201)(PROB(K),K=7,I) write(6,52)(ZVEZD(K),K=6,I) write(6,5253)(PROB(K),K=7,I) write(6,53)(PROB(K),K=8,I) write(6,5353)(CHERT(K),K=8,I) write(6,54)(INGR(K),K=1,I) ? write(6,5454)(INGR(K),K=I+1,I*2) ? write(6,56)(INGR(K),K=I*2+1,I*3) ? write(6,5656)(INGR(K),K=I*3+1,I*4) ? WRITE(6,52)(ZVEZD(K),K=6,I) DO 60 M=1,P WRITE(string,57)POST1(M),PH(M),(CPI(M,K),K=1,I),SP(M), * SPCP(M) DO 4 K=1,I IF(CPI(M,K).NE.9.99) GO TO 4 LN=26+(K-1)*7 LK=30+(K-1)*7 STRING(LN:LK)=' - ' 4 CONTINUE IF(SP(M).NE.9.99) GO TO 5 LN=26+I*7 LK=30+I*7 STRING(LN:LK)=' - ' 5 CONTINUE LN=26+(I+1)*7 LK=30+(I+1)*7 SELECT CASE(SPCP(M)) CASE(99) STRING(LN:LK)=' н.ср.' CASE(9) STRING(LN:LK)=' в.ср.' CASE(90) STRING(LN:LK)=' - ' END SELECT write(6,10000) string write(6,9954) POST2(M),(PROBI(K),K=1,I),PROBI(1) 60 CONTINUE WRITE(6,52)(ZVEZD(K),K=6,I) WRITE(string,58) (SI(K),K=1,I) DO 6 K=1,I IF(SI(K).NE.9.99) GO TO 6 LN=26+(K-1)*7 LK=30+(K-1)*7 STRING(LN:LK)=' - ' 6 CONTINUE WRITE(6,10000) string WRITE(6,52)(ZVEZD(K),K=6,I) WRITE(STRING,59) (SICP(K),K=1,I) do k = 1,i i prizn = 0 LN = 26+(K-1)*7 LK = 30+(K-1)*7 if(sicp(k) .eq.9) then srf1 = ' в.ср.' i prizn = 1 end if if(sicp(k) .eq.99) then srf1 = ' н.ср.' i prizn = 1 end if if(sicp(k) .eq.90) then srf1 = ' - ' i prizn = 1 end if if ( i prizn .eq. 1 ) then string(LN:LK)=SRF1 END IF end do write(6,10000) string WRITE(6,52)(ZVEZD(K),K=6,I) WRITE(6,61)S,(PROB(K),K=8,I) WRITE(6,6100)(PROB(K),K=8,I) WRITE(6,62)S1,(PROB(K),K=8,I) WRITE(6,6200)(PROB(K),K=8,I) write(srf1,6363) scp 6363 format(i6) if(scp .eq.9) srf1 = ' в.ср.' if(scp .eq.99) srf1 =' н.ср.' if(scp .eq.90) srf1 =' - ' WRITE(6,63)Srf1,(PROB(K),K=8,I) WRITE(6,6300)(PROB(K),K=8,I) WRITE(6,6301)(PROB(K),K=8,I) IF(C6.EQ.1.) WRITE(6,110)C5, (PROB(K),K=8,I) WRITE(6,52)(ZVEZD(K),K=6,I) IF(C2.GT.0.0) GO TO 41 write(srf1,6363) sccp if(sccp .eq.9) srf1 = ' в.ср.' if(sccp .eq.99) srf1 =' н.ср.' if(sccp .eq.90) srf1 =' - ' WRITE(6,31) WRITE(6,32)SC,Srf1 WRITE(6,52)(ZVEZD(K),K=6,I) 41 CONTINUE 5757 format(a16) 31 FORMAT(' ',' Cредние за прошедшие 3 срока'/) 51 FORMAT(t2,'*',22X,'Загрязнение гор.',A12,3X,I2,'.',I2,'.',I4, *' г.',1X,'на ',I2,' час.',2A7,' *') 14 52 FORMAT(' ',73('*'),3A7) 15 5201 FORMAT(t2,'*'73(' '),2A7,' *') 14 5253 format(' ','*',t20,'I',' НомI',41X,2A7,'I Пока-I Уро- *') 13 53 FORMAT(' ','*',t20,'I п I',1A7,' Нормированные на ПДК концентр' 14 *,'ации,Cpi=Qpi/ПДКi',t81,'IзательI вень *') 5353 format(' ', '* А д р е с',t20,'I o I',48('-'),1A7,'I загр.I', 13 * ' загр.*') 54 FORMAT(' ','*',t20,'I с I',8(A6,'I'),' на I на *') 20 ? 9954 FORMAT(' ','*',A17,'I I',9A7,' *') 20 5454 format(' ','*',t20,'I т I',8(A6,'I'),'пунктеIпункте*') 20 55 FORMAT(' ','*',6X,' Aдрес I / I',85X,'*') 56 FORMAT(' ','*',17X,'I o I',8(A6,'I'),' Sp I Spcp *') 20 5656 format(' ','*',t20,'I в I',8(A6,'I'),' I *') 20 57 FORMAT(' ','*',A17,'I',I3,1X,9('I',F5.2,1X),'I ', * I2,2X,'*') 58 FORMAT(' ','* ','Пок.загр.гор.ингр. Si',8('I',F5.2,1X), * 'I',13(' '),'*') 59 FORMAT(' ','* Ур.загр.гор.инград I',8(2X,I2, 20 *2X,'I'),13(' '),'*') 61 FORMAT(' ','* B целом по городу S=',F5.2,22x,1A7,'Обозначения:' *,24X,'*') 6100 FORMAT(t2,'*',47X,1A7,' S < 1 - загр. ниже среднего(н.ср.)*') 13 62 FORMAT(' ','* Показатель загрязнения с учетом суммации S1=',F5.2 * ,1A7,'S = 1 - равно среднему за год *') 13 6200 format(t2,'*',47X,1A7,'1 < S < A - загр. выше среднего(в.ср)', * ' *') 63 FORMAT(t2,'*',' Уровень загрязнения города= ',a6, *11X,1A7,'A < S < B - 1 уровень',17(' '),'*') 13 6300 format(t2,'*',47X,1A7,'B < S < D - 2 уровень',17(' '),'*') 13 6301 format(t2,'*',47X,1A7,' S > D - 3 уровень',17(' '),'*') 13 32 FORMAT(' ','Загрязнение города S=', F5.2,' Уровень загрязнения го *рода=',a6) 110 FORMAT(' ','* Bыделяющаяся концентрация в ',F6.1,' ПДК',44X, *1A7,'*') 13 10000 format(a136) return end ***************************************************************** * Программа расчета месячной статистики 1:12:91 ***************************************************************** subroutine MECSTAT(i, p, pdk,pH) integer god1, mec1, data1, cpok1, q1(20,20),p,mecp,godp, & sk(20,20),nn(20,20), pdk(20), ms(20,20),ms1(20,20), & ms2(20,20), qm(20,20),skp(20),nnp(200), msp(20),msp1(20), & msp2(20), qmp(20),qsr(20,20), qsrp(20), skg(20,20), & nng(20,20), msg(20,20), ms1g(20,20), ms2g(20,20), & qmg(20,20), skpg(20), nnpg(20), mspg(20), msp1g(20), & msp2g(20), qmpg(20),pH(20) logical log1 character gorod*12 ! название города character stat1*3,INGR*6,POST1(20)*17,POST2(20)*17 COMMON GOD, MECP, godp, gorod, bt(20) COMMON/UR/CBI(20),CBP(20),INGR(80),POST1,POST2 common /stat/ skg, nng, msg, ms1g, ms2g, qmg, skpg,nnpg, mspg, & msp1g, msp2g, qmpg dimension qpv(20,20), qpv1(20,20), qpv2(20,20), & qpvp(20) , qpvp1(20), qpvp2(20) * К о н е ц о п и с а н и я д а н н ы х * Установка величин в исходное состояние do 1 k = 1, i do 2 m = 1, p sk(m,k) = 999999 nn(m,k) = 0 ms(m,k) = 0 ms1(m,k) = 0 ms2(m,k) = 0 qm(m,k) = -5 qpv(m,k) = 99.99 qpv1(m,k) = 99.99 qpv2(m,k) = 99.99 qsr(m,k) = 9999 2 continue skp(k) = 999999 nnp(k) = 0 msp(k) = 0 msp1(k) = 0 msp2(k) = 0 qmp(k) = -5 qpvp(k) = 99.99 qpvp1(k) = 99.99 qpvp2(k) = 99.99 qsrp(k) = 9999 1 continue * Считывание месячных данных write(*,*) 'Программа расчета месячной статистики ' C open(15, file='mecdan') 7 read(15,120,end = 4,err=22) god1, mec1, data1, cpok1 do 3 k = 1, i read(15,104,end = 4,err=24) (q1(m,k), m = 1, p) 3 continue write(*,*) 'Считывание месячных данных ' 104 FORMAT(20I4) 120 FORMAT(I4,I2,I2,I2) * Расчет сумм и максимальных концентраций и числа случаев по i,p do 5 K = 1, I do 6 M = 1, P if(q1(m,k) .eq. 9999) go to 6 if(sk(m,k) .eq. 999999) sk(m,k) = 0 if(q1(m,k) .gt. qm(m,k)) qm(m,k) = q1(m,k) sk(m,k) = sk(m,k) + q1(m,k) nn(m,k) = nn(m,k) + 1 if(q1(m,k) .le. pdk(k)) go to 6 ms(m,k) = ms(m,k) + 1 if(q1(m,k) .le. 5*pdk(k)) go to 6 ms1(m,k) = ms1(m,k) + 1 if(q1(m,k) .le. 10*pdk(k)) go to 6 ms2(m,k) = ms2(m,k) + 1 6 continue 5 continue go to 7 4 WRITE(*,20)DATA1 20 FORMAT(' В сроке с датой ',I12, ' обнаружен'/ & ' КОНЕЦ в файле MECDAN при считывании в MECSTAT.'/) go to 21 22 WRITE(6,23)DATA1 23 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА ДАТЫ в файле MECDAN при считывании в MECSTAT.'/ ) go to 21 24 WRITE(6,25)DATA1 25 FORMAT(' В сроке с датой ',I12, ' обнаружена'/ & ' ОШИБКА КОНЦЕНТРАЦИИ в файле MECDAN при считывании в MECSTAT.'/) 21 REWIND 15 * Расчет сумм и максимальных концентраций и числа * случаев по всем постам do 8 k = 1, i do 9 m = 1, p if(sk(m,k) .eq. 999999) go to 9 if(skp(k) .eq. 999999) skp(k) = 0 skp(k) = skp(k) + sk(m,k) nnp(k) = nnp(k) + nn(m,k) msp(k) = msp(k) + ms(m,k) msp1(k) = msp1(k) + ms1(m,k) msp2(k) = msp2(k) + ms2(m,k) if(qm(m,k) .gt. qmp(k)) qmp(k) = qm(m,k) 9 continue 8 continue * Расчет месячной статистики do 11 k = 1, i do 12 m = 1, p if (nn(m,k) .eq. 0) go to 12 qpv(m,k) = ms(m,k) * 100. / nn(m,k) qpv1(m,k) = ms1(m,k) * 100. / nn(m,k) qpv2(m,k) = ms2(m,k) * 100. / nn(m,k) qsr(m,k) = sk(m,k)*1.0 / nn(m,k) +.5 12 continue if(nnp(k) .eq. 0) go to 11 qpvp(k) = msp(k) * 100. / nnp(k) qpvp1(k) = msp1(k) * 100. / nnp(k) qpvp2(k) = msp2(k) * 100. / nnp(k) qsrp(k) = skp(k)*1.0 / nnp(k) +.5 11 continue * Расчет годовых сумм и максимальных концентраций и чисел случаев inquire(file ='OCESTAT',exist =log1) if(log1) then stat1 = 'old' else stat1 = 'new' end if open(17, file='OCESTAT',status=stat1,form='unformatted') read(17, end=15, err =16)((skg(M,K),nng(M,K),msg(M,K), *ms1g(M,K),ms2g(M,K),qmg(M,K),M=1,P),skpg(K),nnpg(K), *mspg(K),msp1g(K),msp2g(K),qmpg(K),K=1,I) go to 19 16 WRITE(6,17)MECP DO J1=1,3 WRITE (*,*) CHAR(7) END DO 17 FORMAT(' После срока с месяцем ',I3, ' обнаружена'/ & ' ОШИБКА в файле OCESTAT.'/ ) go to 19 15 WRITE(6,18)MECP DO J1=1,3 WRITE (*,*) CHAR(7) END DO 18 FORMAT(' После срока с месяцем ',I3, ' обнаружен'/ & ' КОНЕЦ в файле OCESTAT.'/ ) 19 do 13 k = 1, i do 14 m = 1, p if(sk(m,k) .eq. 999999) go to 14 if(skg(m,k) .eq. 999999) skg(m,k) = 0 skg(m,k) = skg(m,k) + sk(m,k) nng(m,k) = nng(m,k) + nn(m,k) msg(m,k) = msg(m,k) + ms(m,k) ms1g(m,k) = ms1g(m,k) + ms1(m,k) ms2g(m,k) = ms2g(m,k) + ms2(m,k) if(qm(m,k) .gt. qmg(m,k)) qmg(m,k) = qm(m,k) 14 continue if(skp(k) .eq. 999999) go to 13 if(skpg(k) .eq. 999999) skpg(k) = 0 skpg(k) = skpg(k) + skp(k) nnpg(k) = nnpg(k) + nnp(k) mspg(k) = mspg(k) + msp(k) msp1g(k) = msp1g(k) + msp1(k) msp2g(k) = msp2g(k) + msp2(k) if(qmp(k) .gt. qmpg(k)) qmpg(k) = qmp(k) 13 continue REWIND 17 write(17)((skg(M,K),nng(M,K),msg(M,K), *ms1g(M,K),ms2g(M,K),qmg(M,K),M=1,P),skpg(K),nnpg(K), *mspg(K),msp1g(K),msp2g(K),qmpg(K),K=1,I) REWIND 17 * Печать месячной статистики write(6,100) mecp, godp, gorod write(6,200) 100 format(20x,'Характеристика загрязнения атмосферы'/, & 26x,'за ',i2, ' месяц ', i4, ' года'/ 20x, 'Города ', a12 & , 2x, 'Шифр ________'/) 200 format(65('*') / & ' SK NN MS MS1 MS2 QSR QM QPV QPV1' & ' QPV2'/ 65('*')/) 300 format(1x, 'Примесь K =',i2,2X,4A6,1x, 'Точность b =' & f8.5/ 1x, 60('-') ) 400 format(1x, 'Пост M =',i3,', номер = ',I2 ) 500 format(1x, 3i6, 4i5, 3f8.3) 600 format(1x, 'По всем постам ') 700 format(65('*') ) do k = 1, i K1=K+I K2=K1+I K3=K2+I write(6,300) k,INGR(K),INGR(K1),INGR(K2),INGR(K3),bt(k) do m = 1, p write(6,400) m,PH(M) write(6,500) sk(m,k), nn(m,k), ms(m,k), ms1(m,k), ms2(m,k), & qsr(m,k), qm(m,k), qpv(m,k), qpv1(m,k), qpv2(m,k) end do ! m write(6,600) write(6,500) skp(k), nnp(k), msp(k), msp1(k), msp2(k), & qsrp(k), qmp(k), qpvp(k), qpvp1(k), qpvp2(k) write(6,700) end do ! k return end ***************************************************************** * Программа вычисления годовой статистики 3:12:91 ***************************************************************** subroutine godstat(i, p, pH) integer skg, nng, msg, ms1g, ms2g, qmg,p,mecp,godp,ph(20), & skpg, nnpg, mspg, msp1g, msp2g, qmpg, qsrg(20,20), qsrpg(20) dimension qpvg(20,20), qpv1g(20,20), qpv2g(20,20) common /stat/ skg(20,20), nng(20,20), msg(20,20), ms1g(20,20), & ms2g(20,20), qmg(20,20), skpg(20), nnpg(20), mspg(20), & msp1g(20), msp2g(20), qmpg(20) character gorod*12 ! название города character INGR*6,POST1(20)*17,POST2(20)*17 dimension qpvpg(20), qpvp1g(20), qpvp2g(20) COMMON GOD, MECP, godp, gorod, bt(20) COMMON/UR/CBI(20),CBP(20),INGR(80),POST1,POST2 * К о н е ц о п и с а н и я д а н н ы х * Расчет годовой статистики do 1 k = 1, i do 2 m = 1, p if(nng(m,k) .eq. 0) go to 2 qpvg(m,k) = msg(m,k) * 100. / nng(m,k) qpv1g(m,k) = ms1g(m,k) * 100. / nng(m,k) qpv2g(m,k) = ms2g(m,k) * 100. / nng(m,k) qsrg(m,k) = skg(m,k)*1.0 / nng(m,k) +.5 2 continue if(nnpg(k) .eq. 0) go to 1 qpvpg(k) = mspg(k) * 100. / nnpg(k) qpvp1g(k) = msp1g(k) * 100. / nnpg(k) qpvp2g(k) = msp2g(k) * 100. / nnpg(k) qsrpg(k) = skpg(k)*1.0 / nnpg(k) +.5 1 continue * Печать годовой статистики write(6,100) godp, gorod write(6,200) 100 format(20x,'Характеристика загрязнения атмосферы'/, & 32x,'за ', i4, ' год'/ 20x, 'Города ', a & , 2x, 'Шифр ________'/) 200 format(65('*') / &' SKG NNG MSG MS1G MS2G QSRG QMG QPVG QPV1G ' & ' QPV2G'/ 65('*')/) 300 format(1x, 'Примесь K =',i2,2X,4A6,1x, 'Точность b =' & f8.5/ 1x, 60('-') ) 400 format(1x, 'Пост M =',i3,', номер = ',I2) 500 format(1x, 3i6, 4i5, 3f8.3) 600 format(1x, 'По всем постам ') 700 format(65('*') ) do k = 1, i K1=K+I K2=K1+I K3=K2+I write(6,300) k,INGR(K),INGR(K1),INGR(K2),INGR(K3),bt(k) do m = 1, p write(6,400) m,PH(M) write(6,500) skG(m,k), nnG(m,k), msG(m,k),ms1G(m,k),ms2G(m,k), & qsrG(m,k), qmG(m,k), qpvG(m,k), qpv1G(m,k), qpv2G(m,k) end do ! m write(6,600) write(6,500) skpG(k), nnpG(k), mspG(k), msp1G(k), msp2G(k), & qsrpG(k), qmpG(k), qpvpG(k), qpvp1G(k), qpvp2G(k) write(6,700) end do ! k ********************************************************* * Установка величин в исходное состояние do 3 k = 1, i do 4 m = 1, p skg(m,k) = 999999 nng(m,k) = 0 msg(m,k) = 0 ms1g(m,k) = 0 ms2g(m,k) = 0 qmg(m,k) = -5 4 continue skpg(k) = 999999 nnpg(k) = 0 mspg(k) = 0 msp1g(k) = 0 msp2g(k) = 0 qmpg(k) = -5 3 continue write(17)((skg(M,K),nng(M,K),msg(M,K), *ms1g(M,K),ms2g(M,K),qmg(M,K),M=1,P),skpg(K),nnpg(K), *mspg(K),msp1g(K),msp2g(K),qmpg(K),K=1,I) REWIND 17 return end