-
Notifications
You must be signed in to change notification settings - Fork 1
/
ipa_v2.4.f90
3516 lines (2465 loc) · 93 KB
/
ipa_v2.4.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
! v2.0 rewriten to include MPT method of roll designation
! v2.1 rewritten to handle filter-dependent FORE transformation
! v2.2 increased reachable target id to I10 in screen output
! v2.3 increased digits of dva_mag output, fixed imname and segname output
! v2.4 fixed allocation/deallocation problem with pa arrays when looping
include 'empt_modules.f90'
!-------------------------------------------------------
program ipa
use path_to_ref_files
use config_parameters
use target_cat
use derived_parameters
use pointings_and_groups
implicit none
! --- optimal pointing variables
integer, parameter :: msx=7 ! vector space sampling as odd fraction of acceptance zone in x
integer, parameter :: msy=13 ! vector space sampling as odd fraction of acceptance zone in x
real :: dx,dy
integer :: nx,ny
integer, allocatable :: smap(:,:) !digital shift vector array
real, allocatable :: tx(:),ty(:) ! tangential coordinates of targets
real, allocatable :: sx(:),sy(:) ! v2,v3 coordinates of viable slitlets (mas)
real*8, allocatable :: ra_f(:),dec_f(:)
real, allocatable :: pa_v3_f(:)
integer, allocatable :: n_targs_f(:),ids_f(:,:),id_list(:)
real ax_refra_p,ay_refdec_p
real apa_v3,roll_corr
! --- input and output files
character*70 list_peakfile
character*70 group_pointing_file
character*70 sky_plot
character*70 swarm_plot
character*70 pointing_map_plot
character*70 digital_map_plot
character*2 rn
! - spectral parameters
! integer :: n_disp
real :: lambda1,lambda2
character*6 gname
common/disp/lambda1,lambda2,gname
! --- MSA Parameters-------
integer :: mx,my
real :: x0(4),y0(4),rot(4),xpitch(4),ypitch(4),xopen(4),yopen(4),xbar,ybar
common/msa_dims/mx,my,x0,y0,rot,xpitch,ypitch,xopen,yopen,xbar,ybar
! --- slitmap --------------
integer :: slitmap(4,365,171)
common/slit_map/slitmap
! - prism seperations
integer prism_sep_p(4,365,171),prism_sep_m(4,365,171)
common/prism_length/prism_sep_p,prism_sep_m
real :: t_start,t_stop
integer i,j,k,ii,jj,ih,jh,iho,jho,ig,jg
integer nt,ns
integer n_vectors
real ax,ay,xm,ym,aax,aay
real dist_x,dist_y
integer max_peak,min_peak,n_peaks,peak_val
integer ip
real dra,ddec
real dlim_x,dlim_y,dax,day,ss,cc,pa_v3_tmp
real*8 ra_tmp,dec_tmp
integer it_reach,n_pass
logical group_output
integer initial_dig_depth,min_keep_depth
real*8 ra_old,dec_old,ra_diff,dec_diff
integer loopmax
call cpu_time(t_start)
write(*,*)
write(*,*) '-------------------------------------------------------------------------------'
write(*,*) '--- ipa - Initial Pointing Algorithm Module - Version 2.4 -- 1 September 2022 -'
write(*,*) '-------------------------------------------------------------------------------'
write(*,*)
call load_derived_parameters
dx=av_xopen/float(msx) ! vector space sampling in mas in x
dy=av_yopen/float(msy) ! vector space sampling in mas in y
group_output=.false.
initial_dig_depth=3
min_keep_depth=2
min_numb_groups=1
min_pointings_in_group=1
! read trial configuration file
call file_entry_ipa()
n_filt=2
! read ipa configuration file parameters
open(9,file=trim(ref_path)//'ipa.conf',status='old',access='sequential',form='formatted',err=10)
call skip_hashes(9)
read(9,*) group_output
call skip_hashes(9)
read(9,*) initial_dig_depth
call skip_hashes(9)
read(9,*) min_numb_groups
read(9,*) min_pointings_in_group
if (min_pointings_in_group.le.0) min_pointings_in_group=n_dither
call skip_hashes(9)
read(9,*) min_keep_depth
close(9)
goto 20
10 write(*,*) 'Error: IPA Configuration file not found'
stop
20 continue
! work out actual roll angle of central pointing
call get_cat_ref_position()
call get_mpt_roll_offset(cra,cdec,roll_corr)
apa_v3=cpa_v3+roll_corr
! work out pointing reference point for present roll angle
call roll_v3(apa_v3,ax_refv2,ay_refv3,ax_refra_p,ay_refdec_p) !RA,Dec
write(*,*)
write(*,'(a,I0)') ' Trial Identifier No.: ',ntile
write(*,'(a,a)') ' Configuration File: ',confname
write(*,'(a,a)') ' Disperser: ',disperser
write(*,'(a,f4.2)') ' S_0: ',sthresh
write(*,'(a,2f7.3)') ' Acceptance Zone: ',raccx,raccy
write(*,'(a,a)')' Target Catalog: ',catfile
write(*,'(a,2f13.7)') ' Catalog Median Reference Position: ',ra_c,dec_c
write(*,'(a,a)') ' Reference Image: ',imname
write(*,'(a,a)') ' Segmentation Map: ',segname
write(*,'(a,2f13.7,f10.4)') ' Nominal Pointing & Roll: ',cra,cdec,cpa_ap
write(*,'(a,f10.4)') ' Central Roll Correction: ',roll_corr
write(*,'(a,2f10.2)') ' Search Zone: ',szone_x,szone_y
write(*,'(a,f10.2,f9.5)') ' Angle_to_target,dva_mag:',angle_to_target,dva_mag
write(*,'(a,i0)') ' n_dither: ',n_dither
write(*,*)
if (group_output) then
write(*,'(a)') ' IPA Mode: Pointings Grouped'
write(*,'(a,i0)') ' Initial dig depth:: ',initial_dig_depth
write(*,'(a,i0)') ' Min pointings in group: ',min_pointings_in_group
write(*,'(a,i0)') ' Min number of groups: ',min_numb_groups
else
write(*,'(a)') ' IPA Mode: Pointings Not Grouped'
write(*,'(a,i0)') ' Initial dig depth:: ',initial_dig_depth
write(*,'(a,i0)') ' Min below max to save: ',min_keep_depth
endif
write(*,*)
! create output directory
write(rn,'(I2)') ntile
rn=trim(adjustl(rn))
if (ntile.lt.10) rn='0'//rn(1:1)
call system('mkdir trial_'//rn(1:2))
call system('mkdir trial_'//rn(1:2)//'/ipa_output')
! name output files
sky_plot='trial_'//rn(1:2)//'/ipa_output/input_catalog_on_sky.ps/cps'
swarm_plot='trial_'//rn(1:2)//'/ipa_output/on_sky_map_start.ps/cps'
digital_map_plot='trial_'//rn(1:2)//'/ipa_output/digital_peak_map.ps/cps'
group_pointing_file='trial_'//rn(1:2)//'/ipa_output/grouped_optimal_pointings.txt'
pointing_map_plot='trial_'//rn(1:2)//'/ipa_output/map_optimal_pointings.ps/cps'
! read in priority 1 targets from catalog
call cat_pri_one_read()
if (ntarg.le.0) then
write(*,*)
write(*,*) 'Error: No Targets in Input Catalog'
write(*,*)
stop
endif
if (ntarg_1.le.0) then
write(*,*)
write(*,*) 'Error: No Priority Class 1 Targets in Input Catalog'
write(*,*)
stop
endif
if (nclass.le.0) then
write(*,*)
write(*,*) 'Error: No Priority Class Designations in Input Catalog'
write(*,*)
stop
endif
print *
print *,'Targets in Input Catalog: ',ntarg
print *,'Priority 1 Targets: ',ntarg_1
print *,'Number of Priority Classes:',nclass
! initialize mode-specific instrument model subroutines
call load_msa_dimensions_bd
call load_fpa_dimensions_bd
call msa_to_fpa_disp(n_disp,2.,xm,ym,ax,ay)
! allocate priority 1 target coordinate list and reachable table
nt=ntarg_1
allocate (tx(nt),ty(nt),targ_poss(nt))
! construct priority 1 coordinate swarm on sky_plot at nominal pointing
do i=1,nt
call tangcoord_single(cra,cdec,ra_t(i),dec_t(i),ax,ay) !Ra,Dec
aax=ax*dva_mag+ax_refra_p !apply dva magnification and shift to origin at ref position
aay=ay*dva_mag+ay_refdec_p
! Rotate to V2,V3
call roll_v3(-apa_v3,aax,aay,ax,ay) !V2,V3
! Rotate to MSA coordinate system orientation
tx(i)= ax*cos(phi_r)+ay*sin(phi_r) !xm,ym as
ty(i)=-ax*sin(phi_r)+ay*cos(phi_r)
tx(i)=tx(i)*1000. !mas
ty(i)=ty(i)*1000.
enddo !nt
! construct viable slitlet swarm on sky
call read_shutter_values
if (n_disp.eq.7) call read_prism_separations
call read_base_msamap
call make_slitlet_map
call initialize_slitmap(n_disp,sthresh,1,1)
! determine how many viable slitlets are on msa
ns=0
do k=1,4
do i=1,365
do j=1,171
if (slitmap(k,i,j).eq.4) ns=ns+1
enddo !j
enddo !i
enddo !k
print *
print *,'Number Viable Slitlets on MSA: ',ns
! allocate viable slitlet coordinate list
allocate (sx(ns),sy(ns))
! load viable slitlet coordinate list
ii=0
do k=1,4
do i=1,365
do j=1,171
if (slitmap(k,i,j).ne.4) cycle
ii=ii+1
call shutter_to_msa_bd(k,i,j,xm,ym)
call msa_to_sky_bd(xm,ym,ax,ay) !V2,V3
! rotate to orientation of MSA system
aax= ax*cos(phi_r)+ay*sin(phi_r)
aay=-ax*sin(phi_r)+ay*cos(phi_r)
sx(ii)=aax*1000. !mas
sy(ii)=aay*1000.
enddo !j
enddo !i
enddo !k
! Plot initial slitlet and target swarms on sky
call plot_intial_swarms(nt,tx,ty,id_t,ns,sx,sy,szone_x,szone_y,swarm_plot)
! ------- construct digital shift vector array --------------------------------------
! calculate required size of digital shift array, allocate and null it
nx=int(szone_x*1000./dx) ! shift vector array -nx:nx in x
ny=int(szone_y*1000./dy) ! shift vector array -ny:ny in y
allocate (smap(-nx:nx,-ny:ny))
smap=0
! Fill in shift vector plane with all permissable target-slitlet combinations
n_vectors=0
do i=1,nt !run through all targets
targ_poss(i)=.false. !non-shiftable target assumed initially
do j=1,ns !run through all viable slitlets
! shift vector needed to move target i to center of viable slitlet j
dist_x=sx(j)-tx(i)
dist_y=sy(j)-ty(i)
! Is shift vector within allowable shift vector range?
if ((abs(dist_x).lt.szone_x*1000.).and.(abs(dist_y).lt.szone_y*1000.)) then
targ_poss(i)=.true. !target is shiftable
! Count peaks in shift vector plane
n_vectors=n_vectors+1 !number of peaks in shift vector plane
! round shift vector to nearest digitized (signed) pixel
ih=nint(dist_x/dx)
jh=nint(dist_y/dy)
! Increment shift vector plane by one unit over acceptance zone footprint in x and y
do ii=-(msx-1)/2,(msx-1)/2
do jj=-(msy-1)/2,(msy-1)/2
iho=ih+ii
jho=jh+jj
if ((abs(iho).le.nx).and.(abs(jho).le.ny)) then
smap(iho,jho)=smap(iho,jho)+1
endif
enddo
enddo
endif !in allowable shift zone end
enddo !j loop end
enddo !i loop end
! ------- Digital shift vector array calculation complete ---------------------------
! determine number of (not necessarily simultaneously) reachable targets
n_reach=0
do i=1,nt
if (targ_poss(i)) n_reach=n_reach+1
enddo
if (n_reach.le.0) then
write(*,*)
write(*,*) 'Error: No Priority Class 1 Targets Reachable in Search Box at Nominal Pointing'
write(*,'(a,a)') ' Consult figure: ',swarm_plot
write(*,*)
stop
endif
write(*,*)
write(*,'(a,i0)') ' Total Number of reachable Priority Class 1 targets within Shift Range: ',n_reach
write(*,*)
write(*,*) 'Reachable targets:'
write(*,*) ' ID_cat'
do i=1,nt
if (targ_poss(i)) then
write(*,'(i10)') id_t(i)
endif
enddo
write(*,*)
write(*,'(a,i0)') ' Total number of shift vectors in shift array: ',n_vectors
write(*,'(a,2f7.1)') ' Shift Array digitization [mas]:',dx,dy
! Single Reachable Priority 1 target shortcut start ----------------
if (n_reach.eq.1) then
ra_diff=0.0001/3600./cos(cdec/57.2957795) ! mas
dec_diff=0.0001/3600. !1 mas
loopmax=10
min_numb_groups=1
n_pass=1
max_peak=1
call plot_digital_shift_map(nx,ny,smap,dx,dy,max_peak,digital_map_plot)
deallocate (smap)
! figure out which target is the reachable one
do i=1,nt
if (targ_poss(i)) it_reach=i
enddo
! figure out how many shutters within the search zone the lone target can be placed in
n_peaks=0
do j=1,ns
dist_x=sx(j)-tx(it_reach)
dist_y=sy(j)-ty(it_reach)
if ((abs(dist_x).lt.szone_x*1000.).and.(abs(dist_y).lt.szone_y*1000.)) n_peaks=n_peaks+1
enddo
! allocate pointing save lists
allocate (ra_p(n_peaks),dec_p(n_peaks),pa_v3_p(n_peaks),pa_ap_p(n_peaks),n_targs_p(n_peaks),ids_p(n_peaks,1))
pa_v3_p(:)=apa_v3
pa_ap_p(:)=0.
ids_p=0
! go through through legal shifts a second time to calculate exact pointing values
n_peaks=0
do j=1,ns
dist_x=sx(j)-tx(it_reach)
dist_y=sy(j)-ty(it_reach)
if ((abs(dist_x).lt.szone_x*1000.).and.(abs(dist_y).lt.szone_y*1000.)) then
n_peaks=n_peaks+1
ax=dist_x/1000. !as
ay=dist_y/1000.
aax= ax*cos(phi_r)-ay*sin(phi_r) !rotate offset to v2,v3 orientation
aay= ax*sin(phi_r)+ay*cos(phi_r)
call roll_v3(pa_v3_p(n_peaks),aax,aay,ax,ay) !ra,dec arcsec orientation
ax=-ax
ay=-ay
! calculate matching pointing coordinate
call coordtang_single(cra,cdec,ax,ay,ra_old,dec_old)
! attach individual roll to pointing and do mac loopmax iterations on pointing
do ii=1,loopmax
call get_mpt_roll_offset(ra_old,dec_old,roll_corr)
pa_v3_p(n_peaks)=cpa_v3+roll_corr
call roll_v3(pa_v3_p(n_peaks),aax,aay,ax,ay) !ra,dec arcsec orientation
call coordtang_single(cra,cdec,-ax,-ay,ra_p(n_peaks),dec_p(n_peaks))
if ( (abs(ra_old-ra_p(n_peaks)).lt.ra_diff).and.(abs(dec_old-dec_p(n_peaks)).lt.dec_diff)) exit
ra_old=ra_p(n_peaks)
dec_old=dec_p(n_peaks)
enddo !ii
n_targs_p(n_peaks)=1
ids_p(n_peaks,1)=id_t(it_reach)
! fill in pa_ap_p array
pa_ap_p(n_peaks)=pa_v3_p(n_peaks)+(180.-phi)
if (pa_ap_p(n_peaks).gt.360.) pa_ap_p(n_peaks)=pa_ap_p(n_peaks)-360.
if (pa_ap_p(n_peaks).lt.0.) pa_ap_p(n_peaks)=pa_ap_p(n_peaks)+360.
endif
enddo !ns
deallocate (tx,ty,sx,sy)
max_targs=1
min_targs=0
write(*,*)
write(*,'(a,i0,a,i0,a)') ' Pointings providing simultaneous coverage from ',max_targs,' and down to ',max(min_targs,1),' targets will be sorted and saved'
n_p=n_peaks
np_max_targs=n_peaks
np_min_targs=0
write(*,*)
write(*,'(a,i0,a,i0)') ' Final number of identified ',max_targs,' target coverage pointings: ',np_max_targs
goto 10001
endif
! Single Reachable Priority 1 target shortcut end -------------------------
deallocate (tx,ty,sx,sy)
! determine maximum target overlap hits in digital shift vector array ------
max_peak=-666
do i=-nx,nx
do j=-ny,ny
max_peak=max(max_peak,smap(i,j))
enddo
enddo
call plot_digital_shift_map(nx,ny,smap,dx,dy,max_peak,digital_map_plot)
min_peak=max(max_peak-initial_dig_depth,1) ! initial starting assumption that single pass through is sufficient to locate maximum group with more than n_dither pointings
ng_max_ok=min_numb_groups+1 ! initial starting assumption that single pass through is sufficient to locate maximum group with more than n_dither pointings
n_pass=0
!-----------------------------------------------------------------------------------
1111 n_pass=n_pass+1 ! Entry point for additional deeper passes through digital shift array
!-----------------------------------------------------------------------------------
if (ng_max_ok.le.min_numb_groups) then
write(*,*)
write(*,'(a,i0,a)') ' Pass ',n_pass,' through convolved shift array initiated'
endif
print *
write(*,'(a,I0)') ' Maximum peak in convolved shift array: ',max_peak
if (ng_max_ok.le.min_numb_groups) min_peak=max(min_peak-1,1) !dig one unit deeper on each additional pass
write(*,'(a,I0)') ' Minimum amplitude peaks to be explored: ',min_peak
! determine number of digital peaks worth fine-tuning
n_peaks=0
do i=-nx,nx
do j=-ny,ny
if (smap(i,j).lt.min_peak) cycle
n_peaks=n_peaks+1
enddo
enddo
write(*,'(a,I0)') ' Total number of digital peaks to be fine-tuned: ',n_peaks
! allocate pointing save lists
allocate (ra_p(n_peaks),dec_p(n_peaks),pa_v3_p(n_peaks),n_targs_p(n_peaks),ids_p(n_peaks,2*max_peak),id_list(2*max_peak))
ids_p(:,:)=0
! fill out starting point digital peak-derived pointing save lists
ii=0
do jj=max_peak,min_peak,-1
do i=-nx,nx
do j=-ny,ny
if (smap(i,j).ne.jj) cycle
ii=ii+1
! get digitized shift vector of pixel i,j and calculate approximate ra,dec of peak
dist_x=float(i)*dx/1000. !xm,ym
dist_y=float(j)*dy/1000.
ax= dist_x*cos(-phi_r)+dist_y*sin(-phi_r) !V2,V3 as orientation
ay=-dist_x*sin(-phi_r)+dist_y*cos(-phi_r)
call roll_v3(apa_v3,ax,ay,aax,aay) !ra,dec arcsec orientation
aax=-aax
aay=-aay
call coordtang_single(cra,cdec,aax,aay,ra_p(ii),dec_p(ii))
n_targs_p(ii)=smap(i,j)
! attach individual roll to pointing
call get_mpt_roll_offset(ra_p(ii),dec_p(ii),roll_corr)
pa_v3_p(ii)=cpa_v3+roll_corr
enddo !j
enddo !i
enddo !jj
! ------- Convert in place to fine-tune extracted list of Digital Peaks ---------------
print *
max_targs=-666
ii=0
do ip=1,n_peaks
call fine_tune_pointing_roll(ra_p(ip),dec_p(ip),pa_v3_p(ip),n_targs_p(ip),id_list,max_peak)
do j=1,n_targs_p(ip)
ids_p(ip,j)=id_list(j)
enddo
ii=ii+1
max_targs=max(max_targs,n_targs_p(ip))
enddo !ip n_peaks
write(*,'(a,i0,a,i0,a)') ' ',ii,' peaks out of ',n_peaks,' processed'
write(*,*)
write(*,'(a,i0)') ' Maximum simultaneous Priority 1 Target Coverage: ',max_targs
! ------- Fine-tuning of list of Digital Peaks completed ----
if (group_output) then
! if (ng_max_ok.gt.min_numb_groups) min_targs=max_targs !initial starting point
! if (ng_max_ok.le.min_numb_groups) min_targs=max(min_targs-1,1) !go one step deeper on every subsequent pass
if (ng_max_ok.gt.min_numb_groups) then
min_targs=max_targs !initial starting point
else
min_targs=max(min_targs-1,1) !go one step deeper on every subsequent pass
endif
else
min_targs=max(max_targs-min_keep_depth,1)
endif !group_output
write(*,*)
write(*,'(a,i0,a,i0,a)') ' Pointings providing simultaneous coverage from ',max_targs,' and down to ',min_targs,' targets will be saved'
print *
print *, 'Eliminating low-coverage and duplicate pointings from fine-tuned list (patience please)'
dlim_x=1.0*av_xopen/1000. !as
dlim_y=1.0*av_yopen/1000.
! ss=sin(phi_r-cpa_v3/57.2957795)
! cc=cos(phi_r-cpa_v3/57.2957795)
do i=1,n_peaks
! only care about peaks above min_targs, set n_targs_p(i)=0 if below min_targs
if (n_targs_p(i).lt.min_targs) then
n_targs_p(i)=0
cycle
endif
do j=1,i-1 ! all previously examined pointings before i
if (n_targs_p(j).lt.min_targs) cycle
call tangcoord_single(ra_p(j),dec_p(j),ra_p(i),dec_p(i),dra,ddec) !ra,dec
! Rotate to MSA coordinate system orientation
ss=sin(phi_r-pa_v3_p(i)/57.2957795)
cc=cos(phi_r-pa_v3_p(i)/57.2957795)
dax= dra*cc+ddec*ss
day=-dra*ss+ddec*cc
if ((abs(dax).gt.dlim_x).or.(abs(day).gt.dlim_y)) cycle !pointing j not spatially coincident with pointing i -> next j
! Pointings i and j coincide spatially, does j cover a greater or equal number of targets than trial pointing i? -> if yes, pointing i uninteresting, next j
if (n_targs_p(j).ge.n_targs_p(i)) then
n_targs_p(i)=0
cycle
endif
! Pointings i and j coincide spatially, and trial pointing i has higher coverage than
! previous pointing j at same location -> swap pointing i with j. New trial pointing i now uninteresting
ra_tmp=ra_p(j)
dec_tmp=dec_p(j)
pa_v3_tmp=pa_v3_p(j)
ra_p(j)=ra_p(i)
dec_p(j)=dec_p(i)
pa_v3_p(j)=pa_v3_p(i)
n_targs_p(j)=n_targs_p(i)
do ii=1,n_targs_p(i)
ids_p(j,ii)=ids_p(i,ii)
enddo
ra_p(i)=ra_tmp
dec_p(i)=dec_tmp
pa_v3_p(i)=pa_v3_tmp
n_targs_p(i)=0
enddo !j
enddo !i
! count number of unique non-zero fine-tined peaks of interest
np_min_targs=0 ! number of pointings having at least min_targs coverage
do ip=1,n_peaks
if (n_targs_p(ip).ge.min_targs) np_min_targs=np_min_targs+1
enddo
n_p=np_min_targs ! new final number of saved fine-tuned pointings
write(*,*)
write(*,'(a,i0,a,i0)') ' Final number of identified ',min_targs,' or greater target coverage pointings: ',np_min_targs
! purge final pointing list of uninteresting nulled pointings and compact list
! allocate temporary storage
allocate (ra_f(n_p),dec_f(n_p),pa_v3_f(n_p),n_targs_f(n_p),ids_f(n_p,max_targs))
ii=0
do peak_val=max_targs,min_targs,-1
do ip=1,n_peaks
if (n_targs_p(ip).eq.peak_val) then
ii=ii+1
ra_f(ii)=ra_p(ip)
dec_f(ii)=dec_p(ip)
pa_v3_f(ii)=pa_v3_p(ip)
n_targs_f(ii)=n_targs_p(ip)
do j=1,n_targs_p(ip)
ids_f(ii,j)=ids_p(ip,j)
enddo
endif
enddo !ip
enddo !peak_val
deallocate (ra_p,dec_p,pa_v3_p,n_targs_p,ids_p)
allocate (ra_p(n_p),dec_p(n_p),pa_v3_p(n_p),pa_ap_p(n_p),n_targs_p(n_p),ids_p(n_p,max_targs))
ra_p=ra_f
dec_p=dec_f
pa_v3_p=pa_v3_f
n_targs_p=n_targs_f
ids_p=ids_f
deallocate (ra_f,dec_f,pa_v3_f,n_targs_f,ids_f)
! fill in pa_ap_p array
do ip=1,n_p
pa_ap_p(ip)=pa_v3_p(ip)+(180.-phi)
if (pa_ap_p(ip).gt.360.) pa_ap_p(ip)=pa_ap_p(ip)-360.
if (pa_ap_p(ip).lt.0.) pa_ap_p(ip)=pa_ap_p(ip)+360.
enddo
! write(*,*)
! do ip=1,n_p
! write(*,*) ra_p(ip),dec_p(ip),n_targs_p(ip),(ids_p(ip,j),j=1,n_targs_p(ip))
! enddo
10001 continue ! re-entry jump point for special n_reach=1 case
! group final pointings by targets covered
if (group_output) then
write(*,*)
write(*,*) 'Grouping optimal pointings per targets covered'
write(*,*)
call group_pointings()
do i=1,n_groups
write(*,'(a,i0,a,i0,a,i0,a,i0,a)') ' Pass ',n_pass,' - Group ',i,' covers ',gr_tcount(gr_indx(i)),' targets simultaneously in ',gr_pcount(gr_indx(i)),' pointings'
do j=1,n_groups
if (gr_subs(gr_indx(i),gr_indx(j)).ne.0) write(*,'(a,i0,a,i0,a,i0,a)') ' Group ',i,' is a subset of group ',j,', adding a further ',gr_pcount(gr_indx(j)),' pointings'
enddo
if (gr_ptcount(gr_indx(i)).gt.gr_pcount(gr_indx(i))) write(*,'(a,i0,a,i0,a)') ' The targets of group ',i,' are covered in a total of ',gr_ptcount(gr_indx(i)),' pointings'
write(*,'(a)') ' ID_cat'
do j=1,n_targs_p(gr_targs(gr_indx(i)))
write(*,*) ids_p(gr_targs(gr_indx(i)),j)
enddo !j
write(*,*)
enddo !i
! determine from scratch whether there is a sufficient number of groups containing a sufficient number of pointings
! exceeding the specified value of n_dither
max_ok_gr_targs=-9999
min_ok_gr_targs=9999
do i=1,n_groups
if (gr_ptcount(gr_indx(i)).ge.min_pointings_in_group) then
max_ok_gr_targs=max(max_ok_gr_targs,gr_tcount(gr_indx(i)))
min_ok_gr_targs=min(min_ok_gr_targs,gr_tcount(gr_indx(i)))
endif
enddo
! check whether max_ok_gr_targs and min_ok_gr_targs differ by more than one and if so whether min_ok_gr_targs can be increased
if (max_ok_gr_targs-min_ok_gr_targs.ge.1) then
do j=max_ok_gr_targs-1,min_ok_gr_targs,-1
ng_min_ok=0
do i=1,n_groups
if (gr_tcount(gr_indx(i)).eq.j) ng_min_ok=ng_min_ok+1
enddo !i
if (ng_min_ok.gt.1) then
min_ok_gr_targs=j
exit
endif
enddo !j
endif
ng_min_ok=0
ng_max_ok=0
ng_all_ok=0
do i=1,n_groups
if (gr_ptcount(gr_indx(i)).ge.min_pointings_in_group) then
if (gr_tcount(gr_indx(i)).eq.max_ok_gr_targs) ng_max_ok=ng_max_ok+1
if (gr_tcount(gr_indx(i)).eq.min_ok_gr_targs) ng_min_ok=ng_min_ok+1
if (gr_tcount(gr_indx(i)).ge.min_ok_gr_targs) ng_all_ok=ng_all_ok+1
endif
enddo
if (min_ok_gr_targs.ge.max_ok_gr_targs) ng_min_ok=0 !To handle only max_ok_gr_targs situation
if (ng_all_ok.ge.min_numb_groups) then
write(*,*)
write(*,'(a,i0,a,i0,a,i0,a)') ' ',ng_max_ok,' groups covering ',max_ok_gr_targs,' targets at ',min_pointings_in_group,' or more pointings were found'
if (ng_min_ok.gt.0) write(*,'(a,i0,a,i0,a,i0,a)') ' ',ng_all_ok,' groups covering ',min_ok_gr_targs,' or more targets at ',min_pointings_in_group,' or more pointings were found'
endif
if (ng_all_ok.lt.min_numb_groups) then !loop back for deeper probe of digital peak map
deallocate (ra_p,dec_p,pa_v3_p,pa_ap_p,n_targs_p,ids_p,id_list)
deallocate (gr_flag,gr_targs,gr_pcount,gr_tcount,gr_indx,gr_inv,gr_subs,gr_ptcount)
write(*,*)
write(*,'(a,i0,a)') ' No group with at least ',min_pointings_in_group,' pointings was found'
if (min_targs.le.1) then
write(*,*)
write(*,'(a)') ' Error: All digital peaks in the shift vector plane have been fully explored '
write(*,'(a)') ' Algorithm cannot proceed further'
write(*,*)
stop
endif
goto 1111
endif
! we have identified at least min_numb_groups containing at least min_targets_in_group pointings covering the same group of targets and are good to go
! print out final pointing groups to file
call write_groups_to_file(group_pointing_file)
endif ! plot_output=.true.
! fill in pa_ap_p array
do ip=1,n_p
pa_ap_p(ip)=pa_v3_p(ip)+(180.-phi)
if (pa_ap_p(ip).gt.360.) pa_ap_p(ip)=pa_ap_p(ip)-360.
if (pa_ap_p(ip).lt.0.) pa_ap_p(ip)=pa_ap_p(ip)+360.
enddo
! plot final optimal pointings in shift plane
call plot_pointing_map(pointing_map_plot,nx,ny,dx,dy)
! plot full catalog on sky
call draw_cat_on_sky2(sky_plot)
! open configuration file
open(11,file=confname,status='old',access='sequential', form='formatted')
! Append peak IPA output summary and pointing coordinate list to configuration file
call find_marker(11,'#IP#')
write(11,'(a)') '#'
write(11,'(a)') '#'
write(11,'(a)') '#'
write(11,'(a)') '#'
write(11,'(a)') '#'
write(11,'(a)') '# ----- SECTION AUTOMATICALLY APPENDED BY THE IPA MODULE ----------'
write(11,'(a)') '#'
write(11,'(a,i0)') '# Total number of observable Priority Class 1 targets in range: ',n_reach
write(11,'(a)') '#'
write(11,'(a,i0)') '# Maximum number of Priority Class 1 targets observable simultaneously in a single pointing: ',max_targs
write(11,'(a)') '#'
if (n_dither.gt.1) then
write(11,'(a,i0,a,i0)') '# Maximum number of Priority Class 1 targets observable simultaneously in ',n_dither,' or more dithered pointings: ',max_ok_gr_targs
write(11,'(a)') '#'
endif
write(11,'(a)') '#'
write(11,'(a)') '# A detailed sorted list and map of all optimal pointings identified by the IPA module can be found in the directory:'
write(11,'(a)') '#'
write(11,'(a)') '# ./trial_'//rn(1:2)//'/ipa_output/'
write(11,'(a)') '#'
if (group_output) then
if (ng_all_ok.ge.min_numb_groups) then
write(11,'(a)') '#'
write(11,'(a,i0,a,i0,a,i0,a)') '# ',ng_max_ok,' groups covering ',max_ok_gr_targs,' targets at ',min_pointings_in_group,' or more pointings were found'
if (ng_min_ok.gt.0) write(11,'(a,i0,a,i0,a,i0,a)') '# ',ng_all_ok,' groups covering ',min_ok_gr_targs,' or more targets at ',min_pointings_in_group,' or more pointings were found'
write(11,'(a)') '#'
endif