Skip to content

Commit 0ffd882

Browse files
tperssontpersson
authored
Merge pull request #1052 from ldeniau/clean-tspa-io
Cleanup TPSA I/O
2 parents 47e44a9 + 673b716 commit 0ffd882

File tree

10 files changed

+125
-63
lines changed

10 files changed

+125
-63
lines changed

‎Makefile_test‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -108,7 +108,7 @@ test-dynap \
108108
test-c6t-4 \
109109
test-match-6 test-match-7 \
110110
test-ptc-twiss-2 \
111-
test-ptc-twiss-old6 test-ptc-twiss-old7 \
111+
test-ptc-twiss-old7 \
112112
test-touschek test-touschek-2 \
113113
\
114114
$(call onlx64,$(user-cases),)

‎libs/ptc/src/Ci_tpsa.f90‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -18209,12 +18209,13 @@ subroutine c_normal(xyso3,n,dospin,no_used,rot,phase,nu_spin)
1820918209
! but energy is constant. (Momentum compaction, phase slip etc.. falls from there)
1821018210
! etienne
1821118211

18212-
if(c_skip_gofix) then
18213-
a1=1
18214-
else
18215-
call c_gofix(m1,a1)
18216-
endif
18217-
m1=c_simil(a1,m1,-1)
18212+
if(c_skip_gofix) then
18213+
a1=1
18214+
else
18215+
call c_gofix(m1,a1)
18216+
endif
18217+
18218+
m1=c_simil(a1,m1,-1)
1821818219

1821918220
! Does the the diagonalisation into a rotation
1822018221
call c_linear_a(m1,a2)

‎libs/ptc/src/a_scratch_size.f90‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,7 @@ module precision_constants
8989
! real(dp),parameter:: A_dt = -0.142987272e0_dp ! sateesh
9090
! real(dp),parameter:: a_h3 =-4.183963e0_dp ! sateesh
9191
logical(lp), public :: longprint = my_true
92+
logical(lp), public :: madxprint = my_false
9293

9394
real(dp) :: A_particle=A_ELECTRON
9495
real(dp),parameter::pmae=5.1099895000E-4_dp ! NIST CODATA 2018

‎libs/ptc/src/c_dabnew.f90‎

Lines changed: 43 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -4468,12 +4468,18 @@ subroutine dapri(ina,iunit)
44684468
ioa = 0
44694469
if(inva.eq.0) then
44704470
write(iunit,'(A)') ' I VALUE '
4471-
do i = ipoa,ipoa+illa-1
4472-
write(iunit,'(I6,2X,G20.13)') i-ipoa, cc(i)
4473-
enddo
4471+
if (madxprint) then
4472+
do i = ipoa,ipoa+illa-1
4473+
write(iunit,'(I6,2X,ES23.16)') i-ipoa, cc(i)
4474+
enddo
4475+
else
4476+
do i = ipoa,ipoa+illa-1
4477+
write(iunit,'(I6,2X,G20.13)') i-ipoa, cc(i)
4478+
enddo
4479+
endif
44744480
elseif(nomax.eq.1) then
4475-
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4476-
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
4481+
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4482+
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
44774483
do i=1,illa
44784484
do k=1,inva
44794485
j(k)=0
@@ -4483,12 +4489,16 @@ subroutine dapri(ina,iunit)
44834489
j(i-1)=1
44844490
ioa=1
44854491
endif
4486-
write(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
4487-
write(iunit,*) cc(ipoa+i-1)
4492+
if (madxprint) then
4493+
write(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
4494+
else
4495+
write(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
4496+
write(iunit,*) cc(ipoa+i-1)
4497+
endif
44884498
enddo
44894499
else
4490-
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4491-
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
4500+
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4501+
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
44924502
do ioa = 0,inoa
44934503
do ii=ipoa,ipoa+illa-1
44944504
if(ieo(ia1(i_1(ii))+ia2(i_2(ii))).ne.ioa) goto 100
@@ -4497,9 +4507,12 @@ subroutine dapri(ina,iunit)
44974507
if(abs(cc(ii)).gt.eps) then
44984508
!ETIENNE
44994509
iout = iout+1
4500-
write(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
4501-
!ETIENNE
4502-
write(iunit,*) cc(ii)
4510+
if (madxprint) then
4511+
write(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
4512+
else
4513+
write(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
4514+
write(iunit,*) cc(ii)
4515+
endif
45034516
endif
45044517
!ETIENNE
45054518
!
@@ -4549,16 +4562,18 @@ subroutine dapri77(ina,iunit)
45494562
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') daname(ina),', NO =',inoa,', NV =',inva,', INA =',ina,&
45504563
'*********************************************'
45514564
else
4552-
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') "Properties",', NO =',inoa,', NV =',inva,', INA =',ina,&
4565+
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') "Properties",', NO =',inoa,', NV =',inva,', INA =',ina,&
45534566
'*********************************************'
4554-
endif
4567+
endif
45554568
!
4556-
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4557-
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
4569+
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4570+
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
45584571
!
4559-
c10=' NO ='
4560-
k10=' NV ='
4561-
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
4572+
if (.not.madxprint) then
4573+
c10=' NO ='
4574+
k10=' NV ='
4575+
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
4576+
endif
45624577
iout = 0
45634578
!
45644579
! DO 100 IOA = 0,INOA
@@ -4606,9 +4621,9 @@ subroutine dapri77(ina,iunit)
46064621
j(i)=0
46074622
enddo
46084623
if(iout.eq.0) iout=1
4609-
if(longprint) write(iunit,502) -iout,zero,(j(i),i=1,inva)
4610-
if((.not.longprint).and.(.not.some)) write(iunit,*) 0," Real Polynomial is zero "
4611-
!if(.not.longprint) write(iunit,*) " "
4624+
if(longprint.and.(.not.madxprint)) write(iunit,502) -iout,zero,(j(i),i=1,inva)
4625+
if((.not.longprint).and.(.not.some)) write(iunit,*) 0," Real Polynomial is zero "
4626+
!if((.not.longprint).and.(.not.madxprint)) write(iunit,*) " "
46124627
!
46134628
return
46144629
end subroutine dapri77
@@ -4779,11 +4794,15 @@ subroutine darea(ina,iunit)
47794794
!
47804795
10 continue
47814796
iin = iin + 1
4782-
read(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') ii,c,io,(j(i),i=1,inva)
4797+
if (madxprint) then
4798+
read(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
4799+
else
4800+
read(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
4801+
endif
47834802
!
47844803
if(ii.eq.0) goto 20
47854804
!ETIENNE
4786-
read(iunit,*) c
4805+
if(.not.madxprint) read(iunit,*) c
47874806
!ETIENNE
47884807
if(ii.ne.iin) then
47894808
iwarin = 1

‎libs/ptc/src/cc_dabnew.f90‎

Lines changed: 39 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -3958,11 +3958,11 @@ subroutine c_dapri(ina,iunit)
39583958
if(inva.eq.0) then
39593959
write(iunit,'(A)') ' I VALUE '
39603960
do i = ipoa,ipoa+illa-1
3961-
write(iunit,'(I6,2X,G20.13)') i-ipoa, c_clean_complex(c_cc(i))
3961+
write(iunit,'(I6,2X,ES23.16)') i-ipoa, c_clean_complex(c_cc(i))
39623962
enddo
39633963
elseif(c_nomax.eq.1) then
3964-
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
3965-
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
3964+
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
3965+
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
39663966
do i=1,illa
39673967
do k=1,inva
39683968
j(k)=0
@@ -3972,12 +3972,18 @@ subroutine c_dapri(ina,iunit)
39723972
j(i-1)=1
39733973
ioa=1
39743974
endif
3975-
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout,c_clean_complex(c_cc(ipoa+i-1)),ioa,(j(iii),iii=1,c_nvmax)
3976-
write(iunit,*) c_clean_complex(c_cc(ipoa+i-1))
3975+
if (madxprint) then
3976+
write(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') iout, &
3977+
c_clean_complex(c_cc(ipoa+i-1)),ioa,(j(iii),iii=1,c_nvmax)
3978+
else
3979+
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout, &
3980+
c_clean_complex(c_cc(ipoa+i-1)),ioa,(j(iii),iii=1,c_nvmax)
3981+
write(iunit,*) c_clean_complex(c_cc(ipoa+i-1))
3982+
endif
39773983
enddo
39783984
else
3979-
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
3980-
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
3985+
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
3986+
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
39813987
do ioa = 0,inoa
39823988
do ii=ipoa,ipoa+illa-1
39833989
if(c_ieo(c_ia1(c_i_1(ii))+c_ia2(c_i_2(ii))).ne.ioa) goto 100
@@ -3988,13 +3994,14 @@ subroutine c_dapri(ina,iunit)
39883994
if(abs(real(c_cc(ii)))> epsprint) a=c_cc(ii)
39893995
if(abs(aimag(c_cc(ii)))> epsprint) b=aimag(c_cc(ii))
39903996
ccc=a+(0.0_dp,1.0_dp)*b
3991-
39923997
!ETIENNE
3993-
39943998
iout = iout+1
3995-
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout,ccc,ioa,(j(iii),iii=1,c_nvmax)
3996-
!ETIENNE
3997-
write(iunit,*) c_cc(ii)
3999+
if (madxprint) then
4000+
write(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') iout, ccc,ioa,(j(iii),iii=1,c_nvmax)
4001+
else
4002+
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout, ccc,ioa,(j(iii),iii=1,c_nvmax)
4003+
write(iunit,*) c_cc(ii)
4004+
endif
39984005
endif
39994006
!ETIENNE
40004007
!
@@ -4010,7 +4017,7 @@ subroutine c_dapri(ina,iunit)
40104017
end subroutine c_dapri
40114018

40124019
function c_clean_complex(c)
4013-
implicit none
4020+
implicit none
40144021
complex(dp) c_clean_complex,c
40154022
real(dp) cr,ci
40164023

@@ -4020,7 +4027,7 @@ function c_clean_complex(c)
40204027
if(abs(ci)<epsprint) ci=0
40214028
c_clean_complex=cr+i_*ci
40224029

4023-
end function c_clean_complex
4030+
end function c_clean_complex
40244031

40254032

40264033
subroutine c_dapri77(ina,iunit)
@@ -4060,7 +4067,6 @@ subroutine c_dapri77(ina,iunit)
40604067
ilma = c_idalm(ina)
40614068
illa = c_idall(ina)
40624069
!
4063-
40644070
if(longprint) then
40654071
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') c_daname(ina),', NO =',inoa,', NV =',inva,', INA =',ina,&
40664072
'*********************************************'
@@ -4069,12 +4075,14 @@ subroutine c_dapri77(ina,iunit)
40694075
'*********************************************'
40704076
endif
40714077
!
4072-
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4073-
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
4078+
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
4079+
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
40744080
!
4075-
c10=' NO ='
4076-
k10=' NV ='
4077-
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
4081+
if (.not.madxprint) then
4082+
c10=' NO ='
4083+
k10=' NV ='
4084+
if(longprint) write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
4085+
endif
40784086
iout = 0
40794087
!
40804088
! DO 100 IOA = 0,INOA
@@ -4094,7 +4102,7 @@ subroutine c_dapri77(ina,iunit)
40944102
if(abs(aimag(c_cc(ii)))> epsprint) then
40954103
b=aimag(c_cc(ii))
40964104
imprime=.true.
4097-
endif
4105+
endif
40984106
ccc=a+(0.0_dp,1.0_dp)*b
40994107
! ccc=c_cc(ii)
41004108
if(c_nomax.ne.1) then
@@ -4133,9 +4141,9 @@ subroutine c_dapri77(ina,iunit)
41334141
j(i)=0
41344142
enddo
41354143
if(iout.eq.0) iout=1
4136-
if(longprint) write(iunit,502) -iout,0.0_dp,0.0_dp,(j(i),i=1,inva)
4144+
if(longprint.and.(.not.madxprint)) write(iunit,502) -iout,0.0_dp,0.0_dp,(j(i),i=1,inva)
41374145
if((.not.longprint).and.(.not.some)) write(iunit,*) " Complex Polynomial is zero "
4138-
if(.not.longprint) write(6,*) " "
4146+
if((.not.longprint).and.(.not.madxprint)) write(6,*) " "
41394147
!
41404148
return
41414149
longprint=long
@@ -4263,7 +4271,7 @@ subroutine c_darea(ina,iunit)
42634271
integer,dimension(c_lnv)::j
42644272
complex(dp) c
42654273
character(10) c10
4266-
4274+
42674275
if((.not.C_STABLE_DA)) then
42684276
if(C_watch_user) then
42694277
write(6,*) "big problem in dabnew ", sqrt(crash)
@@ -4303,19 +4311,22 @@ subroutine c_darea(ina,iunit)
43034311
read(iunit,'(A10)') c10
43044312
read(iunit,'(A10)') c10
43054313
read(iunit,'(A10)') c10
4306-
4314+
43074315
!
43084316
!
43094317
iin = 0
43104318
!
43114319
10 continue
43124320
iin = iin + 1
4313-
! read(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') ii,c,io,(j(i),i=1,inva)
4314-
read(iunit,*) ii,c,io,(j(i),i=1,inva)
4321+
if (madxprint) then
4322+
read(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
4323+
else
4324+
read(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
4325+
endif
43154326
!
43164327
if(ii.eq.0) goto 20
43174328
!ETIENNE
4318-
read(iunit,*) c
4329+
if (.not.madxprint) read(iunit,*) c
43194330
!ETIENNE
43204331
if(ii.ne.iin) then
43214332
iwarin = 1
@@ -4356,7 +4367,6 @@ subroutine c_darea(ina,iunit)
43564367
if(c_nomax.ne.1) call dapac(ina)
43574368
!
43584369
return
4359-
43604370
end subroutine c_darea
43614371
!FF
43624372
!

‎src/mad_dict.c‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -755,7 +755,8 @@ const char *const_command_def =
755755
" "
756756
"ptc_setswitch: ptc_setswitch none 0 0 "
757757
"debuglevel = [i,1], "/*sets the level of debugging printout 0 none, 4 everything */
758-
"mapdump = [i, 0], " /*sets the level of map dump printout in all tracking codes 0: none, 1: order 0, 2: order 1 */
758+
"mapdump = [i, 0], " /*ld: sets the level of map dump printout in all tracking codes 0: none, 1: order 0, 2: order 1 */
759+
"madprint = [l, false, true], " /*ld: sets map dump printout format*/
759760
"seed = [i, 123456789], "
760761
"maxacceleration = [l, true, true], " /*switch saying to set cavities phases so the reference orbit is always on the crest, i.e. gains max energy*/
761762
"exact_mis = [l, false, true], " /* switch to ensure exact misaligment treatment */

‎src/mad_extrn_f.h‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -336,6 +336,7 @@ void w_ptc_script_(F_INTEGER scriptname);
336336
void w_ptc_setaccel_method_(F_INTEGER method);
337337
void w_ptc_setdebuglevel_(F_INTEGER level);
338338
void w_ptc_setmapdumplevel_(F_INTEGER level);
339+
void w_ptc_setmadprint_(F_INTEGER level);
339340
void w_ptc_setseed_(F_INTEGER level);
340341
void w_ptc_setspin_(F_INTEGER method);
341342
void w_ptc_setstochastic_(F_INTEGER method);

‎src/mad_ptc.c‎

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -857,13 +857,21 @@ pro_ptc_setswitch(struct in_cmd* cmd)
857857
}
858858

859859
/*MAPDUMP LEVEL*/
860-
if ( name_list_pos("mapdump", nl) >=0 )
861-
{
860+
if ( name_list_pos("mapdump", nl) >=0 ) {
862861
found = command_par_value2("mapdump", cmd->clone, &switchvalue);
862+
// if (debuglevel > 0) printf("mapdump is found and its value is %f\n", switchvalue);
863863
int mapdump = (int)switchvalue;
864864
w_ptc_setmapdumplevel_(&mapdump);
865865
}
866866

867+
/*MADPRINT TPSA FORMAT*/
868+
if ( name_list_pos("madprint", nl) >=0 ) {
869+
found = command_par_value2("madprint", cmd->clone, &switchvalue);
870+
// if (debuglevel > 0) printf("madprint is found and its value is %f\n", switchvalue);
871+
int madprint = (int)switchvalue;
872+
w_ptc_setmadprint_(&madprint);
873+
}
874+
867875
/*ACCELERATION SWITCH*/
868876
found = command_par_value_user2("maxacceleration", cmd->clone, &switchvalue);
869877
if (found)

‎src/madx_ptc_intstate.f90‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module madx_ptc_intstate_module
1515
public :: setenforce6D
1616
public :: ptc_setdebuglevel
1717
public :: ptc_setmapdumplevel
18+
public :: ptc_setmadprint
1819
public :: ptc_setseed
1920
public :: ptc_setaccel_method
2021
public :: ptc_setexactmis
@@ -141,6 +142,19 @@ end subroutine ptc_setmapdumplevel
141142
!____________________________________________________________________________________________
142143

143144

145+
subroutine ptc_setmadprint(level)
146+
use precision_constants, only : madxprint ! LD:13.01.2022
147+
implicit none
148+
integer :: level
149+
150+
if (level > 0) then
151+
print *, "Setting madprint level to", level
152+
end if
153+
madxprint = level.ne.0
154+
155+
end subroutine ptc_setmadprint
156+
157+
!____________________________________________________________________________________________
144158
subroutine ptc_setseed(seed)
145159
USE gauss_dis
146160
implicit none

0 commit comments

Comments
 (0)