Это подпрограмма для чтения 1-с данных  сети станций 210 ММ. Блок для считывания написан стаого формата (до 97 года, кажется) написан Ю.П. Курчашовым (rd_j_old, там 8 каналов). Для более новых данных запись трехканальная (rd_j_new)

Старый формат

! File Read24Np 11 / Oct - 95

subroutine     Rd_j_old(fil_nam,key_oper)

!************************************************************************

! IMPLICIT None
!----------------------------------------------------------------------*
CHARACTER*12 Fil_Nam
CHARACTER*8 Sav_Index, fil_b
character*12     fil_ch
INTEGER*4 L
INTEGER*2 Buffer (8),N,id0_mon(12), id00_mon(12)
CHARACTER*1 C, lt_ch(8), p_t,key_oper(5)
LOGICAL Not_a_Number
character*3 obs_nam, extn_0     
!----------------------------------------------------------------------*
INTEGER*2 I
INTEGER*1 B2 (2) ,B
EQUIVALENCE (B2 ,I)

!************************************************************************

WRITE (* ,'(//'' Old 210 MM format (8 channels) data reading'')')

data lt_ch /'h','d','z','t','n','e','v','8'/
data id00_mon /0,31,59,90,120,151,181,212,243,273,304,334/
extn_0='d00'
read(fil_nam,'(a2,3i2,a1,a3)') fil_b,i_yr,i_mon,i_day,p_t,obs_nam
p_t='.'
do i_m=1,2
id0_mon(i_m)=id00_mon(i_m)
end do
if (i_yr.eq.4*(i_yr/4)) then
do i_m=3,12
id0_mon(i_m)=id00_mon(i_m)+1
end do
else
do i_m=3,12
id0_mon(i_m)=id00_mon(i_m)
end do
end if
i_dy=id0_mon(i_mon)+i_day
write(*,*) i_mon, id0_mon(i_mon), i_dy
! pause
! CALL GetArg (1 ,File_Name ,OK)

! IF (OK .LE. 0)    GOTO 100

! CALL GetArg (2 ,Sav_Index ,OK)

! IF (OK .LE. 0)    GOTO 100
Sav_Index='yyyyyyyy'

OPEN (10,File= Fil_Nam,Status= 'Old',Access='Sequential',Form= 'Binary')
DO N =1 ,8
if (key_oper(5).ne.'l'.and.key_oper(5).ne.'L') then
write(fil_ch, '(a3,2a1,a3)') obs_nam, lt_ch(n), p_t, extn_0
write(*,'(a9)') fil_ch
else
write(fil_ch, '(a2,i2.2,i3.3,2a1,a3)') obs_nam, i_yr,i_dy,lt_ch(n), p_t, extn_0
write(*,'(a14)') fil_ch
end if
! pause

    C = Sav_Index (N : N)

    IF ((C .EQ. 'Y').OR.(C .EQ. 'y'))  then
       OPEN(10 + N,File= Fil_ch,Status = 'Unknown',Access='Sequential',Form= 'Formatted')
   end if
END DO

DO N =1 ,16
    READ (Unit = #10) Buffer
END DO

L = 0

!WRITE (* ,Fmt = '(/10X ,''-th string'' ,A1\)')
    ! '             Char (#0D)

    1 READ (Unit= #10 ,Err= 10) Buffer

L = L + 1
Not_a_Number = .True.

!WRITE (* ,Fmt = '(1X ,I6 ,A1\)')
     !'        L ,Char (#0D)

DO N =1 ,8

    I    = Buffer (N)
    B    = B2 (1)
    B2 (1)    = B2 (2)
    B2 (2)    = B
    Buffer (N) = I

    Not_a_Number=Not_a_Number.AND.(I.EQ.Int2(#8000))

END DO

IF (Not_a_Number)   THEN
    WRITE (*,Fmt = '(/'' End of file (Y/N) ? ''\)')
c='y'

!    READ (* ,'(A)')     C

    IF ((C .EQ. 'Y')  .OR. (C .EQ. 'y'))    GOTO 10

    WRITE (*,Fmt = '(/10X ,''-th string '' ,A1\)') Char (#0D)
END IF

DO N =1 ,8

    C = Sav_Index (N : N)

    IF ((C .EQ. 'Y').OR. (C .EQ. 'y')) then
      WRITE (10 + N,Fmt = '(I6)') Buffer (N)
    end if
END DO
            GOTO 1

   10 DO N =1 ,8

    CLOSE (10 + N)
END DO
!            STOP 'OK'

  100   Continue
!            STOP
!     ' 'Correct call is: Read24Np  YYYYNNNN (Y=to write a file)'

!************************************************************************
return

END ! Read24Np

© Курчашов Ю.П., 1995, испр. Ягова Н. В, 2002

Месячные данные сети IMAGE

! Reads Image month files and write files with the first time column
! for a given station list
integer ix(4000), k_x(2), i_cmp_out(15)
real*8 t_abs
real*8 b(150000,17), a_val(4), s_x(4), b_av(2), d_rad(30), b_av_n(2)
character*1440 str_tot(4000)
character*85 strr
character* 60 pth_in, pth_out
character*12 fil_out, fil_lst, fil_in
character*23 str, frmt_out
character*16 fil_par, frmt_b
character*10 str_cmp(3)
character*5 fil_b
character*3 stn(30),stn_old(30), obs_old(30), obs_new(30), obs, extn_lst, extn_out
character*2 fil_out_b, fil_out_c
character p_tm, s_a, s_0, s_t_n(3)
logical key_read
p_t='.'
str_cmp(1)='X-Y'
str_cmp(2)='H-D'
str_cmp(3)='H-E'
fil_par='rd_image_mon.par'
open(44, file=fil_par, status='old', iostat=i_o_s)
if (i_o_s .eq. 0) then
read(44,'(a60)' ,err=111) pth_in
pth_in=adjustr(pth_in)
read(44,'(a5)' ,err=111) fil_b
read(44,'(a60)' ,err=111) pth_out
pth_out=adjustr(pth_out)
read(44,'(a2)' ,err=111) fil_out_b
read(44,'(a2)' ,err=111) fil_out_c
read(44,'(a3)' ,err=111) extn_out
read(44, *, err=111) i_year_00
read(44, *, err=111) i_doy_00
read(44, *, err=111) i_year
read(44, *, err=111) i_mon
read(44, *, err=111) i_day_st
read(44, *, err=111) i_day_fn
read(44,*,err=111) i_dt
read(44,*,err=111) key_mag
read(44,*,err=111) a_val(1:4)
read(44, *, err=111) num_obs
do i_obs=1, num_obs
read(44,'(a3)' ,err=111) stn_old(i_obs)
end do
111 close(44)
else
!call read_scr(pth_in,fil_b,i_year,i_mon,i_day_st,i_day_fn,num_obs,stn)
goto 222
end if

i_yr=i_year-100*(i_year/100)
len_mon=i_day_fn-i_day_st+1
n_p_day=86400/i_dt
write(frmt_out, '(a8,i2,a8)') '(f16.9,', 2*num_obs, 'e16.8)'
write(fil_out, '(a2,2i2.2,a2,a1,a3)') fil_out_b,i_yr,i_mon,fil_out_c,p_t,extn_out
extn_lst='lst'
write(fil_lst, '(a2,2i2.2,a2,a1,a3)') fil_out_b,i_yr,i_mon,fil_out_c,p_t,extn_lst
! rearanging of station codes to lower case
call all_to_lower(num_obs, stn_old, stn)
! Rearranging to geomagnetic coordinates
if (key_mag .gt. 0) then
call geo_to_mag(num_obs,stn, d_rad)
end if
! initializing arrays
k_row=0
call doy_from_day(i_year,i_mon,i_day_st,i_doy_st)
call dayt_from_doy(i_year,i_doy_st,i_year_00, i_doy_00, i_da_st)
do i_day=i_day_st,i_day_fn   
call doy_from_day(i_year,i_mon,i_day,i_doy)
call dayt_from_doy(i_year,i_doy,i_year_00, i_doy_00, i_da)
do i_p=1,n_p_day
k_row=k_row+1
t_abs=i_da-1+(i_p-1)*1./n_p_day
b(k_row,1)=t_abs
do i_col=2,num_obs*2+1
b(k_row,i_col)=1-1.e11
end do
end do
end do

do i_day=i_day_st,i_day_fn   ! Cycle over days
L_fil_b=len_trim(fil_b)
write(frmt_b, '(a2,i2,a10)') '(a' , L_fil_b, ',a1,3i2.2)'
write(fil_in, frmt_b) fil_b,p_t,i_yr,i_mon,i_day
open (unit=1, file=pth_in//fil_in, iostat=i_o_s)
write(*,*) i_day
if (i_o_s .eq. 0) then    ! If file exists
read(1,'(4000a1440)',err=311,end=311) (str_tot(j), j=1,4000)
k_rec=0
key_read=.true.
do while (key_read)   ! Reading strings inside file
k_rec=k_rec+1
read(str_tot(k_rec),'(i4,i3,i2,i3,a3,2i5,a23,i4,5i2,i1,i4,2(i2,i1),i1,a85,183i7)',err=211)  &
&     l_rec,mnt_rec,i_type,i_obser,obs_old(1),iglat,iglon,str,i_year0,i_mon0,i_day0,i_hr,i_min,  &
&     idt_in, i_pr, i_flt, i_slp, i_base, i_bv, i_cmp, i_day_q, strr, ix(1:183)

if (i_day0 .gt. 0) then    ! If string is not empty

!write(*,*) idt_in, ix(178:180)
!pause
call doy_from_day(i_year0, i_mon0, i_day0, i_doy0)
call dayt_from_doy(i_year0,i_doy0,i_year_00,i_doy_00,i_da0)
i_row_0=(i_da0-i_da_st)*n_p_day
do i_obs=1,num_obs     ! Cycle over stations to choose one just read
call all_to_lower(1, obs_old, obs_new)
obs=obs_new(1)
if (obs .eq. stn(i_obs)) then     ! formation of arrays
i_cmp_out(i_obs)=i_cmp
i_rf=i_dt/idt_in
n_dt=mnt_rec*60/i_dt
it_sec=60*(i_hr*60+i_min)
i_rday_st=it_sec/i_dt
do i_bl=1,n_dt   ! Cycle over blocks
s_x(1:2)=0.
k_x(1:2)=0.
b_av(1:2)=0.
do i_ct=1,i_rf
do i_ch=1,2
num_el=(i_bl-1)*3*i_rf+(i_ct-1)*3+i_ch
if (ix(num_el) .le. a_val(1) .and. ix(num_el) .ge. a_val(2)) then
s_x(i_ch)=s_x(i_ch)+ix(num_el)
k_x(i_ch)=k_x(i_ch)+1
end if
end do
end do
i_row=i_row_0+i_rday_st+i_bl
do i_ch=1,2
if (k_x(i_ch) .gt. 0) then
b_av(i_ch)=s_x(i_ch)/k_x(i_ch)
if (key_mag .gt. 0) then
if (i_ch .eq. 1) then
b_av_n(i_ch)=b_av(i_ch)*dcos(d_rad(i_obs))+b_av(i_ch+1)*dsin(d_rad(i_obs))
else
b_av_n(i_ch)=b_av(i_ch)*dcos(d_rad(i_obs))-b_av(i_ch-1)*dsin(d_rad(i_obs))
end if
i_col=(i_obs-1)*2+i_ch+1
b(i_row,i_col)=b_av_n(i_ch)/1.d1
end if
end if
end do
end do ! Cycle over blocks end
end if
end do  ! Cycle over stations end
else
write(*,*) obs
key_read=.false.
end if
goto 212
211 key_read=.false.
212 end do
311 close(1)
end if
end do
open (2, file=pth_out//fil_out)
num_col=2*num_obs+1

do i_row=1,k_row
write(2,frmt_out) b(i_row,1:num_col)
end do
close (2)
open (3, file=pth_out//fil_lst)
write (3, '(i4, i3)') i_year, i_mon
write (3, '(a27,i4)') 'number of Stations=', num_obs
do i_obs=1,num_obs
i_cmpp=i_cmp_out(i_obs)
if (key_mag .gt. 0) then
i_cmpp=3
end if
write(3, '(a3,2x,a10)') stn(i_obs), str_cmp(i_cmpp)
end do
close (3)

222 end

!_________________
!  © n_y 2007.07.06