C ======================================================= subroutine subipg_dx1c(st) C...........................................................Dec 2023 C C May. 2019 ! C------------------------------------------------------------- C c++ March 2011 C NEW IPG Format for preceding day + current day from HTML file!!! C cc SUBROUTINE SUBIPG(ady,datf) c 10 REM "CONV-IPG" EXTRACT FOF2 FROM IPG DAILY FILE C CHARACTER*128 infil,outfile,ctext,text(366),xtext CHARACTER*4 YEAR,YEAR_pre,AYEAR CHARACTER*120 TITLE CHARACTER*150 WORD,WORD1 CHARACTER*2 YR,AMN,ST,DY1,DY2,DDD,ADY(0:31),DC1,DC2 +,STIPG(6),CYR,CMN,CDY,BYR,BMN,BDY c-- +,XDY +,AMN0,ADY0,AYR0,AMN1,ADY1,AYR1 !NEW*6 +,AMN_pre,ADY_pre,DD2 !+++ADD CHARACTER*3 XXX CHARACTER*5 DATF(0:31,0:23),CODIPG(6),DDRES,TEXF !NEW+7 CHARACTER*10 DD !Ljuba CHARACTER*16 indate !FEB2015 Tamara !!!!!!!!!!!!!!! INTEGER IM(12) c--- INTEGER*2 IDY2,JD,IDD c--- +,IM(12),IYR,IMN0,IDY0,IMN,IYR0 !NEW+6 C DATA STIPG/'kg','ma','mg','sd','tz','rv'/ !NEW+7 DATA STIPG/'kg','ma','rv','sd','mg','tz'/ !DEC 2021 DATA CODIPG/'32508','34504','34506','37701','45601','39601'/ !DEC 2021 DATA ADY/32*'00'/ DATA IM/31,28,31,30,31,30,31,31,30,31,30,31/ !NEW+6 C CALL DATE_AND_TIME(DD) !Ljuba C- YEAR=DD(1:4) C- AMN=DD(5:6) C- DC1=DD(7:8) 799 format(A4,2(1X,A2),1X,A4,2(1X,A2)) !FEB2015 NEW COMMAND NUMBER = 799 798 format(' YEAR, AMN, DD2 = ',A4,2(1X,A2),1X,A4,2(1X,A2)) indate='c:/web/graf/date' !!! Tamara !!!!!!! !FEB2015 C# indate='/var/www/izmiran/ionosphere/weather/graf/date' !!! LIUBA !!FEB2015 open(10,file=indate) !FEB2015 read(10,799) AYEAR,AMN,DD2,YEAR_pre,AMN_pre,ADY_pre !FEB2015 NEW FORMAT NUMBER = 799 WRITE(*,798) AYEAR, AMN, DD2,YEAR_pre,AMN_pre,ADY_pre !FEB2015 NEW FORMAT NUMBER = 798 close(unit=10) C WRITE(*,*) 'PC Date: Year,Month,Day = ',DD,'Time = ',TTT !FEB2015 C YEAR=DD(1:4) !FEB2015 C DO ii=1,5 if (st.eq.STIPG(ii)) then C st=stipg(ist) ist=ii TEXF=codipg(ist) exit endif ENDDO C YR=AYEAR(3:4) YEAR=AYEAR BYR=YEAR(3:4) c-- BMN=DD(5:6) BMN=AMN c-- BDY=DD(7:8) BDY=DD2 C c-- YEAR='2000' c-- YEAR(3:4)=YR c-- DC1=XDY DC1=DD2 DC2=DC1 C read(AMN,*) rmn !NEW+6 imn=int(rmn) !NEW+6 read(YR,*) ryr !NEW+6 iyr=int(ryr) !NEW+6 z1=iyr/4.0 !NEW+6 jz=int(z1)*4 !NEW+6 IF(jz.EQ.iyr) THEN !NEW+6 IM(2)=29 !NEW+6 idnr=366 !NEW+6 ELSE !NEW+6 IM(2)=28 !NEW+6 idnr=365 !NEW+6 ENDIF !NEW+6 C ========================================== C C cycle on stations C Cpre DO 155 ist=1,6 !NEW+7 C DO 155 ist=1,5 !NEW+7 DY1=DC1 DY2=DC2 C st=stipg(ist) C TEXF=codipg(ist) read(dy1,*) rdy1 c read(dy2,*) rdy2 iyr0=iyr !NEW*6 imn0=imn !NEW*6 idd=int(rdy1)-1 ! 1st 24-data for prec. day if (idd.eq.0) then !NEW*6 imn0=imn-1 !NEW*6 if (imn0.eq.0) then !NEW*6 iyr0=iyr-1 !NEW*6 imn0=12 !NEW*6 idy0=31 !NEW*6 endif !NEW*6 idd=im(imn0) !NEW*6 endif !NEW*6 call blet2(idd,ADY1) !NEW*6 call blet2(imn0,AMN1) !NEW*6 call blet2(iyr0,AYR1) !NEW*6 idy0=idd-1 !NEW+6 c- iyr0=iyr !NEW*6 c- imn0=imn !NEW*6 if (idy0.eq.0) then !NEW+6 imn0=imn-1 !NEW+6 if (imn0.eq.0) then !NEW+6 iyr0=iyr-1 !NEW+6 imn0=12 !NEW+6 idy0=31 !NEW+6 endif !NEW+6 idy0=im(imn0) !NEW+6 endif !NEW+6 call blet2(idd,DDD) !NEW+6 call blet2(idy0,ADY0) !NEW+6 call blet2(imn0,AMN0) !NEW+6 call blet2(iyr0,AYR0) !NEW+6 C idy2=idd ! temp 55 format(A2) C DO n=0,31 DO i=0,23 datf(n,i)=' 00 ' ENDDO enddo C infil='c:\web\graf\ipg\yrmndyipg.htm' !Tamara infil(17:18)=YR !Tamara infil(19:20)=bmn !Tamara infil(21:22)=dc1 ! !Tamara infil(23:29)='ipg.htm' !Tamara C/ infil='/var/www/izmiran/ionosphere/weather/graf/ipg/yrmndyipg.htm' !Ljuba C/ infil(46:47)=YR !Ljuba C/ infil(48:49)=amn !Ljuba C/ infil(50:51)=dc1 ! !Ljuba C/ infil(52:58)='ipg.htm' !Ljuba C+ outfile='c:\web\graf\2010\stYRf.br' !Tamara outfile(13:16)=AYEAR !Tamara outfile(20:21)=YR !Tamara outfile(18:19)=ST !Tamara C/ outfile='/var/www/izmiran/ionosphere/weather/graf/2010/stYRf.br' !Ljuba C/ outfile(42:45)=YEAR !Ljuba C/ outfile(49:50)=YR !Ljuba C/ outfile(47:48)=ST !Ljuba C write(*,*) outfile c 89 format(A128) C OPEN(12,file=OUTFILE) !! I REMOVED ACCESS='APPEND'. Ljuba do 80 i=1,356 c nn=i-1 !NEW+6 nn=i !NEW+6 read(12,89,err=3,end=84) ctext text(i)=ctext cyr=ctext(1:2) cmn=ctext(3:4) cdy=ctext(5:6) c if ((CYR.eq.YR).and.(CMN.eq.AMN).and.(CDY.eq.DDD)) then !NEW+6 if ((CYR.eq.AYR0).and.(CMN.eq.AMN0).and.(CDY.eq.ADY0)) then !NEW+6 exit endif 80 continue 84 close(unit=12) C Re-write outfile for prec. period: OPEN(12,file=OUTFILE) do i=1,nn-1 write(12,89) text(i) enddo C remember prec. day of outfile add +21ut,22ut,23ut data: ctext=text(nn) ! close(unit=12) C OPEN(12,FILE=OUTFILE,ACCESS='APPEND') ! C ========================================================== istart=0 1 CONTINUE jd=idd jj=jd-idd+1 C restore prec. day for 00:21 UT: do k=1,21 k1=9+5*(k-1) k2=k1+4 ddres=ctext(k1:k2) datf(jj-1,k-1)=ddres ! NEW+ enddo C call blet2(jd,DDD) c ADY(jj)=ddd !NEW+6 ADY(jj)=ADY0 !NEW+6 ifl=0 c-- INFIL(19:20)=BMN OPEN(11,FILE=INFIL) 10 read (11,160,err=3,end=2) title 160 format(A120) istart=index(title,texf) if (istart.gt.0) then read (11,160,err=3,end=2) title ! read extra line C? read (11,160,err=3,end=2) title ! read extra line ++++ goto 11 else goto 10 endif 11 continue 161 format(A150) read (11,161,err=3,end=2) word word1(1:149)=word(2:150) word=word1 DDRES=' 0 ' DO k=1,48 ! cycle on reading foF2 for two days call shift(word,XXX) DDRES(1:3)=XXX if (k.lt.4) then datf(jj-1,k+20)=ddres endif if (k.lt.28) then datf(jj,k-4)=ddres else datf(jj+1,k-28)=ddres !NEW+ endif ENDDO GOTO 440 do k=1,24 ! start readind data foF2 read (11,*,err=440,end=2) mut,lt,med,kf2 13 write(*,*) mut,lt,med,kf2 !ΡΡ DDRES=' 0 ' if (kf2.lt.10) goto 54 XXX=' 0' CALL BLET3(kf2,XXX) DDRES(1:3)=XXX 54 if (k.lt.4) then datf(jj-1,k+20)=ddres else datf(jj,k-4)=DDRES endif enddo ! end of reading station data for 1st dat datf(jj,21)=' 0 ' datf(jj,22)=' 0 ' datf(jj,23)=' 0 ' C Add data for current day: do m=1,4 read (11,160,err=3,end=2) title ! read extra line enddo C+++ do k=1,24 ! start readind data foF2 read (11,89,err=3,end=2) xtext XXX=' 0' backspace(11) XXX=xtext(10:12) if (xxx.eq.' ') exit read (11,*,err=440,end=2) mut,lt,med,kf2 write(*,*) mut,lt,med,kf2 DDRES=' 0 ' XXX=' 0' if (kf2.lt.10) goto 154 XXX=' 0' CALL BLET3(kf2,XXX) DDRES(1:3)=XXX 154 if (k.lt.4) then datf(jj,k+20)=ddres else datf(jj+1,k-4)=DDRES endif enddo ! end of reading station data for current day 440 CLOSE (unit=11) 77 CONTINUE ! End of reading cycle datf(jj+1,21)=' 0 ' datf(jj+1,22)=' 0 ' datf(jj+1,23)=' 0 ' jd=idd-1 call blet2(idd,DDD) !NEW+6 ady(1)=DDD !NEW+6 jd=idd+1 !NEW+6 call blet2(jd,DDD) ady(2)=DDD write(*,181) ST 181 format(2X,A2) c// DO J=0,JJ+1 !NEW*6 c// if (j.eq.0) then !NEW+6 write(*,180) AYR0,AMN0,ADY0,(datf(0,k),k=0,23) !NEW+6 write(12,180) AYR0,AMN0,ADY0,(datf(0,k),k=0,23) !NEW+6 c// endif !NEW*6 c// if (j.eq.1) then !NEW*6 write(*,180) AYR1,AMN1,ADY1,(datf(1,k),k=0,23) !NEW*6 write(12,180) AYR1,AMN1,ADY1,(datf(1,k),k=0,23) !NEW*6 c// endif !NEW*6 C-- if ((YR.eq.BYR).and.(AMN.eq.BMN).and.(DY1.eq.BDY)) GOTO 150 write(*,180) yr,bmn,dy1,(datf(2,k),k=0,23) !NEW*6 write(12,180) yr,bmn,dy1,(datf(2,k),k=0,23) !NEW*6 180 format(3A2,2X,24(A5)) c// ENDDO 150 close(unit=12) C close(unit=11) C 155 CONTINUE ! End cycle on stations goto 2 3 write(*,*) 'INPUT FILE IS NOT IN YOUR DIRECTORY ' 2 continue C- pause ' ' RETURN C stop END C C ------------------------------------------------------ C subroutine shift(txt,res) C C to shift word 1-3 positions left C ival = value of foF2 C character*150 txt,txt1 character*1 y1,y2,y3,y4 character*3 res res=' 00' iflag=0 goto 2 C 1 do i=1,150 i1=i+1 y1=txt(i1:i1) txt1(i:i)=y1 enddo txt=txt1 2 y1=txt(1:1) y2=txt(2:2) y3=txt(3:3) y4=txt(4:4) i1=index(txt,',') if (i1.eq.1) goto 7 if (i1.eq.2) goto 6 if (i1.eq.3) goto 4 if (i1.eq.4) goto 5 c if ((i1.eq.1).and.(iflag.eq.0)) then c goto 1 c else c goto 3 c endif iflag=iflag+1 C if ((y1.eq.',').and.(y2.eq.',')) goto 3 if ((y1.eq.',').and.(iflag.eq.1)) goto 1 if ((y2.eq.',').and.(iflag.eq.1)) goto 3 c- if ((y1.ne.',').and.(y2.ne.',').and.(y3.eq.',')) then 4 res(1:1)=' ' res(2:2)=y1 res(3:3)=y2 txt1(1:147)=txt(4:150) txt=txt1 goto 3 c- endif c- if ((y1.ne.',').and.(y2.ne.',').and.(y3.ne.',').and.(y4.eq.',')) c- + then 5 res(1:1)=y1 res(2:2)=y2 res(3:3)=y3 txt1(1:146)=txt(5:150) txt=txt1 goto 3 c- endif 6 txt1(1:148)=txt(3:150) txt=txt1 goto 3 7 txt1(1:149)=txt(2:150) txt=txt1 goto 3 3 RETURN END C subroutine blet3(ilet,alet3) c nn=1,2,3,4 CHARACTER*1 IN(0:9) INTEGER ilet DATA IN/'0','1','2','3','4','5','6','7','8','9'/ CHARACTER*3 alet3 C alet3='000' ! j100=ilet/100 j10=(ilet-j100*100)/10 j1=ilet-j100*100-j10*10 5 do i=0,9 if (j100.eq.i) then alet3(1:1)=IN(i) endif enddo do i=0,9 if (j10.eq.i) then alet3(2:2)=IN(i) endif enddo 7 do i=0,9 if (j1.eq.i) then alet3(3:3)=IN(i) endif enddo C if (alet3(1:1).eq.'0') alet3(1:1)=' ' return end C=================================================================