Skip to content

Commit

Permalink
Merge pull request #1052 from ldeniau/clean-tspa-io
Browse files Browse the repository at this point in the history 
Cleanup TPSA I/O
  • Loading branch information
@tpersson
tpersson committed Jan 14, 2022
2 parents 47e44a9 + 673b716 commit 0ffd882
Show file tree
Hide file tree
Showing 10 changed files with 125 additions and 63 deletions.
2 changes: 1 addition & 1 deletion Makefile_test
View file
Expand Up @@ -108,7 +108,7 @@ test-dynap \
test-c6t-4 \
test-match-6 test-match-7 \
test-ptc-twiss-2 \
test-ptc-twiss-old6 test-ptc-twiss-old7 \
test-ptc-twiss-old7 \
test-touschek test-touschek-2 \
\
$(call onlx64,$(user-cases),)
Expand Down
13 changes: 7 additions & 6 deletions libs/ptc/src/Ci_tpsa.f90
View file
Expand Up @@ -18209,12 +18209,13 @@ subroutine c_normal(xyso3,n,dospin,no_used,rot,phase,nu_spin)
! but energy is constant. (Momentum compaction, phase slip etc.. falls from there)
! etienne

if(c_skip_gofix) then
a1=1
else
call c_gofix(m1,a1)
endif
m1=c_simil(a1,m1,-1)
if(c_skip_gofix) then
a1=1
else
call c_gofix(m1,a1)
endif

m1=c_simil(a1,m1,-1)

! Does the the diagonalisation into a rotation
call c_linear_a(m1,a2)
Expand Down
1 change: 1 addition & 0 deletions libs/ptc/src/a_scratch_size.f90
View file
Expand Up @@ -89,6 +89,7 @@ module precision_constants
! real(dp),parameter:: A_dt = -0.142987272e0_dp ! sateesh
! real(dp),parameter:: a_h3 =-4.183963e0_dp ! sateesh
logical(lp), public :: longprint = my_true
logical(lp), public :: madxprint = my_false

real(dp) :: A_particle=A_ELECTRON
real(dp),parameter::pmae=5.1099895000E-4_dp ! NIST CODATA 2018
Expand Down
67 changes: 43 additions & 24 deletions libs/ptc/src/c_dabnew.f90
View file
Expand Up @@ -4468,12 +4468,18 @@ subroutine dapri(ina,iunit)
ioa = 0
if(inva.eq.0) then
write(iunit,'(A)') ' I VALUE '
do i = ipoa,ipoa+illa-1
write(iunit,'(I6,2X,G20.13)') i-ipoa, cc(i)
enddo
if (madxprint) then
do i = ipoa,ipoa+illa-1
write(iunit,'(I6,2X,ES23.16)') i-ipoa, cc(i)
enddo
else
do i = ipoa,ipoa+illa-1
write(iunit,'(I6,2X,G20.13)') i-ipoa, cc(i)
enddo
endif
elseif(nomax.eq.1) then
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
do i=1,illa
do k=1,inva
j(k)=0
Expand All @@ -4483,12 +4489,16 @@ subroutine dapri(ina,iunit)
j(i-1)=1
ioa=1
endif
write(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
write(iunit,*) cc(ipoa+i-1)
if (madxprint) then
write(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
else
write(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') iout,cc(ipoa+i-1),ioa,(j(iii),iii=1,nvmax)
write(iunit,*) cc(ipoa+i-1)
endif
enddo
else
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
do ioa = 0,inoa
do ii=ipoa,ipoa+illa-1
if(ieo(ia1(i_1(ii))+ia2(i_2(ii))).ne.ioa) goto 100
Expand All @@ -4497,9 +4507,12 @@ subroutine dapri(ina,iunit)
if(abs(cc(ii)).gt.eps) then
!ETIENNE
iout = iout+1
write(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
!ETIENNE
write(iunit,*) cc(ii)
if (madxprint) then
write(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
else
write(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') iout,cc(ii),ioa,(j(iii),iii=1,nvmax)
write(iunit,*) cc(ii)
endif
endif
!ETIENNE
!
Expand Down Expand Up @@ -4549,16 +4562,18 @@ subroutine dapri77(ina,iunit)
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') daname(ina),', NO =',inoa,', NV =',inva,', INA =',ina,&
'*********************************************'
else
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') "Properties",', NO =',inoa,', NV =',inva,', INA =',ina,&
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') "Properties",', NO =',inoa,', NV =',inva,', INA =',ina,&
'*********************************************'
endif
endif
!
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS ZERO '
!
c10=' NO ='
k10=' NV ='
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
if (.not.madxprint) then
c10=' NO ='
k10=' NV ='
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
endif
iout = 0
!
! DO 100 IOA = 0,INOA
Expand Down Expand Up @@ -4606,9 +4621,9 @@ subroutine dapri77(ina,iunit)
j(i)=0
enddo
if(iout.eq.0) iout=1
if(longprint) write(iunit,502) -iout,zero,(j(i),i=1,inva)
if((.not.longprint).and.(.not.some)) write(iunit,*) 0," Real Polynomial is zero "
!if(.not.longprint) write(iunit,*) " "
if(longprint.and.(.not.madxprint)) write(iunit,502) -iout,zero,(j(i),i=1,inva)
if((.not.longprint).and.(.not.some)) write(iunit,*) 0," Real Polynomial is zero "
!if((.not.longprint).and.(.not.madxprint)) write(iunit,*) " "
!
return
end subroutine dapri77
Expand Down Expand Up @@ -4779,11 +4794,15 @@ subroutine darea(ina,iunit)
!
10 continue
iin = iin + 1
read(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') ii,c,io,(j(i),i=1,inva)
if (madxprint) then
read(iunit,'(I6,2X,ES23.16,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
else
read(iunit,'(I6,2X,G20.13,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
endif
!
if(ii.eq.0) goto 20
!ETIENNE
read(iunit,*) c
if(.not.madxprint) read(iunit,*) c
!ETIENNE
if(ii.ne.iin) then
iwarin = 1
Expand Down
68 changes: 39 additions & 29 deletions libs/ptc/src/cc_dabnew.f90
View file
Expand Up @@ -3958,11 +3958,11 @@ subroutine c_dapri(ina,iunit)
if(inva.eq.0) then
write(iunit,'(A)') ' I VALUE '
do i = ipoa,ipoa+illa-1
write(iunit,'(I6,2X,G20.13)') i-ipoa, c_clean_complex(c_cc(i))
write(iunit,'(I6,2X,ES23.16)') i-ipoa, c_clean_complex(c_cc(i))
enddo
elseif(c_nomax.eq.1) then
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
do i=1,illa
do k=1,inva
j(k)=0
Expand All @@ -3972,12 +3972,18 @@ subroutine c_dapri(ina,iunit)
j(i-1)=1
ioa=1
endif
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)
write(iunit,*) c_clean_complex(c_cc(ipoa+i-1))
if (madxprint) then
write(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') iout, &
c_clean_complex(c_cc(ipoa+i-1)),ioa,(j(iii),iii=1,c_nvmax)
else
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)
write(iunit,*) c_clean_complex(c_cc(ipoa+i-1))
endif
enddo
else
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
if(illa.ne.0) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
do ioa = 0,inoa
do ii=ipoa,ipoa+illa-1
if(c_ieo(c_ia1(c_i_1(ii))+c_ia2(c_i_2(ii))).ne.ioa) goto 100
Expand All @@ -3988,13 +3994,14 @@ subroutine c_dapri(ina,iunit)
if(abs(real(c_cc(ii)))> epsprint) a=c_cc(ii)
if(abs(aimag(c_cc(ii)))> epsprint) b=aimag(c_cc(ii))
ccc=a+(0.0_dp,1.0_dp)*b

!ETIENNE

iout = iout+1
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout,ccc,ioa,(j(iii),iii=1,c_nvmax)
!ETIENNE
write(iunit,*) c_cc(ii)
if (madxprint) then
write(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') iout, ccc,ioa,(j(iii),iii=1,c_nvmax)
else
write(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2i2,1X))') iout, ccc,ioa,(j(iii),iii=1,c_nvmax)
write(iunit,*) c_cc(ii)
endif
endif
!ETIENNE
!
Expand All @@ -4010,7 +4017,7 @@ subroutine c_dapri(ina,iunit)
end subroutine c_dapri

function c_clean_complex(c)
implicit none
implicit none
complex(dp) c_clean_complex,c
real(dp) cr,ci

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

end function c_clean_complex
end function c_clean_complex


subroutine c_dapri77(ina,iunit)
Expand Down Expand Up @@ -4060,7 +4067,6 @@ subroutine c_dapri77(ina,iunit)
ilma = c_idalm(ina)
illa = c_idall(ina)
!

if(longprint) then
write(iunit,'(/1X,A10,A6,I5,A6,I5,A7,I5/1X,A/)') c_daname(ina),', NO =',inoa,', NV =',inva,', INA =',ina,&
'*********************************************'
Expand All @@ -4069,12 +4075,14 @@ subroutine c_dapri77(ina,iunit)
'*********************************************'
endif
!
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
if(illa.ne.0.and.longprint) write(iunit,'(A)') ' I COEFFICIENT ORDER EXPONENTS'
if(illa.eq.0.and.longprint) write(iunit,'(A)') ' ALL COMPONENTS 0.0_dp '
!
c10=' NO ='
k10=' NV ='
if(longprint)write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
if (.not.madxprint) then
c10=' NO ='
k10=' NV ='
if(longprint) write(iunit,'(A10,I6,A10,I6)') c10,inoa,k10,inva
endif
iout = 0
!
! DO 100 IOA = 0,INOA
Expand All @@ -4094,7 +4102,7 @@ subroutine c_dapri77(ina,iunit)
if(abs(aimag(c_cc(ii)))> epsprint) then
b=aimag(c_cc(ii))
imprime=.true.
endif
endif
ccc=a+(0.0_dp,1.0_dp)*b
! ccc=c_cc(ii)
if(c_nomax.ne.1) then
Expand Down Expand Up @@ -4133,9 +4141,9 @@ subroutine c_dapri77(ina,iunit)
j(i)=0
enddo
if(iout.eq.0) iout=1
if(longprint) write(iunit,502) -iout,0.0_dp,0.0_dp,(j(i),i=1,inva)
if(longprint.and.(.not.madxprint)) write(iunit,502) -iout,0.0_dp,0.0_dp,(j(i),i=1,inva)
if((.not.longprint).and.(.not.some)) write(iunit,*) " Complex Polynomial is zero "
if(.not.longprint) write(6,*) " "
if((.not.longprint).and.(.not.madxprint)) write(6,*) " "
!
return
longprint=long
Expand Down Expand Up @@ -4263,7 +4271,7 @@ subroutine c_darea(ina,iunit)
integer,dimension(c_lnv)::j
complex(dp) c
character(10) c10

if((.not.C_STABLE_DA)) then
if(C_watch_user) then
write(6,*) "big problem in dabnew ", sqrt(crash)
Expand Down Expand Up @@ -4303,19 +4311,22 @@ subroutine c_darea(ina,iunit)
read(iunit,'(A10)') c10
read(iunit,'(A10)') c10
read(iunit,'(A10)') c10

!
!
iin = 0
!
10 continue
iin = iin + 1
! read(iunit,'(I6,2X,G20.13,I5,4X,18(2i2,1X))') ii,c,io,(j(i),i=1,inva)
read(iunit,*) ii,c,io,(j(i),i=1,inva)
if (madxprint) then
read(iunit,'(I6,2X,ES23.16,1x,ES23.16,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
else
read(iunit,'(I6,2X,G20.13,1x,G20.13,I5,4X,18(2I2,1X))') ii,c,io,(j(i),i=1,inva)
endif
!
if(ii.eq.0) goto 20
!ETIENNE
read(iunit,*) c
if (.not.madxprint) read(iunit,*) c
!ETIENNE
if(ii.ne.iin) then
iwarin = 1
Expand Down Expand Up @@ -4356,7 +4367,6 @@ subroutine c_darea(ina,iunit)
if(c_nomax.ne.1) call dapac(ina)
!
return

end subroutine c_darea
!FF
!
Expand Down
3 changes: 2 additions & 1 deletion src/mad_dict.c
View file
Expand Up @@ -755,7 +755,8 @@ const char *const_command_def =
" "
"ptc_setswitch: ptc_setswitch none 0 0 "
"debuglevel = [i,1], "/*sets the level of debugging printout 0 none, 4 everything */
"mapdump = [i, 0], " /*sets the level of map dump printout in all tracking codes 0: none, 1: order 0, 2: order 1 */
"mapdump = [i, 0], " /*ld: sets the level of map dump printout in all tracking codes 0: none, 1: order 0, 2: order 1 */
"madprint = [l, false, true], " /*ld: sets map dump printout format*/
"seed = [i, 123456789], "
"maxacceleration = [l, true, true], " /*switch saying to set cavities phases so the reference orbit is always on the crest, i.e. gains max energy*/
"exact_mis = [l, false, true], " /* switch to ensure exact misaligment treatment */
Expand Down
1 change: 1 addition & 0 deletions src/mad_extrn_f.h
View file
Expand Up @@ -336,6 +336,7 @@ void w_ptc_script_(F_INTEGER scriptname);
void w_ptc_setaccel_method_(F_INTEGER method);
void w_ptc_setdebuglevel_(F_INTEGER level);
void w_ptc_setmapdumplevel_(F_INTEGER level);
void w_ptc_setmadprint_(F_INTEGER level);
void w_ptc_setseed_(F_INTEGER level);
void w_ptc_setspin_(F_INTEGER method);
void w_ptc_setstochastic_(F_INTEGER method);
Expand Down
12 changes: 10 additions & 2 deletions src/mad_ptc.c
View file
Expand Up @@ -857,13 +857,21 @@ pro_ptc_setswitch(struct in_cmd* cmd)
}

/*MAPDUMP LEVEL*/
if ( name_list_pos("mapdump", nl) >=0 )
{
if ( name_list_pos("mapdump", nl) >=0 ) {
found = command_par_value2("mapdump", cmd->clone, &switchvalue);
// if (debuglevel > 0) printf("mapdump is found and its value is %f\n", switchvalue);
int mapdump = (int)switchvalue;
w_ptc_setmapdumplevel_(&mapdump);
}

/*MADPRINT TPSA FORMAT*/
if ( name_list_pos("madprint", nl) >=0 ) {
found = command_par_value2("madprint", cmd->clone, &switchvalue);
// if (debuglevel > 0) printf("madprint is found and its value is %f\n", switchvalue);
int madprint = (int)switchvalue;
w_ptc_setmadprint_(&madprint);
}

/*ACCELERATION SWITCH*/
found = command_par_value_user2("maxacceleration", cmd->clone, &switchvalue);
if (found)
Expand Down
14 changes: 14 additions & 0 deletions src/madx_ptc_intstate.f90
View file
Expand Up @@ -15,6 +15,7 @@ module madx_ptc_intstate_module
public :: setenforce6D
public :: ptc_setdebuglevel
public :: ptc_setmapdumplevel
public :: ptc_setmadprint
public :: ptc_setseed
public :: ptc_setaccel_method
public :: ptc_setexactmis
Expand Down Expand Up @@ -141,6 +142,19 @@ end subroutine ptc_setmapdumplevel
!____________________________________________________________________________________________


subroutine ptc_setmadprint(level)
use precision_constants, only : madxprint ! LD:13.01.2022
implicit none
integer :: level

if (level > 0) then
print *, "Setting madprint level to", level
end if
madxprint = level.ne.0

end subroutine ptc_setmadprint

!____________________________________________________________________________________________
subroutine ptc_setseed(seed)
USE gauss_dis
implicit none
Expand Down

0 comments on commit 0ffd882

Please sign in to comment.