Skip to content

S
solvers-acuk-m
Commit f9673ee9 authored by Takhir Fakhrutdinov's avatar Takhir Fakhrutdinov
Browse files
Options

Добавили папку rdjson

parent f89f998d
Hide whitespace changes
Inline Side-by-side
Showing with 2527 additions and 0 deletions
.gitignore
View file @ f9673ee9
...@@ -7,4 +7,5 @@ ...@@ -7,4 +7,5 @@
!fson/ !fson/
!sofa_c/ !sofa_c/
!sofa/ !sofa/
!rdjson/
!fte/ !fte/
rdjson/.gitignore 0 → 100644
View file @ f9673ee9
*
!*.f95
!makefile
!.gitignore
rdjson/adaps_m.f95 0 → 100644
View file @ f9673ee9
!------------------------------------------------------------------------------
!> @group omcc - АСПОС ОКП
!> @author Нью-Ком Технолоджис
!> @file adaps_m.f95
!> @date November 9, 2016
!> @brief  Глобальные константы
!------------------------------------------------------------------------------
module adaps_m
use, intrinsic :: iso_fortran_env
implicit none
integer, public, parameter :: ORBIT_SIZE_ = 60 ! размер вектора орбит
integer, public, parameter :: SHORTORBIT_SIZE_ = 10 ! размер сокращенного вектора состояния
integer, public, parameter :: XALL_SIZE_ = 32 ! размер массива с прочей информацией /VZ 07.07.2014
integer, public, parameter :: XABS_SIZE_ = 11 ! размер расширенного вектора состояния
integer, public, parameter :: GLS_SIZE_ = 37 ! размер вектора с эфемеридной информацией /VZ 15.01.2014
integer, public, parameter :: GLONASS_SIZE_ = 7 ! размер вектора с эфемеридной информацией из альманаха ГЛОНАСС
integer, public, parameter :: GPSIAC_SIZE_ = 8 ! размер вектора с эфемеридной информацией из альманаха GPS по данным ЦУП
integer, public, parameter :: GPS_SIZE_ = 10 ! размер вектора с эфемеридной информацией из альманаха GPS
integer, public, parameter :: BDU_SIZE_ = 10 ! размер вектора с эфемеридной информацией из альманаха BEIDOU
integer, public, parameter :: ZNH_SIZE_ = 23 ! размер вектора СО ЗНХ
integer, public, parameter :: TLE_SIZE_ = 10 ! размер вектора СО TLE во внутреннем представлении
integer, public, parameter :: WTLE_SIZE_ = 11 ! размер расширенного вектора СО TLE
integer, public, parameter :: OTLE_SIZE_ = 12 ! размер вектора NKO+СО TLE в оригинальном представлении
integer, public, parameter :: DEXT_SIZE_ = 10 ! размер вектора dext
integer, public, parameter :: NIPS_SIZE_ = 4 ! размер вектора координат для группы ИП
integer, public, parameter :: LOCS_SIZE_ = 7 ! размер массива с характеристиками ошибок радиолокатора
integer, public, parameter :: NPOS_SIZE_ = 3 ! размер вектора координат для одного ИП
integer, public, parameter :: NIPINFO_SIZE_ = 10 ! размер информационного массива для ИП
integer, public, parameter :: LOCINFO_SIZE_ = 14 ! размер информационного массива для радиолокатора
integer, public, parameter :: NIPSFORECAST_SIZE_ = 16 ! размер массива прогноза погоды для группы НИП
integer, public, parameter :: TU_SIZE_ = 32 ! размер вектора технических условий для ИП
integer, public, parameter :: VIP_SIZE_ = 3 ! размер массива vip объектов (nko,рейтинг,кол-во проводок)
integer, public, parameter :: FORECAST_SIZE_ = 14 ! размер массива прогноза погоды
integer, public, parameter :: RAIT_SIZE_ = 9 ! размер вектора rating 7 + 2 (usat+dsat)
integer, public, parameter :: MASK_SIZE_ = 360 ! размер вектора исходной маски горизонта
integer, public, parameter :: STAT_SIZE_ = 15 ! размер массива статистики
integer, public, parameter :: HM_SIZE_ = 8 ! размерность матрицы измерений
integer, public, parameter :: EOPT_SIZE_ = 16 ! размерность массива с невязками
integer, public, parameter :: SEANCE_IC_ROPT_SIZE_ = 8 ! Размерность массива с измерениями в НУ для seance
integer, public, parameter :: SEANCE_IC_RLOC_SIZE_ = 8 ! Размерность массива с измерениями в НУ для seancerloc
integer, public, parameter :: MAN_SIZE_ = 12 ! Размерность массива с манёврами КА
integer, public, parameter :: BIND_SIZE_ = 19 ! размерность массива с информацией о привязках
integer, public, parameter :: BINDS_SIZE_ = 44 ! размерность массива с информацией о привязках (новый) 01.04.2021
integer, public, parameter :: CLUSTER_SIZE_ = 3 ! размерность массива с информацией о составе кластеров спутников
integer, public, parameter :: UNDEF_SIZE_ = 12 ! размерность массива с информацией о непрогнозируемых возмущениях
integer, public, parameter :: CONFIRM_SIZE_ = 5 ! размерность массива подтверждения
integer, public, parameter :: DAYS_SIZE_ = 30 ! количество суточных интервалов для решения задачи оценвания
integer, public, parameter :: WEEK_SIZE_ = 7 ! продолжительность контрольного интервала
integer, public, parameter :: EPH_SIZE_ = 6 ! размерность массива с эфемеридами
integer, public, parameter :: FUNS_SIZE_ = 11 ! размерность массива функционалов
integer, public, parameter :: FUNSLOC_SIZE_ = 14 ! размерность массива функционалов для радиолокационных измерений
integer, public, parameter :: ROPT_SIZE_ = 22 ! Размерность массива с оптическими измерениями
integer, public, parameter :: RLOC_SIZE_ = 32 ! Размерность массива с радиолокационными измерениями
integer, public, parameter :: FINFO_SIZE_ = 6 ! размер массива об усредненных значениях функционалов
integer, public, parameter :: METROPT_SIZE_ = 17 ! размерность массива с преобразованными измерениями
integer, public, parameter :: METRLOC_SIZE_ = 22 ! размерность массива с преобразованными измерениями для радиолокатора
integer, public, parameter :: METRSUM_SIZE_ = 25 ! размерность массива с преобразованными измерениями для радиолокатора
integer, public, parameter :: FILL_SIZE_ = 4 ! размерность массива с общей инормацией о сете на выбранном интервале
integer, public, parameter :: WIZM_SIZE_ = 14 ! размерности массива измерений подготовленных для обработки
integer, public, parameter :: UTC_SIZE_ = 7 ! размерности массива UTC во внутреннем представлении
integer, public, parameter :: ETALON_SIZE_ = 41 ! размерность массива со списком эталонных объектов
integer, public, parameter :: HIST_SIZE_ = 4 ! размерность массива с историей изменения параметров ИП
integer, public, parameter :: TORB_SIZE_ = 18 ! размерность массива временных орбит
integer, public, parameter :: JGROUP_SIZE_ = 2 ! размерность массива объектов для фомирования заданий на наблюдения
integer, public, parameter :: XA_SIZE_ = 8 ! размерность расширенного вектора состояния
integer, public, parameter :: MEASLOC_SIZE_ = 7 ! размерность массива с измерительной радиолокационной информацией
integer, public, parameter :: MEASOPT_SIZE_ = 5 ! размерность массива с измерительной оптической информацией
integer, public, parameter :: ITERMAXGR = 30 ! количество итераций в задаче уточнения полученной оценки (graduation)
integer, public, parameter :: ITERMAXQO = 15 ! количество итераций в задаче уточнения полученной оценки (qorbits)
integer, public, parameter :: SUMITERMAX = 100 ! предельное количество итераций
integer, public, parameter :: METHODX = 0 ! вариант задания вектора состояния в декартовой СК
integer, public, parameter :: METHODM = 1 ! вариант задания вектора состояния в модифицированных элементах
integer, public, parameter :: METHODL = 2 ! вариант задания вектора состояния в элементах Лагранжа
! ----------------------------------------------------------------------------------------------------------------------
! Структура с номерами КО и прочей лабудой для заполнения формы 200/400
! ----------------------------------------------------------------------------------------------------------------------
type SATCAT
integer :: dbno ! Номер объекта в базе
character (len=7) :: adaps ! Номер объекта в базе ADAPS (если есть NORAD = norad, если нет = Aznh)
integer :: norad ! Номер объекта в каталоге КК ВВС США
integer :: kiam ! Номер объекта в БД ИПМ
integer :: znh ! номер объекта ЗНХ
character (len=11) :: intdesNORAD ! Международное обозначение объекта в КК ВВС США ГГГГ-NNNPPP
! где ГГГГ-год запуска NNN - порядковый номер пуска в году PPP буквенное обозначение объекта в запуске
character (len=11) :: intdesIPM ! Международное обозначение объекта в сегменте АСПОС ГГГГNNNkkkk
! где ГГГГ-год запуска NNN - порядковый номер пуска в году kkkk цифровой порядковый номер обозначение объекта в запуске
character (len=11) :: objecttype ! тип объекта
character (len=40) :: satname ! название объекта
character (len=10) :: site ! полигон запуска
character (len=10) :: launch ! дата запуска
character (len=10) :: notActive ! дата прекращения существования
end type
! ----------------------------------------------------------------------------------------------------------------------
! Структура для работы с TLE
! ----------------------------------------------------------------------------------------------------------------------
type SGPTLE
integer :: NKO ! НКО номер объекта
integer :: TEPH ! изначально типы эфемерид, сейчас 0
real(8) :: TSINCE ! Эпоха задания вектора состояния (TT)
real(8) :: XMO ! средняя аномалия, рад
real(8) :: XINCL ! наклонение, рад
real(8) :: XNODEO ! долгота восходящего узла, рад
real(8) :: OMEGAO ! аргумент перигея, рад
real(8) :: EO ! эксцентриситет
real(8) :: XNO ! частота обращения (оборотов в день)
real(8) :: XNDT20 ! первая производная от среднего движения (ускорение), деленная на 2
real(8) :: XNDD60 ! Вторая производная от среднего движения, деленная на шесть
real(8) :: BSTAR ! Коэффициент торможения B* (BSTAR)
end type
end module adaps_m
rdjson/const_m.f95 0 → 100644
View file @ f9673ee9
!------------------------------------------------------------------------------
!> @group adaps - АСПОС ОКП
!> @author ИПМ им.Келдыша
!> @file print_cadr_m.f95
!> @date Ноябрь 8, 2016
!> @brief модуль определения констант
!------------------------------------------------------------------------------
module const_m
use, intrinsic :: iso_fortran_env
real(8) , parameter :: JDconst = 2400000.5D00 ! константа для перевода в MJD
real(8) , parameter :: PENALTY = 1.0D20 ! штрафное значение
real(8) , parameter :: DNULL = 0.0D00 ! нулевое значение
! Зaдaниe пapaмeтpoв Зeмли. OЗЭ.
!
! AEARTB - бoльшaя пoлyocь OЗЭ. (км) (ПЗ-90.11)
! AEARTS - мaлaя пoлyocь OЗЭ. (км) (ПЗ-90.11)
! AEART0 - cpeдний paдиyc Зeмли. (км)
! EXEAR2 - пepвый экcцeнтpиcитeт в квaдpaтe (ПЗ-90.11)
! WEARTH - номинальная yглoвaя cкopocть вpaщeния Зeмли. (1/c)
! GRAVIT - гpaвитaциoннaя пocтoяннaя Зeмли (км^3/c^2) (ПЗ-90.11)
! C20 - коэффициент C20
! C30 - коэффициент C30
! C40 - коэффициент C40
!
! Физичecкиe пocтoянныe.
!
! CLIGHT - Cкopocть cвeтa (км/c)
!
real(8), parameter :: AEARTB = 0.6378136490D+04
real(8), parameter :: AEARTS = 0.63567513618+04
real(8), parameter :: AEART0 = 0.6371165000D+04
real(8), parameter :: WEARTH = 0.7292115146704D-04
real(8), parameter :: EXEAR2 = 0.66943661774819D-02
real(8), parameter :: GRAVIT = 398600.44180D+00
real(8), parameter :: CLIGHT = 299792.45800D+00
real(8), parameter :: C20 = -0.10826266835532D-02
real(8), parameter :: C30 = 0.25326564853322D-05
real(8), parameter :: C40 = 0.16196215913670E-05
!
! Постоянные
!
! DAS2R - Arcseconds to radians
! TURNAS - Arcseconds in a full circle
! DJ00 - Reference epoch (J2000.0), JD
! DJC - Days per Julian century
! D2PI - 2PI
! SECDAY - количество секунд в сутках
! MINDAY - количество минут в сутках
! DPI - PI
! DSMALL - маленькое число
! RADDEG - количество радиан в градусе
! DEGRAD - количество градусов в радиане
! TTBEGLIMIT - левая граница временной области
! TTENDLIMIT - правая граница временной области
!
real(8), parameter :: DAS2R = 4.848136811095359935899141D-6
real(8), parameter :: TURNAS = 1296000D0
real(8), parameter :: DJ00 = 2451545D0
real(8), parameter :: DJC = 36525D0
real(8), parameter :: D2PI = 6.283185307179586476925287D0
real(8), parameter :: SECDAY = 86400D00
real(8), parameter :: MINDAY = 1440D00
real(8), parameter :: DPI = 3.141592653589793238462643D0
real(8), parameter :: DSMALL = 1.0D-12
real(8), parameter :: DEGRAD = 57.2957795130823208D0
real(8), parameter :: RADDEG = 0.01745329251994329D0
! real(8), parameter :: TTBEGLIMIT = 2451536.5D00
real(8), parameter :: TTBEGLIMIT = 2440000.5D00
real(8), parameter :: TTENDLIMIT = 2525008.5D00
!
! Физические постоянные
!
! GRAVSU - гравитвционня постоянная Солнца (км**3/с**2)
! GRAVMO - гравитвционня постоянная Луны (км**3/с**2)
! CSUNE0 - световое давление у Земли (H/m**2)
! ASTRED - астрономическая единица длины (км)
!
real(8), parameter :: GRAVSU = 1.32715445D+11
real(8), parameter :: GRAVMO = 4.90277790D+03
real(8), parameter :: CSUNE0 = 4.56000000D-06
real(8), parameter :: ASTRED = 1.49597900D+08
!
! Базовые значения, описывющие произвольный КО
!
! CXBASE - коэффициент лобового сопротивления
! 1.0 - сфера
! 2.2 - конус, *** (Жданюк)
! CLBASE - коэффициент отражения
! 1.2 - среднее значение (Стат. Динамика)
! OPMBASE - базовое отношение площади к массе
! 1m2/1000кг = 0.001 (плотность воды)
!
real(8), parameter :: CXBASE = 2.2D00
real(8), parameter :: CLBASE = 1.2D00
real(8), parameter :: OPMBASE = 0.001D00
!
! NaN
real(8), parameter :: NaN = transfer(-2251799813685248_int64, 1._real64)
end module const_m
\ No newline at end of file
rdjson/delta_m.f95 0 → 100644
View file @ f9673ee9
!------------------------------------------------------------------------------
!> @group adaps - АСПОС ОКП
!> @author Нью-Ком Технолоджис
!> @file delta_m.f95
!> @date мар 21, 2019
!> @brief модуль задания области с параметрами интегрирования
!------------------------------------------------------------------------------
module delta_m
use, intrinsic :: iso_fortran_env
!
! deltaX(8) - R*8 вектор приращений
!
!real(8), public :: deltaX(8) = (/1.0D00,1.0D00,1.0D00,0.00001D00,0.00001D00,0.00001D00,0.1D00,0.1D00/)
real(8), public :: deltaX(8) = (/0.1D00,0.1D00,0.1D00,0.000001D00,0.000001D00,0.000001D00,0.001D00,0.001D00/)
real(8), public :: deltaXF(8) = (/0.01D00,0.01D00,0.01D00,0.0000001D00,0.0000001D00,0.0000001D00,0.001D00,0.001D00/)
real(8), public :: deltaXFF(8) = (/0.001D00,0.001D00,0.001D00,0.0000001D00,0.0000001D00,0.0000001D00,0.00001D00,0.00001D00/)
!
! формируем вектор приращений при расчете баллистических производных
! для координат - 1 км
! для скоростей - 0.1 м/c
! для коэффициента светового давления
! для баллистического коэффициента
!
!
! deltaM(8) - R*8 вектор приращений для модифицированных кеплеровых элементов
!
real(8), public :: deltaM(8) = (/1.0D00,3.0D-05,3.0D-05,1.0D-05,1.0D-05,3.0D-06,0.001D00,0.001D00/)
!real(8) :: deltaM(8) = (/0.01D00,1.0D-06,1.0D-06,1.0D-06,1.0D-06,1.0D-06,0.0001D00,0.0001D00/)
!
! для большой полуоси - 1км
! для эксцентриситета - 0.00001
! для углов - 0.000003 1 км=5"/(360*60*60)
!
! deltaL(8) - R*8 вектор приращений для элементов Лагранжа
!
real(8), public :: deltaL(8) = (/1.0D-6,1.0D-06,1.0D-06,1.0D-06,1.0D-06,1.0D-06,0.001D00,0.001D00/)
!
! для среднего движения - 1.0D-06
! для средней аномалии - 1.0D-06
! для k h p q эксцентриситета - 1.0D-06
! для коэффициентов - 0.001
! deltaS(8) - R*8 вектор приращений для элементов TLE
!
real(8),public :: deltaS(8) = (/1.0D-6,1.0D-06,1.0D-06,1.0D-06,1.0D-06,1.0D-06,1.0D-08,1.0D-08/)
!
! 1 - долгота восходящего узла, рад
! 2 - наклонение, рад
! 3 - Частота обращения (рад / мин)
! 4 - эксцентриситет
! 5 - аргумент перигея, рад
! 6 - средняя аномалия, рад
! 7 - Первая производная от среднего движения (ускорение), деленная на два
! 8 - Коэффициент торможения B* (BSTAR)
! deltaCOEF(8) - I*4 количество шагов поиска коэффициентов
!
integer(8),public :: deltaCOEF(8) = (/ 1,2,4,8,16,32,64,128 /)
end module delta_m
\ No newline at end of file
rdjson/forms_m.f95 0 → 100644
View file @ f9673ee9
! Copyright (c) 2016
!
! forms_m module
!
! File: forms_m.f95
! Author: Fakhrutdinov E. Takhir
!
! Created on November 20, 2016
module forms_m
use fson
use fson_value_m
use adaps_m
use const_m
use wrjson
implicit none
private
public :: frm_object_info, frm_statistics, frm_motion_model, frm_datetime, frm_additem, frm_attr
public :: frm_orbit_elem, frm_orbit_rv
public :: frm_covorb, frm_covrv, frm_covrnb
public :: frm_xml
interface frm_object_info
module procedure object_info
end interface
interface frm_additem
module procedure add_item_real
module procedure add_item_wattr_real
end interface
interface frm_attr
module procedure add_attr
end interface
interface frm_statistics
module procedure statistics
end interface
interface frm_motion_model
module procedure motionmodel
end interface
interface frm_datetime
module procedure datetime
end interface
interface frm_orbit_elem
module procedure orbit_elements
end interface
interface frm_orbit_rv
module procedure orbit_rv
end interface
interface frm_covorb
module procedure orbit_covelem
end interface
interface frm_covrv
module procedure orbit_covrv
end interface
interface frm_covrnb
module procedure orbit_covrnb
end interface
interface frm_xml
module procedure xml_header
end interface
contains
function add_attr(name,val,parent) result(rs)
type(fson_value), pointer, optional :: parent
character(len=*), intent(in) :: name
character(len=*), intent(in) :: val
type(fson_value), pointer :: rs
if(present(parent)) then
rs => parent
else
rs => js_object(null())
endif
call js_add(rs,name,val)
end function add_attr
subroutine add_item(parent,name,val,attr)
type(fson_value), pointer, intent(in) :: parent
type(fson_value), pointer, intent(in),optional :: attr
character(len=*), intent(in) :: name
character(len=*), intent(in) :: val
type(fson_value), pointer :: p
if(present(attr)) then
p => js_array(parent,name)
call fson_value_add(p,attr)
call js_add(p,value=val)
else
call js_add(parent,name,val)
endif
end subroutine add_item
subroutine add_item_wattr_real(parent,name,val,attr)
type(fson_value), pointer, intent(in) :: parent
type(fson_value), pointer, intent(in),optional :: attr
character(len=*), intent(in) :: name
real(8), intent(in) :: val
character(len=25) buff
write(buff,'(SPE20.13E3)') val
if(present(attr)) then
call add_item(parent,name,trim(adjustl(buff)),attr)
else
call add_item(parent,name,trim(adjustl(buff)))
endif
end subroutine add_item_wattr_real
subroutine add_item_real(parent,name,attr,aval,val)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in) :: name,attr,aval
real(8), intent(in) :: val
character(len=25) buff
write(buff,'(SPE20.13E3)') val
call add_item(parent,name,trim(adjustl(buff)),add_attr(attr,aval))
end subroutine add_item_real
function xml_header(parent,name) result(el)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in) :: name
type(fson_value), pointer :: el
type(fson_value), pointer :: attr
el => js_array(parent,name)
attr => js_object(el)
call js_add(attr,'xmlns:ss','urn:schemas-rka:aspos')
call js_add(attr,'xmlns:xsi','http://www.w3.org/2001/XMLSchema-instance')
call js_add(attr,'xsi:schemaLocation','urn:schemas-rka:aspos aspos_schema_unu.xsd')
el => js_object(el)
end function xml_header
subroutine object_info(CNKO,rs)
type(SATCAT), intent(in) :: CNKO ! структура с описанием номеров объекта
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
p => js_object(rs,'ObjectInfo')
if( CNKO % dbno < 16000000 ) then
call js_add(p,'ObjectNumber',trim(CNKO % adaps))
else
call js_add(p,'ObjectNumber','')
endif
if( CNKO % kiam > 0 ) then
call js_add(p,'IPMNumber',trim(adjustl(itoa(CNKO % kiam))))
else
call js_null(p,'IPMNumber')
endif
if( CNKO % norad > 0 ) then
call js_add(p,'NoradNumber',trim(adjustl(itoa(CNKO % norad))))
else
call js_null(p,'NoradNumber')
endif
call js_add(p,"IntdesNorad",trim(CNKO % intdesNORAD))
call js_add(p,'IntdesIPM',trim(CNKO % intdesIPM))
end subroutine object_info
subroutine statistics(STAT,rs)
real(8), intent(in) :: STAT(STAT_SIZE_)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p,r ! рабочие переменные
character(len=10) buff
p => js_object(rs,'Statistics')
call add_item_real(p,'Interval','unit','dd',STAT(1))
write(buff,'(I3.3)') int(STAT(2))
call js_add(p,'NightsCount',trim(adjustl(buff)))
write(buff,'(I2.2)') int(STAT(3))
call js_add(p,'SitesCount',trim(adjustl(buff)))
r => js_object(p,'AlphaStat')
call add_item_real(r,'Mean','unit','arcsec',STAT(4))
call add_item_real(r,'Median','unit','arcsec',STAT(5))
call add_item_real(r,'Sigma','unit','arcsec',STAT(6))
r => js_object(p,'DeltaStat')
call add_item_real(r,'Mean','unit','arcsec',STAT(7))
call add_item_real(r,'Median','unit','arcsec',STAT(8))
call add_item_real(r,'Sigma','unit','arcsec',STAT(9))
end subroutine statistics
subroutine motionmodel(rs)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
character(len=8) buff
!
!
! Параметры интегрирования передаваемые через общую область
!
! P_JD R*8 - TT генерации условий интегрирования
! P_TIMER R*8 - Интервал для обновления условий
! P_MODEL(6) I*4 - управляющие индексы
! 1 - гравитационноное влияние Солнца
! 2 - гравитационное влияние Луны
! 3 - нецентральность поля тяготения Земли
! 4 - учет светового давления
! 5 - учет сопротивления атмосферы
! 6 - количество учитываемых гармоник ГПЗ
! P_DAT R*8 - Delta AT (UTC-TAI)
! P_DUT1 R*8 - delta UT1 (UT1-UTC)
! P_XP R*8 - Смещение полюса XP на дату P_JD
! P_YP R*8 - Смещение полюса YP на дату P_JD
! P_SUN(6) R*8 - координаты x,y,z и скорости Солнца в J2000 на дату
! P_MOON(6) R*8 - координаты x,y,z и скорости Луны в J2000 на дату
! P_OPM R*8 - отношение площади к массе
! P_CX R*8 - коэффициент лобового сопротивления
! P_SV R*8 - коэффициент отражения (альбедо)
! P_SAEM(4) R*8 - индексы FAP
! 1- F0
! 2 - F
! 3 - F81
! 4 - Kp
! P_POM(3,3) R*8 - матрица перевода из ITRS в TIRS
! P_ERA(3,3) R*8 - матрица перевода из TIRS а ERS
! P_PN(3,3) R*8 - матрица перевода из ERS в J2000
! P-BIAS(3,3) R*8 - матрица перевода из GCRS в J2000
!
REAL(8) :: P_JD,P_TIMER,P_DAT,P_DUT1,P_XP,P_YP,P_SUN(6),P_MOON(6)
REAL(8) :: P_OPM,P_CX,P_SV,P_SAEM(4),P_POM(3,3),P_PN(3,3)
REAL(8) :: P_ERA(3,3), P_BIAS(3,3)
INTEGER(4) :: P_MODEL(6)
COMMON /NPARAM/ P_JD,P_TIMER,P_MODEL,P_DAT,P_DUT1,P_XP,P_YP,P_SUN,P_MOON,P_OPM,P_CX,P_SV,P_SAEM,P_POM,P_ERA,P_PN,P_BIAS
! include '../cmn/nparam.f95'
! используются следующие параметры
! P_MODEL(1)=1 ! гравитационноное влияние Солнца
! P_MODEL(2)=1 ! гравитационное влияние Луны
! P_MODEL(3)=1 ! нецентральность поля тяготения Земли
! P_MODEL(4)=1 ! учет светового давления
! P_MODEL(5)=1 ! учет сопротивления атмосферы
! P_MODEL(6)=8 ! количество учитываемых гармоник ГПЗ
p => js_object(rs,'MotionModel')
if(P_MODEL(3).eq.1) then
call js_add(p,'EarthGravModel','GRAV_EGM96') ! Тип модели гравитационного поля Земли
! GRAV_PZ90 - ПЗ-90
! GRAV_EGM96 - EGM96
! GRAV_JGM3 - JGM3
! GRAV_JGM2 - JGM2
! GRAV_JGM1 - JGM1
! GRAV_GEMT3 - GEMT3
! GRAV_GEMT2 - GEMT2
! GRAV_GEMT1 - GEMT1
! GRAV_WGS84 - WGS84
! GRAV_WGS72 - WGS72
! GRAV_MU - центральное поле притяжения
! GRAV_PZ9002S - ПЗ-90 02 усеченная
! GRAV_PZ9002 - ПЗ-90 полная
write(buff,'(I2.2)') P_MODEL(6)
call js_add(p,'EarthGravModelZ',trim(adjustl(buff)))
call js_add(p,'EarthGravModelT',trim(adjustl(buff)))
call js_add(p,'EarthGravModelS',trim(adjustl(buff)))
else
call js_add(p,'EarthGravModel','GRAV_MU') ! Тип модели гравитационного поля Земли
endif
call js_add(p,'MoonGravUse',trim(adjustl(itoa(P_MODEL(2)))))
call js_add(p,'SunGravUse',trim(adjustl(itoa(P_MODEL(1)))))
if(P_MODEL(5).eq.0) then
call js_add(p,'AtmModel','ATM_NONE') ! Тип модели атмосферы
! ATM_NONE без учета атмосферы
! ATM_DMA90 DMA90
! ATM_DMA77 DMA77
! ATM_MSIS90 MSIS90
! ATM_DMA2000 DMA2000
! ATM_USSA76 USSA76
! ATM_J72 J72
! ATM_JR JR
! ATM_CIRA90 CIRA90
! ATM_C81 C81
! ATM_DMA84 DMA84
! ATM_STATIC Static
! ATM_DMA2004 DMA2004
! ATM_DMA2004M DMA2004m
else
call js_add(p,'AtmModel','ATM_DMA90')
endif
if(P_MODEL(4).eq.0) then
call js_add(p,'SRPModel','LIGHT_NONE') ! Тип модели светового давления
! LIGHT_NONE без учета светового давления
! LIGHT_NOSHADOW без учета тени
! LIGHT_CILINDERSHADOW учет цилиндрической модели тени
else
call js_add(p,'SRPModel','LIGHT_CYLINDERSHADOW')
endif
!
! Заготовка для учета параметров описывающих коэффициенты использованные при моделировании возмущения от атмосферы
! блок AtmCoefTable
! CoefDay описатель подгруппы в группе AtmCoefTable
! Date Дата к которой относятся значения коэффициентов солнечной активности
! F01 Среднесуточное значение индекса F10.7
! F81w Средневзвешенное значение индекса F10.7 за 81 суток
! F81 Среднее значение индекса F10.7 за 81 суток
! F90 Среднее значение индекса F10.7 за 90 суток
! F135w Средневзвешенное значение индекса F10.7 за 135 суток
! F135 Среднее значение индекса F10.7 за 135 суток
! Ap Среднесуточное значение планетарной амплитуды геомагнитной возмущенности
! Kps Среднесуточное значение планетарного трехчасового индекса геомагнитной возмущенности
! Kp1 Значение первого планетарного трехчасового индекса геомагнитной возмущенности
! Kp2 Значение второго планетарного трехчасового индекса геомагнитной возмущенности
! Kp3 Значение третьего планетарного трехчасового индекса геомагнитной возмущенности
! Kp4 Значение четвертого планетарного трехчасового индекса геомагнитной возмущенности
! Kp5 Значение пятого планетарного трехчасового индекса геомагнитной возмущенности
! Kp6 Значение шестого планетарного трехчасового индекса геомагнитной возмущенности
! Kp7 Значение седьмого планетарного трехчасового индекса геомагнитной возмущенности
! Kp8 Значение восьмого планетарного трехчасового индекса геомагнитной возмущенности
!
end subroutine
subroutine datetime(TT1,TT2,name,rs)
real(8), intent(in) :: TT1,TT2
character(len=*), intent(in) :: name
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
integer :: IY,IM,ID,IH,ISEC,IMIN,MSEC,RC
real(8) :: TEMP, Fday
call iau_JD2CAL(TT1,TT2,IY,IM,ID,Fday,RC) ! григорианский календарь
TEMP=Fday*SECDAY
IH=int(TEMP/3600) ! целые часы
TEMP=TEMP-IH*3600.0D00 ! минуты
IMIN=int(TEMP/60) ! целые минуты
TEMP=TEMP-IMIN*60 ! секунды
ISEC=int(TEMP) ! целые секунды
MSEC=int((TEMP-ISEC)*1000) ! милисекунды
call add_item(rs,name,trim(dmy_datetime(IY,IM,ID,IH,IMIN,ISEC,MSEC)),add_attr('scale','UTC'))
end subroutine datetime
subroutine orbit_rv(Rv,rs)
real(8), intent(in) :: Rv(8)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
p => js_object(rs,'Rv')
call add_item_real(p,'X','unit','km',Rv(1))
call add_item_real(p,'Y','unit','km',Rv(2))
call add_item_real(p,'Z','unit','km',Rv(3))
call add_item_real(p,'VX','unit','km/s',Rv(4))
call add_item_real(p,'VY','unit','km/s',Rv(5))
call add_item_real(p,'VZ','unit','km/s',Rv(6))
call add_item_real(p,'S','unit','m^2/kg',Rv(7))
call add_item_real(p,'K','unit','m^2/kg',Rv(8))
end subroutine orbit_rv
subroutine orbit_covrv(UVars,Prv,rs)
real(8), intent(in) :: Prv(8,8)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
integer, intent(in) :: UVars ! Тип уточняемых параметров
! 0 - только 6-и мерный вектор
! 1 - 6-и мерный вектор и баллистический коэффициент
! 2 - 6-и мерный вектор и коэффициент светового давления
! 3 - 6-и мерный вектор баллистический коэффициент и коэффициент светового давления
type(fson_value), pointer :: p ! рабочие переменные
p => js_object(rs,'CovRv')
call add_item_real(p,'XX','unit','km^2',Prv(1,1))
call add_item_real(p,'YY','unit','km^2',Prv(2,2))
call add_item_real(p,'ZZ','unit','km^2',Prv(3,3))
call add_item_real(p,'VXVX','unit','(km/s)^2',Prv(4,4))
call add_item_real(p,'VYVY','unit','(km/s)^2',Prv(5,5))
call add_item_real(p,'VZVZ','unit','(km/s)^2',Prv(6,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'KK','unit','(m^2/kg)^2',Prv(7,7))
call add_item_real(p,'XY','unit','km^2',Prv(1,2))
call add_item_real(p,'XZ','unit','km^2',Prv(1,3))
call add_item_real(p,'XVX','unit','km*km/s',Prv(1,4))
call add_item_real(p,'XVY','unit','km*km/s',Prv(1,5))
call add_item_real(p,'XVZ','unit','km*km/s',Prv(1,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'XK','unit','km*(m^2/kg)',Prv(1,7))
call add_item_real(p,'YZ','unit','km^2',Prv(2,3))
call add_item_real(p,'YVX','unit','km*km/s',Prv(2,4))
call add_item_real(p,'YVY','unit','km*km/s',Prv(2,5))
call add_item_real(p,'YVZ','unit','km*km/s',Prv(2,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'YK','unit','km*(m^2/kg)',Prv(2,7))
call add_item_real(p,'ZVX','unit','km*km/s',Prv(3,4))
call add_item_real(p,'ZVY','unit','km*km/s',Prv(3,5))
call add_item_real(p,'ZVZ','unit','km*km/s',Prv(3,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'ZK','unit','km*(m^2/kg)',Prv(3,7))
call add_item_real(p,'VXVY','unit','(km/s)^2',Prv(4,5))
call add_item_real(p,'VXVZ','unit','(km/s)^2',Prv(4,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'VXK','unit','km/s*(m^2/kg)',Prv(4,7))
call add_item_real(p,'VYVZ','unit','(km/s)^2',Prv(5,6))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'VYK','unit','km/s*(m^2/kg)',Prv(5,7))
if(UVars.eq.2.or.UVars.eq.3) call add_item_real(p,'VZK','unit','km/s*(m^2/kg)',Prv(6,7))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'SS','unit','(m^2/kg)^2',Prv(8,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'XS','unit','km*(m^2/kg)',Prv(1,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'YS','unit','km*(m^2/kg)',Prv(2,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'ZS','unit','km*(m^2/kg)',Prv(3,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'VXS','unit','km/s*(m^2/kg)',Prv(4,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'VYS','unit','km/s*(m^2/kg)',Prv(5,8))
if(UVars.eq.1.or.UVars.eq.3) call add_item_real(p,'VZS','unit','km/s*(m^2/kg)',Prv(6,8))
if(UVars.eq.3) call add_item_real(p,'SK','unit','(m^2/kg)^2',Prv(7,8))
end subroutine orbit_covrv
subroutine orbit_elements(Orb,rs)
real(8), intent(in) :: Orb(9)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
character(len=25) buff
write(buff,'(SPE20.13E3)') Orb(3)
p => js_object(rs,'Orb')
call add_item_real(p,'Semiaxis','unit','km',Orb(1))
call add_item_real(p,'Inclination','unit','degree',Orb(2))
call js_add(p,'Eccentricity',value=trim(adjustl(buff)))
call add_item_real(p,'RAAN','unit','degree',Orb(4))
call add_item_real(p,'ArgOfPerigee','unit','degree',Orb(5))
call add_item_real(p,'ArgOfLatitude','unit','degree',Orb(6))
call add_item_real(p,'Period','unit','mm',Orb(7))
call add_item_real(p,'HApogee','unit','km',Orb(8))
call add_item_real(p,'HPerigee','unit','km',Orb(9))
end subroutine orbit_elements
subroutine orbit_covelem(PORB,rs)
real(8), intent(in) :: PORB(6,6)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
character(len=25) buff
write(buff,'(SPE20.13E3)') PORB(2,2)
p => js_object(rs,'CovOrb')
call add_item_real(p,'AA','unit','km^2',PORB(1,1))
call add_item_real(p,'AE','unit','km',PORB(1,2))
call add_item_real(p,'AW','unit','km*degree',PORB(1,3))
call add_item_real(p,'AI','unit','km*degree',PORB(1,4))
call add_item_real(p,'AO','unit','km*degree',PORB(1,5))
call add_item_real(p,'AT','unit','km*ss',PORB(1,6))
call js_add(p,'EE',value=trim(adjustl(buff)))
call add_item_real(p,'EW','unit','degree',PORB(2,3))
call add_item_real(p,'EI','unit','degree',PORB(2,4))
call add_item_real(p,'EO','unit','degree',PORB(2,5))
call add_item_real(p,'ET','unit','ss',PORB(2,6))
call add_item_real(p,'WW','unit','degree^2',PORB(3,3))
call add_item_real(p,'WI','unit','degree^2',PORB(3,4))
call add_item_real(p,'WO','unit','degree^2',PORB(3,5))
call add_item_real(p,'WT','unit','degree*ss',PORB(3,6))
call add_item_real(p,'II','unit','degree^2',PORB(4,4))
call add_item_real(p,'IO','unit','degree^2',PORB(4,5))
call add_item_real(p,'IT','unit','degree*ss',PORB(4,6))
call add_item_real(p,'OO','unit','degree^2',PORB(5,5))
call add_item_real(p,'OT','unit','degree*ss',PORB(5,6))
call add_item_real(p,'TT','unit','ss^2',PORB(6,6))
end subroutine orbit_covelem
subroutine orbit_covrnb(PRNB,rs)
real(8), intent(in) :: PRNB(6,6)
type(fson_value), pointer, intent(in) :: rs ! результат в формате json
type(fson_value), pointer :: p ! рабочие переменные
p => js_object(rs,'CovRnb')
call add_item_real(p,'RR','unit','km^2',PRNB(1,1))
call add_item_real(p,'NN','unit','km^2',PRNB(2,2))
call add_item_real(p,'BB','unit','km^2',PRNB(3,3))
call add_item_real(p,'VRVR','unit','(km/s)^2',PRNB(4,4))
call add_item_real(p,'VNVN','unit','(km/s)^2',PRNB(5,5))
call add_item_real(p,'VBVB','unit','(km/s)^2',PRNB(6,6))
call add_item_real(p,'RN','unit','km^2',PRNB(1,2))
call add_item_real(p,'RB','unit','km^2',PRNB(1,3))
call add_item_real(p,'RVR','unit','km*km/s',PRNB(1,4))
call add_item_real(p,'RVN','unit','km*km/s',PRNB(1,5))
call add_item_real(p,'RVB','unit','km*km/s',PRNB(1,6))
call add_item_real(p,'NB','unit','km^2',PRNB(2,3))
call add_item_real(p,'NVR','unit','km*km/s',PRNB(2,4))
call add_item_real(p,'NVN','unit','km*km/s',PRNB(2,5))
call add_item_real(p,'NVB','unit','km*km/s',PRNB(2,6))
call add_item_real(p,'BVR','unit','km*km/s',PRNB(3,4))
call add_item_real(p,'BVN','unit','km*km/s',PRNB(3,5))
call add_item_real(p,'BVB','unit','km*km/s',PRNB(3,6))
call add_item_real(p,'VRVN','unit','(km/s)^2',PRNB(4,5))
call add_item_real(p,'VRVB','unit','(km/s)^2',PRNB(4,6))
call add_item_real(p,'VNVB','unit','(km/s)^2',PRNB(5,6))
end subroutine orbit_covrnb
end module forms_m
\ No newline at end of file
rdjson/makefile 0 → 100644
View file @ f9673ee9
PLATFORM:=$(shell uname -s |awk -F- '{print $$1}')
FC=gfortran
RM=rm
AR = ar
ARFLAGS= ru
BUILDDIR = ../build/$(PLATFORM)
MODDIR = $(BUILDDIR)/mod
LIBDIR = $(BUILDDIR)/lib
SHAREDIR = $(BUILDDIR)/share
OBJDIR = $(BUILDDIR)/obj/rdjson
FCFLAGS = -MD -Wall -ffree-line-length-none -O -J$(MODDIR) -cpp
ifdef DEBUG
FCFLAGS += -g -O0 -DDEBUG=$(DEBUG)
else
FCFLAGS += -O2
endif
OBJS = $(addprefix $(OBJDIR)/,adaps_m.o const_m.o param_m.o delta_m.o rdjson.o wrjson.o)
DEPS = $(addprefix $(OBJDIR)/,$(patsubst %.f95,%.d,$(wildcard *.f*)))
MODS = $(addprefix $(MODDIR)/,$(patsubst %.f95,%.mod,$(wildcard *.f*)))
LIBTARGET=$(LIBDIR)/librdjson.a
all: dirs lib
.PHONY: dirs
dirs:
mkdir -p $(MODDIR) $(LIBDIR) $(OBJDIR)
lib: $(LIBTARGET)
$(LIBTARGET) : $(OBJS)
$(AR) $(ARFLAGS) $(LIBTARGET) $(OBJS)
$(OBJDIR)/%.o: %.f*
$(FC) -c $(FCFLAGS) -o $@ $<
include $(wildcard $(OBJDIR)/*.d)
.PHONY: clean
clean:
$(RM) -f $(OBJS) $(DEPS) $(MODS) $(LIBTARGET)
rdjson/param_m.f95 0 → 100644
View file @ f9673ee9
!------------------------------------------------------------------------------
!> @group adaps - АСПОС ОКП
!> @author Нью-Ком Технолоджис
!> @file param_m.f95
!> @date мар 21, 2019
!> @brief модуль задания области с параметрами интегрирования
!------------------------------------------------------------------------------
module param_m
use, intrinsic :: iso_fortran_env
! Параметры интегрирования передаваемые через общую область
real(8), public :: P_JD ! P_JD R*8 - TT генерации условий интегрирования P_JD=P_TT1+P_TT2
real(8), public :: P_TT1 ! P_TT1 R*8 - первая часть двусоставного времени (JD)
real(8), public :: P_TT2 ! P_TT2 R*8 - вторая часть двусоставного времени (JD)
real(8), public :: P_TIMER ! P_TIMER R*8 - Интервал для обновления условий
real(8), public :: P_DAT ! P_DAT R*8 - Delta AT (UTC-TAI)
real(8), public :: P_DUT1 ! P_DUT1 R*8 - delta UT1 (UT1-UTC)
real(8), public :: P_XP ! P_XP R*8 - Смещение полюса XP на дату P_JD
real(8), public :: P_YP ! P_YP R*8 - Смещение полюса YP на дату P_JD
real(8), public :: P_STIME ! P_STIME R*8 - Звездное время на Гринвиче на дату P_JD, рад
real(8), public :: P_SUN(6) ! P_SUN(6) R*8 - координаты x,y,z и скорости Солнца в J2000 на дату
real(8), public :: P_MOON(6) ! P_MOON(6) R*8 - координаты x,y,z и скорости Луны в J2000 на дату
real(8), public :: P_OPM ! P_OPM R*8 - отношение площади к массе
real(8), public :: P_CX ! P_CX R*8 - коэффициент лобового сопротивления
real(8), public :: P_SV ! P_SV R*8 - коэффициент отражения (альбедо)
real(8), public :: P_SAEM(4) ! P_SAEM(4) R*8 - индексы FAP ( F0, F, F81, Kp )
real(8), public :: P_POM(3,3) ! P_POM(3,3) R*8 - матрица перевода из ITRS в TIRS
real(8), public :: P_PN(3,3) ! P_ERA(3,3) R*8 - матрица перевода из TIRS а ERS
real(8), public :: P_ERA(3,3) ! P_PN(3,3) R*8 - матрица перевода из ERS в J2000
real(8), public :: P_BIAS(3,3) ! P-BIAS(3,3) R*8 - матрица перевода из GCRS в J2000
INTEGER(4), public :: P_MODEL(6) ! P_MODEL(6) I*4 - управляющие индексы:
! 1 - гравитационноное влияние Солнца
! 2 - гравитационное влияние Луны
! 3 - нецентральность поля тяготения Земли
! 4 - учет светового давления
! 5 - учет сопротивления атмосферы
! 6 - количество учитываемых гармоник ГПЗ
end module param_m
\ No newline at end of file
rdjson/rdjson.f95 0 → 100644
View file @ f9673ee9
! Copyright (c) 2015
!
! File: rdjson.f95
! Author: Fakhrutdinov E. Takhir
!
! Created on May 22, 2015, 13:30
!
! Описание: модуль чтения стандартных блоков из структуры JSON
!
module rdjson
use fson
use fson_value_m
use adaps_m
use const_m
implicit none
integer, parameter :: TMP_MASK_SIZE_ = 2 ! размер вектора исходной маски горизонта
integer, allocatable, dimension(:,:) :: nkomap
interface get_planic_common
module procedure get_planic_common_one
module procedure get_planic_common_many
end interface
interface get_vector
module procedure get_vector_i8
module procedure get_vector_i4
module procedure get_vector_r
end interface
interface get_alloc_vector
module procedure get_alloc_vector_i8
module procedure get_alloc_vector_i4
module procedure get_alloc_vector_r
end interface
interface get_matrix
module procedure get_matrix_i8
module procedure get_matrix_i4
module procedure get_matrix_r
end interface
interface get_alloc_matrix
module procedure get_alloc_matrix_i8
module procedure get_alloc_matrix_i4
module procedure get_alloc_matrix_r
end interface
contains
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] vector вектор - real(8) (:)
!! @param [in] offset смещение относительно начала массива JSON - integer
! ----------------------------------------------------------------------------------------------------------------------
subroutine readVector( json, vector, offset)
type(fson_value), intent(in), pointer :: json
real(8), intent(inout) :: vector(:)
integer, intent(in), optional :: offset
integer :: i
type(fson_value), pointer :: el
! обходим разные настройки компиляторов
vector = NaN
if( associated(json) ) then
if(present(offset)) then
el => fson_value_get(json,1+offset)
else
el => fson_value_get(json,1)
endif
do i = lbound(vector,1),ubound(vector,1)
call fson_get(el,value=vector(i))
el => el % next
if(.not.associated(el)) exit
enddo
endif
end subroutine readVector
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] vector вектор - real(8) (:)
!! @param [in] offset смещение относительно начала массива JSON - integer
! ----------------------------------------------------------------------------------------------------------------------
subroutine readI4Vector( json, vector)
type(fson_value), intent(in), pointer :: json
integer, intent(inout) :: vector(:)
integer :: i
type(fson_value), pointer :: el
integer(8) :: tmp
vector = 0
if( associated(json) ) then
el => fson_value_get(json,1)
do i = lbound(vector,1),ubound(vector,1)
call fson_get(el,value=tmp)
vector(i) = int(tmp,4)
el => el % next
if(.not.associated(el)) exit
enddo
endif
end subroutine readI4Vector
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из массива JSON c выделением памяти
!! @param [in] json указатель на структуру JSON - type(fson_value) pointer
!! @param [in] key наименование поля JSON c типом массив - character(len=*)
!! @param [out] sz - размер вектора - integer
!! @param [out] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine readAllocVector( json, key, sz, vector )
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
integer, intent(out) :: sz
real(8), intent(inout), allocatable :: vector(:)
type(fson_value), pointer :: array
integer :: alloc_err ! признак ошибки выделения памяти
array => fson_value_get(json,key)
sz = fson_value_count(array)
allocate(vector(sz),stat=alloc_err)
if(alloc_err.ne.0) then
write(ERROR_UNIT,*) 'DEBUG: try allocate ',key,' size:',sz
stop 'ERROR: can not allocate vector'
endif
call readVector(array,vector)
end subroutine readAllocVector
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из массива JSON c выделением памяти
!! @param [in] json указатель на структуру JSON - type(fson_value) pointer
!! @param [in] key наименование поля JSON c типом массив - character(len=*)
!! @param [out] sz - размер вектора - integer
!! @param [out] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine readAllocI4Vector( json, key, vector )
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
integer, intent(inout), allocatable :: vector(:)
type(fson_value), pointer :: array
integer :: alloc_err ! признак ошибки выделения памяти
integer :: sz
array => fson_value_get(json,key)
sz = fson_value_count(array)
allocate(vector(sz),stat=alloc_err)
if(alloc_err.ne.0) then
write(ERROR_UNIT,*) 'DEBUG: try allocate ',key,' size:',sz
stop 'ERROR: can not allocate vector'
endif
call readI4Vector(array,vector)
end subroutine readAllocI4Vector
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение матрицы из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] array матрица - real(8) (:,:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine readMatrix( json, array )
type(fson_value), intent(in), pointer :: json
real(8), intent(inout) :: array(:,:)
integer :: i,j
type(fson_value), pointer :: el,row
array = NaN
if( associated(json) ) then
row => json % children
do i = lbound(array,1),ubound(array,1)
el => row % children
do j= lbound(array,2),ubound(array,2)
call fson_get(el,value=array(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
endif
end subroutine readMatrix
! ----------------------------------------------------------------------------------------------------------------------
! readAllocMatrix - чтение c выделением памяти матрицы
! ----------------------------------------------------------------------------------------------------------------------
subroutine readAllocMatrix( json, key, rows, cols, array )
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
integer, intent(out) :: rows
integer, intent(in) :: cols
real(8), intent(inout), allocatable :: array(:,:)
type(fson_value), pointer :: matrix
integer :: alloc_err ! признак ошибки выделения памяти
matrix => fson_value_get(json,key)
if( associated(matrix) ) then
rows = fson_value_count(matrix)
if(rows.gt.0) then
allocate(array(rows,cols),stat=alloc_err)
if(alloc_err.ne.0) then
write(ERROR_UNIT,*) 'DEBUG: try allocate ',key,' rows:',rows,' cols:',cols
stop 'ERROR: can not allocate array'
endif
call readMatrix(matrix,array)
endif
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение матрицы из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] array матрица - integer(8) (:,:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine readIMatrix( json, array )
type(fson_value), intent(in), pointer :: json
integer(8), intent(inout) :: array(:,:)
integer :: i,j
type(fson_value), pointer :: el,row
array = 0
if( associated(json) ) then
row => json % children
do i = lbound(array,1),ubound(array,1)
el => row % children
do j= lbound(array,2),ubound(array,2)
call fson_get(el,value=array(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
endif
end subroutine readIMatrix
! ----------------------------------------------------------------------------------------------------------------------
! readAllocIMatrix - чтение c выделением памяти матрицы
! ----------------------------------------------------------------------------------------------------------------------
subroutine readAllocIMatrix( json, key , rows, cols, array )
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
integer, intent(out) :: rows
integer, intent(in) :: cols
integer(8), intent(inout), allocatable :: array(:,:)
type(fson_value), pointer :: matrix
integer :: alloc_err ! признак ошибки выделения памяти
matrix => fson_value_get(json,key)
if( associated(matrix) ) then
rows = fson_value_count(matrix)
if(rows.gt.0) then
allocate(array(rows,cols),stat=alloc_err)
if(alloc_err.ne.0) then
write(ERROR_UNIT,*) 'DEBUG: try allocate ',key,' rows:',rows,' cols:',cols
stop 'ERROR: can not allocate array'
endif
call readIMatrix(matrix,array)
endif
endif
end subroutine readAllocIMatrix
! ----------------------------------------------------------------------------------------------------------------------
! readOrbits - чтение массива орбит
! ----------------------------------------------------------------------------------------------------------------------
subroutine readOrbits( json, orbtype, n_orbits, orbits)
character(len=*) :: orbtype
type(fson_value), pointer :: json
integer :: n_orbits
real(8), allocatable :: orbits(:,:) ! массив орбит
call readAllocMatrix(json,orbtype,n_orbits,ORBIT_SIZE_,orbits)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readDext - чтение массива dext
! ----------------------------------------------------------------------------------------------------------------------
subroutine readDext( json, n_dext, dext)
type(fson_value), pointer :: json
integer :: n_dext
real(8), allocatable :: dext(:,:) ! массив внешних данных N*10 (iers и идексов солнечной активности на период N дней)
call readAllocMatrix(json,'dext',n_dext,DEXT_SIZE_,dext)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! initTuNames - инициализация массива наименованиия ТУ
! ----------------------------------------------------------------------------------------------------------------------
subroutine initTUNames( tu_names )
character( len=* ) :: tu_names(TU_SIZE_)
!--------------------------------------------------------------------------------------------------------------------
! задаем названия ТУ планирования
!--------------------------------------------------------------------------------------------------------------------
! max-len -----------------------------------------------------------------
tu_names( 1) = 'мин. угол места КО, °'
tu_names( 2) = 'макс. фазовый угол, °'
tu_names( 3) = 'предельная звезднвя величина'
tu_names( 4) = 'угол погружения Солнца, °'
tu_names( 5) = 'мин. угловое расстояние до Луны, °'
tu_names( 6) = 'учет тени Земли'
tu_names( 7) = 'учет Млечного пути'
tu_names( 8) = 'учет маски горизонта'
tu_names( 9) = 'учет ограничений по времени на измерение'
tu_names(10) = 'режим поиска'
tu_names(11) = 'макс. угловая скорость относительно наблюдателя, \"/с'
tu_names(12) = 'количество кадров в серии'
tu_names(13) = 'время на измерение (наведение+экспозиция), с'
tu_names(14) = 'макс. длина проводки, с'
tu_names(15) = 'кол-во измерений в проводке'
tu_names(16) = 'длительность перекладки через меридиан, с'
tu_names(17) = 'мин. скорость ведения, \"/с'
tu_names(18) = 'макс. угловая скорость перенаведения, °/с'
tu_names(19) = 'ведение объекта при экспозиции'
tu_names(20) = 'длительность экспозиции, с'
tu_names(21) = 'угол обзора по прямому восхождению, °'
tu_names(22) = 'угол обзора по склонению, °'
tu_names(23) = 'СКО астрометрической ошибки, \"'
tu_names(24) = 'СКО случайной ошибки вычисления времени кадра, \"'
tu_names(25) = 'формат вывода'
tu_names(26) = 'систематическая ошибка вычисления времени кадра, \"'
tu_names(27) = 'сдвиг относительно зоны, ч'
tu_names(28) = 'интервал между автофокусировками, с'
tu_names(29) = 'продолжительность автофокусировки, с'
tu_names(30) = 'приоритет выбора объектов по ЦУ'
tu_names(31) = 'назначение ИП'
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readNipTU - чтение ТУ планирования для ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine readNipTU( json, nip_tu)
type(fson_value), pointer :: json
real(8) :: nip_tu(TU_SIZE_) ! массив c техническими условиями ИП
type(fson_value), pointer :: array,row
integer :: t, tp, n_tu
!--------------------------------------------------------------------------------------------------------------------
! задаем ТУ планирования по умолчанию
!--------------------------------------------------------------------------------------------------------------------
nip_tu( 1) = 10.0D00 ! минимальный угол места
nip_tu( 2) = 80.0D00 ! максимальный фазовый угол
nip_tu( 3) = 14.0D00 ! задание блеска
nip_tu( 4) = 18.0D00 ! Угол погружения Солнца
nip_tu( 5) = 5.0D00 ! минимальное угловое расстояние до Луны
nip_tu( 6) = 1.0D00 ! признак учета тени Земли
nip_tu( 7) = 1.0D00 ! признак учета млечного пути
nip_tu( 8) = 1.0D00 ! признак учета маски горизонта
nip_tu( 9) = 1.0D00 ! признак учета зависимости блеска от угла места
nip_tu(10) = 1.0D00 ! режим поиска
nip_tu(11) = 10.0D00 ! максимальная угловая скорость относительно наблюдателя
nip_tu(12) = 1.0D00 ! минимальный интервал видимости
nip_tu(13) = 20.0D00 ! время на одно измерение
nip_tu(14) = 1200.0D00 ! время на одну проводку
nip_tu(15) = 7.0D00 ! количество измерений в проводке
nip_tu(16) = 180.0D00 ! время перекладки через меридиан
nip_tu(17) = 1.0D00 ! минимальная скорость ведения
nip_tu(18) = 1.0D00 ! максимальная угловая скорость перенаведения
nip_tu(19) = 0.0D00 ! Ведение объекта при экспозиции
nip_tu(20) = 12.0D00 ! время экспозиции
nip_tu(21) = 2.3D00 ! поле зрения по Аz
nip_tu(22) = 2.3D00 ! поле зрения по Alt
nip_tu(23) = 1.0D00 ! СКО астрометрической ошибки, "
nip_tu(24) = 1.0D00 ! СКО ошибки измерения времени, "
nip_tu(25) = 1.0D00 ! формат вывода
nip_tu(26) = 0.0D00 ! систематическая ошибка времени, "
nip_tu(27) = 0.0D00 ! сдвиг относительно зоны, ч
nip_tu(28) = 0.0D00 ! интервал между автофокусировками, с
nip_tu(29) = 0.0D00 ! продолжительность автофокусировки, с
nip_tu(30) = 0.0D00 ! приоритет выбора объетов по ЦУ
nip_tu(31) = 0.0D00 ! назначение ИП
!--------------------------------------------------------------------------------------------------------------------
! читаем ТУ планирования
!--------------------------------------------------------------------------------------------------------------------
array => fson_value_get(json,'tu')
if(associated(array)) then
n_tu = min(fson_value_count(array),TU_SIZE_)
do t = 1,n_tu
row => fson_value_get(array,t)
call fson_get(row,'tp',tp)
call fson_get(row,'prm_value',nip_tu(tp-24000))
enddo
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readPlanTU - чтение ТУ планирования
! ----------------------------------------------------------------------------------------------------------------------
subroutine readPlanTU( json, nip_tu, tu_names )
type(fson_value), pointer :: json
real(8) :: nip_tu(TU_SIZE_) ! массив c техническими условиями ИП
character( len=* ) :: tu_names(TU_SIZE_)
!-------------------------------------------------------------------------------------------------------------------
! инициализируем массив наименований ТУ
!-------------------------------------------------------------------------------------------------------------------
call initTUNames(tu_names)
!--------------------------------------------------------------------------------------------------------------------
! читаем ТУ планирования
!--------------------------------------------------------------------------------------------------------------------
call readNipTU( json, nip_tu )
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readNipGorizontMask - чтение маски горизонта ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine readNipGorizontMask( json, nip_mask, nip_tu )
type(fson_value), pointer :: json
real(8) :: nip_mask(MASK_SIZE_) ! итоговая маска горизонта для ИС
real(8) :: nip_tu(TU_SIZE_) ! массив c техническими условиями планирования
integer, allocatable :: tmp_mask(:,:) ! исходная маска горизонта ИС
type(fson_value), pointer :: array,row,el
integer :: alloc_err ! признак ошибки выделения памяти
real(8) :: delta
integer n_mask,i,j,k,l
do i=1,MASK_SIZE_
nip_mask(i) = nip_tu(1)
enddo
if(nip_tu(8).ne.0) then
array => fson_value_get(json,'gmask')
if(associated(array)) then
n_mask = fson_value_count(array)
allocate (tmp_mask(n_mask,TMP_MASK_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) then
stop 'ERROR: allocate temp_mask array'
endif
do i = 1,n_mask
row => fson_value_get(array,i)
do j = 1,TMP_MASK_SIZE_
el => fson_value_get(row,j)
call fson_get(el,value=tmp_mask(i,j))
enddo
enddo
! -- заполняем маску горизонта ИС
do i = 1,n_mask-1
k = tmp_mask(i,1)+1
l = tmp_mask(i+1,1)+1
! -- защита от дурака
if( l.gt.MASK_SIZE_ ) then
l = MASK_SIZE_
endif
delta = dble(tmp_mask(i+1,2)-tmp_mask(i,2))/dble(l-k)
do j = k,l
nip_mask(j) = tmp_mask(i,2)+(j-k)*delta
enddo
enddo
deallocate(tmp_mask)
endif
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readVipObjects - чтение массива отранжированных vip КО
! ----------------------------------------------------------------------------------------------------------------------
subroutine readVipObjects( json, n_vip, vips )
type(fson_value), pointer :: json
integer :: n_vip
real(8), allocatable :: vips(:,:) ! массив отранжированных vip КО
call readAllocMatrix(json,'vip_objects',n_vip,VIP_SIZE_,vips)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readWeatherForecast - чтение прогноза погоды
! ----------------------------------------------------------------------------------------------------------------------
subroutine readWeatherForecast( json, weather_forecast )
type(fson_value), pointer :: json
real(8) :: weather_forecast(FORECAST_SIZE_) ! текущий прогноз погоды, ближайший слева к местной полуночи
type(fson_value), pointer :: array
weather_forecast = 0.0D00
array => fson_value_get(json,'weather_forecast')
if(associated(array)) then
call readVector(array,weather_forecast)
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readNipsWeatherForecast - чтение прогноза погоды для группы НИПов на несколько суток
! ----------------------------------------------------------------------------------------------------------------------
subroutine readNipsWeatherForecast( json, n_forecast, weather_forecast )
type(fson_value), pointer :: json
integer :: n_forecast
real(8), allocatable :: weather_forecast(:,:) ! текущий прогноз погоды, ближайший слева к местной полуночи
call readAllocMatrix(json,'weather_forecast',n_forecast,NIPSFORECAST_SIZE_,weather_forecast)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readPlanNip - чтение иформации ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine readPlanNip( json, nip, nip_pos )
type(fson_value), pointer :: json
integer :: nip ! номер ИП при планировании
real(8) :: nip_pos(3) ! массив с координатами выбранного ИП
type(fson_value), pointer :: array,row
row => fson_value_get(json,'nip')
if(.not.associated(row)) then
stop 'ERROR: Not defined observer.'
endif
call fson_get(row,'id',nip)
array => fson_value_get(row,'pos')
if(.not.associated(array)) then
stop 'ERROR: Not defined observer coordinates.'
endif
call readVector(array,nip_pos)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readSatRating - чтение массива рейтигов КО
! ----------------------------------------------------------------------------------------------------------------------
subroutine readSatRating( json, n_rating, rsat)
type(fson_value), pointer :: json
integer :: n_rating
real(8), allocatable :: rsat(:,:) ! массив рейтинга КО
call readAllocMatrix(json,'rating',n_rating,RAIT_SIZE_,rsat)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readNips - чтение массива координат ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine readNips( json, n_nips, nips )
type(fson_value), pointer :: json
integer :: n_nips
real(8), allocatable :: nips(:,:)
call readAllocMatrix(json,'nips',n_nips,NIPS_SIZE_,nips)
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readObject - чтение структры описания объекта
! ----------------------------------------------------------------------------------------------------------------------
subroutine readObject(json,CNKO)
type(fson_value), pointer :: json
type(SATCAT) CNKO
if(associated(json)) then
call fson_get(json,'dbno',CNKO%dbno)
call fson_get(json,'adaps',CNKO%adaps)
call fson_get(json,'kiam',CNKO%kiam)
call fson_get(json,'znh',CNKO%znh)
call fson_get(json,'norad',CNKO%norad)
call fson_get(json,'intldes',CNKO%intdesNORAD)
call fson_get(json,'aspos_intldes',CNKO%intdesIPM)
call fson_get(json,'object_type',CNKO%objecttype)
call fson_get(json,'satname',CNKO%satname)
call fson_get(json,'site',CNKO%site)
call fson_get(json,'launch',CNKO%Launch)
call fson_get(json,'notactive',CNKO%notActive)
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! readOrbitsWOCV - чтение массива орбит идетификации (без КМ)
! ----------------------------------------------------------------------------------------------------------------------
subroutine readOrbitsWOCV( json, key, rows, array)
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
integer, intent(inout) :: rows
real(8), intent(inout), allocatable :: array(:,:)
! локальные переменные
type(fson_value), pointer :: matrix
integer :: alloc_err ! признак ошибки выделения памяти
integer :: i,j,cols
type(fson_value), pointer :: el,row
matrix => fson_value_get(json,key)
if( associated(matrix) ) then
rows = fson_value_count(matrix)
if(rows.gt.0) then
allocate(array(rows,ORBIT_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) then
write(ERROR_UNIT,*) 'DEBUG: try allocate ',key,' rows:',rows,' cols:',ORBIT_SIZE_
stop 'ERROR: can not allocate array'
endif
array = NaN
row => matrix % children
cols = fson_value_count(row)
do i = lbound(array,1),ubound(array,1)
el => row % children
do j= lbound(array,2),ubound(array,2)
if( cols > 32 .or. (j < 30 .or. j > 57) ) then
call fson_get(el,value=array(i,j))
el => el % next
endif
enddo
row => row % next
enddo
endif
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! getMeas - чтение массивов измерений и массива времён засечек
! ----------------------------------------------------------------------------------------------------------------------
subroutine getMeas(jp, meas_sz, meas, times_c, ic_sz)
type(fson_value), intent(in), pointer :: jp !< указатель на json
integer, intent(in) :: meas_sz !< размер вектора измерения
real(8), intent(inout), allocatable, dimension(:,:) :: meas !< измерения
character(len=*), intent(inout), allocatable, dimension(:) :: times_c !< засечки
integer, intent(in), optional :: ic_sz !< размер вектора измерения в НУ
! локальные переменные
type(fson_value), pointer :: el, row
integer :: alloc_err, i, j, rows, sz
sz = meas_sz
if(present(ic_sz)) sz = ic_sz
if( associated(jp) ) then
rows = fson_value_count(jp)
if(rows.gt.0) then
allocate(meas(rows,meas_sz),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate meas array.'
allocate(times_c(rows),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate times vector.'
meas = 0.0D00
row => jp % children
do i = lbound(meas,1),ubound(meas,1)
el => row % children
do j= lbound(meas,2),sz ! читаем вектор измерений
call fson_get(el,value=meas(i,j))
el => el % next
enddo
call fson_get(el,value=times_c(i)) ! читаем время
row => row % next
enddo
endif
endif
end subroutine getMeas
! ----------------------------------------------------------------------------------------------------------------------
! init_nkomap - инициализация справочника объектов
! ----------------------------------------------------------------------------------------------------------------------
subroutine init_nkomap( json )
type(fson_value), intent(in), pointer :: json
type(fson_value), pointer :: matrix,el,row
integer :: rows,i,j,alloc_err ! признак ошибки выделения памяти
matrix => fson_value_get(json,'nkomap')
if( associated(matrix) ) then
rows = fson_value_count(matrix)
if(rows.gt.0) then
allocate(nkomap(rows,2),stat=alloc_err)
if(alloc_err.ne.0) then
stop 'ERROR: can not allocate nkomap'
endif
row => matrix % children
do i = lbound(nkomap,1),ubound(nkomap,1)
el => row % children
do j= lbound(nkomap,2),ubound(nkomap,2)
call fson_get(el,value=nkomap(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
endif
endif
end subroutine init_nkomap
! ----------------------------------------------------------------------------------------------------------------------
! qfind - быстрый поиск по упорядоченному массиву
! ----------------------------------------------------------------------------------------------------------------------
function qfind_int(src,map) result(res)
integer, intent(in) :: src
integer, allocatable, dimension(:,:), intent(in) :: map
integer :: i,lb,ub,cn,res
lb = 1
ub = size(map,1)
i = (ub-lb)/2
cn = size(map,1) !защита от дурака
res=-1
do while (i.gt.0.and.cn.gt.0)
if(map(i,1).eq.src) then
res = i
exit
else if(map(i,1).lt.src) then
lb = i+1
else
ub = i-1
endif
i = lb+(ub-lb)/2
cn = cn - 1
enddo
end function qfind_int
! ----------------------------------------------------------------------------------------------------------------------
! qfind - быстрый поиск по упорядоченному массиву
! ----------------------------------------------------------------------------------------------------------------------
function qfind_float(src,map) result(res)
integer, intent(in) :: src
real(8), allocatable, dimension(:,:), intent(in) :: map
integer :: i,lb,ub,cn,res
lb = 1
ub = size(map,1)
i = (ub-lb)/2
cn = size(map,1) !защита от дурака
res=-1
do while (i.gt.0.and.cn.gt.0)
if(int(map(i,1)).eq.src) then
res = i
exit
else if(int(map(i,1)).lt.src) then
lb = i+1
else
ub = i-1
endif
i = lb+(ub-lb)/2
cn = cn - 1
enddo
end function qfind_float
! ----------------------------------------------------------------------------------------------------------------------
! getnko - получение номера КО по идентификатору
! ----------------------------------------------------------------------------------------------------------------------
function getnko(koid) result (nko)
integer, intent(in) :: koid
integer :: nko
nko = koid
if(koid.gt.0.and.allocated(nkomap)) then
nko = qfind_int(koid,nkomap)
if(nko.gt.0) nko = nkomap(nko,2)
endif
end function getnko
! ----------------------------------------------------------------------------------------------------------------------
! get_orbindex - получение индекса орбиты koid
! ----------------------------------------------------------------------------------------------------------------------
function get_orbindex(koid,orblist) result (ix)
integer, intent(in) :: koid
real(8), allocatable, dimension(:,:), intent(in) :: orblist
integer :: ix
ix = -1
if(allocated(orblist)) ix = qfind_float(koid,orblist)
end function get_orbindex
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [inout] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_vector_r( json, vector )
type(fson_value), intent(in), pointer :: json
real(8), intent(inout) :: vector(:)
integer :: i
type(fson_value), pointer :: el
! обходим разные настройки компиляторов
vector = NaN
el => fson_value_get(json,1)
do i = lbound(vector,1),ubound(vector,1)
call fson_get(el,value=vector(i))
el => el % next
if(.not.associated(el)) exit
enddo
end subroutine get_vector_r
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [inout] vector вектор - integer(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_vector_i8( json, vector )
type(fson_value), intent(in), pointer :: json
integer(8), intent(inout) :: vector(:)
integer :: i
type(fson_value), pointer :: el
! обходим разные настройки компиляторов
el => fson_value_get(json,1)
do i = lbound(vector,1),ubound(vector,1)
call fson_get(el,value=vector(i))
el => el % next
if(.not.associated(el)) exit
enddo
end subroutine get_vector_i8
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [inout] vector вектор - integer(4) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_vector_i4( json, vector )
type(fson_value), intent(in), pointer :: json
integer(4), intent(inout) :: vector(:)
integer :: i
type(fson_value), pointer :: el
! обходим разные настройки компиляторов
el => fson_value_get(json,1)
do i = lbound(vector,1),ubound(vector,1)
call fson_get(el,value=vector(i))
el => el % next
if(.not.associated(el)) exit
enddo
end subroutine get_vector_i4
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из массива JSON c выделением памяти
!! @param [in] json указатель на структуру JSON - vector
!! @param [out] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_vector_r ( json, vector )
type(fson_value), intent(in), pointer :: json
real(8), intent(inout), allocatable :: vector(:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(vector(sz),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate vector'
call get_vector_r(json,vector)
end subroutine get_alloc_vector_r
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из массива JSON c выделением памяти
!! @param [in] json указатель на структуру JSON - vector
!! @param [out] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_vector_i8 ( json, vector )
type(fson_value), intent(in), pointer :: json
integer(8), intent(inout), allocatable :: vector(:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(vector(sz),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate vector'
call get_vector_i8(json,vector)
end subroutine get_alloc_vector_i8
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение вектора из массива JSON c выделением памяти
!! @param [in] json указатель на структуру JSON - vector
!! @param [out] vector вектор - real(8) (:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_vector_i4 ( json, vector )
type(fson_value), intent(in), pointer :: json
integer(4), intent(inout), allocatable :: vector(:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(vector(sz),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate vector'
call get_vector_i4(json,vector)
end subroutine get_alloc_vector_i4
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение матрицы из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] array матрица - integer(8) (:,:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_matrix_i8( json, array )
type(fson_value), intent(in), pointer :: json
integer(8), intent(inout) :: array(:,:)
integer :: i,j
type(fson_value), pointer :: el,row
row => json % children
do i = lbound(array,1),ubound(array,1)
el => row % children
do j = lbound(array,2),ubound(array,2)
call fson_get(el,value=array(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
end subroutine get_matrix_i8
! ----------------------------------------------------------------------------------------------------------------------
! get_alloc_matrix - чтение c выделением памяти матрицы
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_matrix_i8( json, cols, array )
type(fson_value), intent(in), pointer :: json
integer, intent(in) :: cols
integer(8), intent(inout), allocatable :: array(:,:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(array(sz,cols),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate array'
call get_matrix_i8(json,array)
end subroutine get_alloc_matrix_i8
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение матрицы из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] array матрица - integer(8) (:,:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_matrix_i4( json, array )
type(fson_value), intent(in), pointer :: json
integer(4), intent(inout) :: array(:,:)
integer :: i,j
type(fson_value), pointer :: el,row
row => json % children
do i = lbound(array,1),ubound(array,1)
el => row % children
do j = lbound(array,2),ubound(array,2)
call fson_get(el,value=array(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
end subroutine get_matrix_i4
! ----------------------------------------------------------------------------------------------------------------------
! get_alloc_matrix - чтение c выделением памяти матрицы
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_matrix_i4( json, cols, array )
type(fson_value), intent(in), pointer :: json
integer, intent(in) :: cols
integer(4), intent(inout), allocatable :: array(:,:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(array(sz,cols),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate array'
call get_matrix_i4(json,array)
end subroutine get_alloc_matrix_i4
! ----------------------------------------------------------------------------------------------------------------------
!> Чтение матрицы из структуры JSON
!! @param [in] json указатель на массив JSON - type(fson_value) pointer
!! @param [out] array матрица - real(8) (:,:)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_matrix_r( json, array )
type(fson_value), intent(in), pointer :: json
real(8), intent(inout) :: array(:,:)
integer :: i,j
type(fson_value), pointer :: el,row
array = NaN
row => json % children
do i = lbound(array,1),ubound(array,1)
el => row % children
do j = lbound(array,2),ubound(array,2)
call fson_get(el,value=array(i,j))
el => el % next
if(.not.associated(el)) exit
enddo
row => row % next
enddo
end subroutine get_matrix_r
! ----------------------------------------------------------------------------------------------------------------------
! get_alloc_matrix - чтение c выделением памяти матрицы
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_alloc_matrix_r( json, cols, array )
type(fson_value), intent(in), pointer :: json
integer, intent(in) :: cols
real(8), intent(inout), allocatable :: array(:,:)
integer :: sz,alloc_err ! признак ошибки выделения памяти
sz = fson_value_count(json)
allocate(array(sz,cols),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate array'
call get_matrix_r(json,array)
end subroutine get_alloc_matrix_r
! ----------------------------------------------------------------------------------------------------------------------
! has_vector_null - проверка значений вектора
! ----------------------------------------------------------------------------------------------------------------------
function has_vector_null(json) result(res)
type(fson_value), intent(in), pointer :: json
logical :: res
type(fson_value), pointer :: el
res = .false.
el => fson_value_get(json,1)
do while (associated(el))
if(el%value_type.eq.TYPE_NULL) then
res = .true.
exit
endif
el => el % next
enddo
end function
! ----------------------------------------------------------------------------------------------------------------------
! get_hmask - чтение маски горизонта ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_hmask( json, nip_mask)
type(fson_value), pointer, intent(in) :: json
real(8), intent(inout) :: nip_mask(MASK_SIZE_) ! итоговая маска горизонта для ИС
integer, allocatable :: tmp_mask(:,:) ! исходная маска горизонта ИС
type(fson_value), pointer :: row,el
integer :: alloc_err
real(8) :: delta
integer :: n_mask,i,j,k,l
if(associated(json).and.json%value_type.ne.TYPE_NULL) then
n_mask = fson_value_count(json)
allocate (tmp_mask(n_mask,TMP_MASK_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: allocate temp_mask array'
do i = 1,n_mask
row => fson_value_get(json,i)
do j = 1,TMP_MASK_SIZE_
el => fson_value_get(row,j)
call fson_get(el,value=tmp_mask(i,j))
enddo
enddo
! -- заполняем маску горизонта ИС
do i = 1,n_mask-1
k = tmp_mask(i,1)+1
l = tmp_mask(i+1,1)+1
! -- защита от дурака
if( l.gt.MASK_SIZE_ ) l = MASK_SIZE_
delta = dble(tmp_mask(i+1,2)-tmp_mask(i,2))/dble(l-k)
do j = k,l
nip_mask(j) = tmp_mask(i,2)+(j-k)*delta
enddo
enddo
deallocate(tmp_mask)
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! get_zonerating_ - получение рейтинга зон
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_zonerating_(json,key,rt)
type(fson_value), intent(in), pointer :: json
character(len=*), intent(in) :: key
real(8), intent(inout), allocatable :: rt(:,:,:)
! локальные переменные
type(fson_value), pointer :: array, row, rate, el
integer :: layer,lat,lon
integer :: n_array,n_rate
integer :: i,j
array => fson_value_get(json,key)
if(.not.associated(array)) stop 'ERROR: Not defined zones ratings.'
n_array = fson_value_count(array)
do i = 1,n_array
row => fson_value_get(array,i)
call fson_get(row,'lr',value=layer)
rate => fson_value_get(row,'lat')
if( rate%value_type.ne.TYPE_NULL ) then
call fson_get(row,'lat',value=lat)
rate => fson_value_get(row,'rt')
n_rate = fson_value_count(rate)
do j = 1,n_rate
el => fson_value_get(rate,j)
call fson_get(fson_value_get(el,1),value=lon)
call fson_get(fson_value_get(el,2),value=rt(layer,lon,lat))
enddo
endif
enddo
end subroutine get_zonerating_
! ----------------------------------------------------------------------------------------------------------------------
! get_planic_common_one - получение общих НУ задач планирования для одного средства
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_planic_common_one(json,pltype,mjd,nipinfo,tu,hmask,dext,weather_forecast,vips,orbits)
type(fson_value), pointer, intent(in) :: json
integer, intent(inout) :: pltype
real(8), intent(inout) :: mjd
real(8), intent(inout) :: nipinfo(:)
real(8), intent(inout) :: tu(TU_SIZE_) ! массив c техническими условиями планирования
real(8), intent(inout) :: hmask(360) ! итоговая маска горизонта для ИС
real(8), allocatable, intent(inout) :: dext(:,:)
real(8), intent(inout) :: weather_forecast(FORECAST_SIZE_)
real(8), allocatable, optional, intent(inout) :: vips(:,:)
real(8), allocatable, optional, intent(inout) :: orbits(:,:)
type(fson_value), pointer :: el
call fson_get(json,'pltype',pltype)
call fson_get(json,'mjd',mjd)
call get_vector(fson_value_get(json,'nipinfo'),nipinfo)
call get_vector(fson_value_get(json,'tu'),tu)
hmask = tu(1)
if(tu(8).ne.0) call get_hmask(fson_value_get(json,'gmask'),hmask)
call get_alloc_matrix(fson_value_get(json,'dext'),DEXT_SIZE_,dext)
weather_forecast = 0.0D0
el => fson_value_get(json,'weather_forecast')
if(associated(el).and..not.has_vector_null(el)) call get_vector(el,weather_forecast)
if(present(vips)) then
el => fson_value_get(json,'vip_objects')
if(associated(el)) call get_alloc_matrix(el,VIP_SIZE_,vips)
endif
if(present(orbits)) call get_alloc_matrix(fson_value_get(json,'orbits'),ORBIT_SIZE_,orbits)
end subroutine get_planic_common_one
! ----------------------------------------------------------------------------------------------------------------------
! get_planic_common_many - получение общих НУ задач планирования для нескольких средств
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_planic_common_many(json,pltype,mjd,nipinfo,tu,hmask,dext,weather_forecast,vips,orbits)
type(fson_value), pointer, intent(in) :: json
integer, intent(inout) :: pltype
real(8), intent(inout) :: mjd
real(8), allocatable, intent(inout) :: nipinfo(:,:)
real(8), allocatable, intent(inout) :: tu(:,:) ! массив c техническими условиями планирования
real(8), allocatable, intent(inout) :: hmask(:,:) ! итоговая маска горизонта для ИС
real(8), allocatable, intent(inout) :: dext(:,:)
real(8), allocatable, intent(inout) :: weather_forecast(:,:)
real(8), allocatable, optional, intent(inout) :: vips(:,:)
real(8), allocatable, optional, intent(inout) :: orbits(:,:)
type(fson_value), pointer :: el
integer :: i, sz, alloc_err
call fson_get(json,'pltype',pltype)
call fson_get(json,'mjd',mjd)
call get_alloc_matrix(fson_value_get(json,'nipinfo'),NIPINFO_SIZE_,nipinfo)
call get_alloc_matrix(fson_value_get(json,'tu'),TU_SIZE_,tu)
sz = size(nipinfo,1)
! читаем маски горизонтов
allocate (hmask(sz,MASK_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: allocate mask array'
el => fson_value_get(json,'gmask')
do i=1,sz
hmask(i,:) = tu(i,1)
if(tu(i,8).ne.0) call get_hmask(fson_value_get(el,i),hmask(i,:))
enddo
call get_alloc_matrix(fson_value_get(json,'dext'),DEXT_SIZE_,dext)
allocate (weather_forecast(sz,FORECAST_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: allocate mask array'
weather_forecast = 0.0D0
do i = 1,sz
el => fson_value_get(fson_value_get(json,'weather_forecast'),i)
if(associated(el).and..not.has_vector_null(el)) call get_vector(el,weather_forecast(i,:))
enddo
if(present(vips)) then
el => fson_value_get(json,'vip_objects')
if(associated(el)) call get_alloc_matrix(el,VIP_SIZE_,vips)
endif
if(present(orbits)) call get_alloc_matrix(fson_value_get(json,'orbits'),ORBIT_SIZE_,orbits)
end subroutine get_planic_common_many
! ----------------------------------------------------------------------------------------------------------------------
! get_planic_zonratings - получение рейтинга зон
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_planic_zonratings(json,rgso,igso,ugso,bgso)
type(fson_value), pointer, intent(in) :: json
real(8), allocatable, intent(inout) :: rgso(:,:,:)
real(8), allocatable, intent(inout) :: igso(:,:,:)
real(8), allocatable, optional, intent(inout) :: ugso(:,:,:)
real(8), allocatable, optional, intent(inout) :: bgso(:,:,:)
call get_zonerating_(json,'rgso',rgso)
call get_zonerating_(json,'igso',igso)
if(present(ugso)) call get_zonerating_(json,'ugso',ugso)
if(present(bgso)) call get_zonerating_(json,'bgso',bgso)
end subroutine get_planic_zonratings
! ----------------------------------------------------------------------------------------------------------------------
! get_orbits_wocv - чтение массива орбит идетификации (без КМ)
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_orbits_wocv( matrix, array )
type(fson_value), intent(in), pointer :: matrix
real(8), intent(inout), allocatable :: array(:,:)
! локальные переменные
integer :: alloc_err ! признак ошибки выделения памяти
integer :: i,j,cols,rows
type(fson_value), pointer :: el,row
rows = fson_value_count(matrix)
if(rows.gt.0) then
allocate(array(rows,ORBIT_SIZE_),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: get_orbits_wocv can not allocate array'
array = NaN
row => matrix % children
cols = fson_value_count(row)
do i = lbound(array,1),ubound(array,1)
el => row % children
do j= lbound(array,2),ubound(array,2)
if( j < 30 .or. j > 57 ) then
call fson_get(el,value=array(i,j))
el => el % next
endif
enddo
row => row % next
enddo
endif
end subroutine
! ----------------------------------------------------------------------------------------------------------------------
! get_meas - чтение массивов измерений и массива времён засечек
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_meas(jp, meas_sz, meas, times_c)
type(fson_value), intent(in), pointer :: jp !< указатель на json
integer, intent(in) :: meas_sz !< размер вектора измерения
real(8), intent(inout), allocatable :: meas(:,:) !< измерения
character(len=*), intent(inout), optional, allocatable :: times_c(:) !< засечки
! локальные переменные
type(fson_value), pointer :: el, row
integer :: alloc_err, i, j, rows
rows = fson_value_count(jp)
if(rows.gt.0) then
allocate(meas(rows,meas_sz),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate meas array.'
if(present(times_c)) then
allocate(times_c(rows),stat=alloc_err)
if(alloc_err.ne.0) stop 'ERROR: can not allocate times vector.'
endif
meas = 0.0D00
row => jp % children
do i = lbound(meas,1),ubound(meas,1)
el => row % children
do j = lbound(meas,2),ubound(meas,2) ! читаем вектор измерений
call fson_get(el,value=meas(i,j))
el => el % next
enddo
if(present(times_c).and.associated(el)) call fson_get(el,value=times_c(i)) ! читаем время
row => row % next
enddo
endif
end subroutine get_meas
! ----------------------------------------------------------------------------------------------------------------------
! get_objinfo - чтение структры описания объекта
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_objinfo(json,info)
type(fson_value), pointer, intent(in) :: json
type(SATCAT), intent(inout) :: info
info%adaps = trim(' ')
info%intdesNORAD = trim(' ')
info%intdesIPM = trim(' ')
info%satname = trim(' ')
info%dbno = -1
info%kiam = -1
info%znh = -1
info%norad = -1
if(associated(json)) then
call fson_get(json,'koid',info%dbno,-1)
call fson_get(json,'adaps',info%adaps,'')
call fson_get(json,'kiam',info%kiam,-1)
call fson_get(json,'unko',info%znh,-1)
call fson_get(json,'norad',info%norad,-1)
call fson_get(json,'object_id',info%intdesNORAD,'')
call fson_get(json,'object_id_kiam',info%intdesIPM,'')
call fson_get(json,'object_name',info%satname,'')
endif
end subroutine get_objinfo
! ----------------------------------------------------------------------------------------------------------------------
! get_nipinfo - чтение информации об ИП
! ----------------------------------------------------------------------------------------------------------------------
subroutine get_nipinfo(json,nipinfo,locinfo)
type(fson_value), pointer, intent(in) :: json
real(8), allocatable, intent(inout) :: nipinfo(:,:)
real(8), allocatable, intent(inout) :: locinfo(:,:)
type(fson_value), pointer :: p
p => fson_value_get(json,'nipinfo')
if(associated(fson_value_get(p,'optical'))) call get_alloc_matrix(fson_value_get(p,'optical'),NIPINFO_SIZE_,nipinfo)
if(associated(fson_value_get(p,'rls'))) call get_alloc_matrix(fson_value_get(p,'rls'), LOCINFO_SIZE_,locinfo)
end subroutine get_nipinfo
end module rdjson
\ No newline at end of file
rdjson/wrjson.f95 0 → 100644
View file @ f9673ee9
! Copyright (c) 2016
!
! File: wrjson.f95
! Author: Fakhrutdinov E. Takhir
!
! Created on Nov 1, 2016, 13:30
!
! Описание: модуль создания структуры JSON
!
module wrjson
use fson
use fson_value_m
use fson_string_m
implicit none
character(len=*) , parameter , public :: ADAPS_ID = 'ADAPSLive! v.1.0'
private
public :: js_add,js_array,js_object,js_null,js_copy,js_init_result, iso_datetime, dmy_datetime, chartime, itoa, to_ttm
interface js_array
module procedure wr_create_array
end interface js_array
interface js_object
module procedure wr_create_object
end interface js_object
interface js_add
module procedure wr_add_real
module procedure wr_add_double
module procedure wr_add_integer
module procedure wr_add_bigint
module procedure wr_add_logical
module procedure wr_add_realvector
module procedure wr_add_doublevector
module procedure wr_add_intvector
module procedure wr_add_bigintvector
module procedure wr_add_string
end interface js_add
interface js_null
module procedure wr_add_null
end interface js_null
interface js_init_result
module procedure wr_initresult
end interface
interface js_copy
module procedure wr_value_copy
end interface
interface iso_datetime
module procedure wr_iso_datetime
end interface
interface dmy_datetime
module procedure wr_dmy_datetime
end interface
interface chartime
module procedure wr_chartime
end interface
interface itoa
module procedure wr_itoa_integer
module procedure wr_itoa_bigint
end interface
interface to_ttm
module procedure wr_to_ttm
end interface
contains
function wr_create_value(parent,tp,name) result(new)
type(fson_value), pointer, intent(in) :: parent
integer ,intent(in) :: tp
character(len=*), intent(in), optional :: name
type(fson_value), pointer :: new
new => fson_value_create()
new % value_type = tp
if(present(name)) then
new % name => fson_string_create(name)
endif
if(associated(parent)) call fson_value_add(parent,new)
end function wr_create_value
function wr_create_object(parent,name) result(new)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_OBJECT,name)
else
new => wr_create_value(parent,TYPE_OBJECT)
endif
end function wr_create_object
function wr_create_array(parent,name) result(new)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_ARRAY,name)
else
new => wr_create_value(parent,TYPE_ARRAY)
endif
end function wr_create_array
subroutine wr_add_real(parent,name,value,fmt)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
character(len=*), intent(in), optional :: fmt
real(4), intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_REAL,name)
else
new => wr_create_value(parent,TYPE_REAL)
endif
if(present(fmt)) new % value_fmt = trim(fmt)
new % value_real = dble(value)
end subroutine wr_add_real
subroutine wr_add_double(parent,name,value,fmt)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
character(len=*), intent(in), optional :: fmt
real(8), intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_REAL,name)
else
new => wr_create_value(parent,TYPE_REAL)
endif
if(present(fmt)) new % value_fmt = trim(fmt)
new % value_real = value
end subroutine wr_add_double
subroutine wr_add_integer(parent,name,value)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
integer, intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_INTEGER,name)
else
new => wr_create_value(parent,TYPE_INTEGER)
endif
new % value_integer = int(value,8)
end subroutine wr_add_integer
subroutine wr_add_bigint(parent,name,value)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
integer(8), intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_INTEGER,name)
else
new => wr_create_value(parent,TYPE_INTEGER)
endif
new % value_integer = value
end subroutine wr_add_bigint
subroutine wr_add_logical(parent,name,value)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
logical, intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_LOGICAL,name)
else
new => wr_create_value(parent,TYPE_LOGICAL)
endif
new % value_logical = value
end subroutine wr_add_logical
subroutine wr_add_null(parent,name)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
type(fson_value), pointer :: new
new => fson_value_create()
new % value_type = TYPE_NULL
if(present(name)) then
new % name => fson_string_create(name)
endif
call fson_value_add(parent,new)
end subroutine wr_add_null
subroutine wr_add_realvector(parent,vector)
type(fson_value), pointer, intent(in) :: parent
real(4), intent(in) :: vector(:)
integer i
do i = lbound(vector,1),ubound(vector,1)
call wr_add_real(parent,value=vector(i))
enddo
end subroutine wr_add_realvector
subroutine wr_add_doublevector(parent,vector)
type(fson_value), pointer, intent(in) :: parent
real(8), intent(in) :: vector(:)
integer i
do i = lbound(vector,1),ubound(vector,1)
call wr_add_double(parent,value=vector(i))
enddo
end subroutine wr_add_doublevector
subroutine wr_add_intvector(parent,vector)
type(fson_value), pointer, intent(in) :: parent
integer, intent(in) :: vector(:)
integer i
do i = lbound(vector,1),ubound(vector,1)
call wr_add_integer(parent,value=vector(i))
enddo
end subroutine wr_add_intvector
subroutine wr_add_bigintvector(parent,vector)
type(fson_value), pointer, intent(in) :: parent
integer(8), intent(in) :: vector(:)
integer i
do i = lbound(vector,1),ubound(vector,1)
call wr_add_bigint(parent,value=vector(i))
enddo
end subroutine wr_add_bigintvector
subroutine wr_add_string(parent,name,value)
type(fson_value), pointer, intent(in) :: parent
character(len=*), intent(in), optional :: name
character(len=*), intent(in) :: value
type(fson_value), pointer :: new
if(present(name)) then
new => wr_create_value(parent,TYPE_STRING,name)
else
new => wr_create_value(parent,TYPE_STRING)
endif
new % value_string => fson_string_create(value)
end subroutine wr_add_string
recursive subroutine wr_value_copy(this,trg,exclude_name)
type(fson_value), pointer :: this, trg, element, new
character (len = *), intent(in) :: exclude_name
integer :: i, count, lstr
character(len=1024) :: tmpstr
select case (this % value_type)
case(TYPE_OBJECT)
count = fson_value_count(this)
do i = 1, count
! get the element
element => fson_value_get(this, i)
new => fson_value_create()
new % value_type = element % value_type
! get the name
if(associated(element % name)) then
call fson_string_copy(element % name,tmpstr)
if(tmpstr.eq.exclude_name) then
nullify(new)
cycle
endif
new % name => fson_string_create(tmpstr)
endif
! recursive copy of the element
call fson_value_add(trg,new)
call wr_value_copy(element,new,exclude_name)
enddo
case (TYPE_ARRAY)
count = fson_value_count(this)
do i = 1, count
! get the element
element => fson_value_get(this, i)
new => fson_value_create()
new % value_type = element % value_type
call fson_value_add(trg,new)
! recursive copy of the element
call wr_value_copy(element,new,exclude_name)
enddo
case (TYPE_STRING)
lstr = fson_string_length(this % value_string)
call fson_string_copy(this % value_string, tmpstr)
trg % value_string => fson_string_create(tmpstr(1:lstr))
case (TYPE_LOGICAL)
trg % value_logical = this % value_logical
case (TYPE_INTEGER)
trg % value_integer = this % value_integer
case (TYPE_REAL)
trg % value_real = this % value_real
endselect
end subroutine wr_value_copy
function wr_initresult(value,rs,ifnotexists) result(isAdapsMessage)
! заполнение стандартной структуры сообщения adaps с результом расчета
type(fson_value) , pointer , intent(in) :: value, rs
logical , intent(in), optional :: ifnotexists
logical :: isAdapsMessage
type(fson_value) , pointer :: el
character(len=len(ADAPS_ID)) :: tmpstr
logical :: notexists = .false.
isAdapsMessage = .false.
! проверка идентификатора сообщения
el => fson_value_get(value,'id')
if(associated(el)) then
if(el % value_type.eq.TYPE_STRING) then
call fson_string_copy(el % value_string,tmpstr)
isAdapsMessage = tmpstr.eq.ADAPS_ID
endif
endif
if(present(ifnotexists)) notexists = ifnotexists
if(.not.isAdapsMessage.and.notexists) then
stop 'ADAPS message id not found'
endif
if(isAdapsMessage) then
call wr_value_copy(value,rs,'init')
else
call wr_add_string(rs,'id',ADAPS_ID)
endif
end function wr_initresult
function wr_chartime(hour,minute,second,milisecond) result(chtime)
integer , intent(in) :: hour
integer , intent(in), optional :: minute,second,milisecond
character(len=*) , parameter :: tmfmt = "I2.2,':',I2.2,':',I2.2"
character(len=*) , parameter :: msfmt = ",'.',I3.3"
character(len=50) :: cfmt
character(len=12) :: chtime
integer :: iminute = 0,isecond = 0
if(present(minute)) iminute = minute
if(present(second)) isecond = second
if(present(milisecond)) then
cfmt = '('//tmfmt//msfmt//')'
write(chtime,cfmt) hour,iminute,isecond,milisecond
else
cfmt = '('//tmfmt//')'
write(chtime,cfmt) hour,iminute,isecond
endif
end function
function wr_datetime(dmyfmt,year,month,day,hour,minute,second,milisecond) result(chdatetime)
! YYYY-MM-DD HH:MM:SS.MSS
character(len=50) :: chdatetime
character(len=*) , intent(in) :: dmyfmt
integer , intent(in) :: year,month,day,hour,minute,second
integer , intent(in), optional :: milisecond
character(len=*) , parameter :: tmfmt = ",I2.2,':',I2.2,':',I2.2"
character(len=*) , parameter :: msfmt = ",'.',I3.3"
character(len=128) :: cfmt
if(present(milisecond)) then
cfmt = '('//dmyfmt//tmfmt//msfmt//')'
write(chdatetime,cfmt) year,month,day,hour,minute,second,milisecond
else
cfmt = '('//dmyfmt//tmfmt//')'
write(chdatetime,cfmt) year,month,day,hour,minute,second
endif
end function wr_datetime
function wr_dmy_datetime(year,month,day,hour,minute,second,milisecond) result(chdatetime)
character(len=50) :: chdatetime
integer , intent(in) :: year,month,day
integer , intent(in), optional :: hour,minute,second,milisecond
integer :: ihour = 0, iminute = 0, isecond = 0
if(present(hour)) ihour = hour
if(present(minute)) iminute = minute
if(present(second)) isecond = second
if(present(milisecond)) then
chdatetime = wr_datetime("I2.2,'/',I2.2,'/',I4.4,X",day,month,year,ihour,iminute,isecond,milisecond)
else
chdatetime = wr_datetime("I2.2,'/',I2.2,'/',I4.4,X",day,month,year,ihour,iminute,isecond)
endif
end function wr_dmy_datetime
function wr_iso_datetime(year,month,day,hour,minute,second,milisecond) result(chdatetime)
character(len=50) :: chdatetime
integer , intent(in) :: year,month,day
integer , intent(in), optional :: hour,minute,second,milisecond
integer :: ihour = 0, iminute = 0, isecond = 0
if(present(hour)) ihour = hour
if(present(minute)) iminute = minute
if(present(second)) isecond = second
if(present(milisecond)) then
chdatetime = wr_datetime("I4.4,'-',I2.2,'-',I2.2,X",year,month,day,ihour,iminute,isecond,milisecond)
else
chdatetime = wr_datetime("I4.4,'-',I2.2,'-',I2.2,X",year,month,day,ihour,iminute,isecond)
endif
end function wr_iso_datetime
function wr_itoa_integer(value_integer) result(tmpstr)
integer, intent(in) :: value_integer
character(len=32) tmpstr
write(tmpstr,*) value_integer
write(tmpstr,'(A)') trim(adjustl(tmpstr))
end function wr_itoa_integer
function wr_itoa_bigint(value_bigint) result(tmpstr)
integer(8), intent(in) :: value_bigint
character(len=64) tmpstr
write(tmpstr,*) value_bigint
write(tmpstr,'(A)') trim(adjustl(tmpstr))
end function wr_itoa_bigint
!! преобразование mjd даты во внутренний формат
!> 40587 - mjd 1 jan 1970
!> @param [in] mjd дата и время в формате mjd
!> @result - время во внутреннем формате
function wr_to_ttm(mjd) result(ttm)
real(8), intent(in) :: mjd
integer(8) ttm
!ttm = floor((mjd-40587.0)*86400.0*1000000,8) не работает!!!
ttm = floor((mjd-40587.0)*86400.0*1000+0.5,8)*1000 ! округление до 3-х знаков( милисекунд )
end function
end module wrjson
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment