[430] | 1 | !The Polymorphic Tracking Code |
---|
| 2 | !Copyright (C) Etienne Forest and CERN |
---|
| 3 | |
---|
| 4 | |
---|
| 5 | MODULE S_TRACKING |
---|
| 6 | USE S_FAMILY |
---|
| 7 | |
---|
| 8 | IMPLICIT NONE |
---|
| 9 | public |
---|
| 10 | logical(lp),TARGET :: ALWAYS_EXACT_PATCHING=.TRUE. |
---|
| 11 | ! type(fibre), pointer :: lost_fibre |
---|
| 12 | ! type(integration_node), pointer :: lost_node |
---|
| 13 | |
---|
| 14 | ! linked |
---|
| 15 | PRIVATE TRACK_LAYOUT_FLAG_R,TRACK_LAYOUT_FLAG_P |
---|
| 16 | ! PRIVATE FIND_ORBIT_LAYOUT,FIND_ORBIT_M_LAYOUT,FIND_ENV_LAYOUT, FIND_ORBIT_LAYOUT_noda |
---|
| 17 | PRIVATE TRACK_LAYOUT_FLAG_R1,TRACK_LAYOUT_FLAG_P1 |
---|
| 18 | PRIVATE MIS_FIBR,MIS_FIBP,PATCH_FIBR,PATCH_FIBP |
---|
| 19 | PRIVATE TRACK_FIBRE_R,TRACK_FIBRE_P |
---|
| 20 | PRIVATE TRACK_LAYOUT_FLAG_R1f,TRACK_LAYOUT_FLAG_P1f |
---|
| 21 | PRIVATE TRACK_LAYOUT_FLAG_Rf,TRACK_LAYOUT_FLAG_Pf |
---|
| 22 | private TRACK_fibre_based_R,TRACK_fibre_based_P |
---|
| 23 | ! old Sj_elements |
---|
| 24 | ! END old Sj_elements |
---|
| 25 | |
---|
| 26 | ! TYPE UPDATING |
---|
| 27 | ! logical(lp) UPDATE |
---|
| 28 | ! END TYPE UPDATING |
---|
| 29 | |
---|
| 30 | |
---|
| 31 | |
---|
| 32 | ! TYPE (UPDATING), PARAMETER :: COMPUTE= UPDATING(.TRUE.) |
---|
| 33 | LOGICAL :: COMPUTE = .FALSE. |
---|
| 34 | |
---|
| 35 | INTERFACE TRACK |
---|
| 36 | ! linked |
---|
| 37 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_R |
---|
| 38 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_P |
---|
| 39 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_R1 |
---|
| 40 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_P1 |
---|
| 41 | MODULE PROCEDURE TRACK_FIBRE_R |
---|
| 42 | MODULE PROCEDURE TRACK_FIBRE_P |
---|
| 43 | MODULE PROCEDURE TRACK_fibre_based_R |
---|
| 44 | MODULE PROCEDURE TRACK_fibre_based_P |
---|
| 45 | ! old Sj_elements |
---|
| 46 | ! END old Sj_elements |
---|
| 47 | END INTERFACE |
---|
| 48 | |
---|
| 49 | |
---|
| 50 | INTERFACE TRACK_FIBRE_SINGLE |
---|
| 51 | MODULE PROCEDURE TRACK_FIBRE_R |
---|
| 52 | MODULE PROCEDURE TRACK_FIBRE_P |
---|
| 53 | END INTERFACE |
---|
| 54 | |
---|
| 55 | INTERFACE TRACK_FLAG |
---|
| 56 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_R1f |
---|
| 57 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_P1f |
---|
| 58 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_Rf |
---|
| 59 | MODULE PROCEDURE TRACK_LAYOUT_FLAG_Pf |
---|
| 60 | END INTERFACE |
---|
| 61 | |
---|
| 62 | |
---|
| 63 | INTERFACE PATCH_FIB |
---|
| 64 | MODULE PROCEDURE PATCH_FIBR |
---|
| 65 | MODULE PROCEDURE PATCH_FIBP |
---|
| 66 | END INTERFACE |
---|
| 67 | |
---|
| 68 | INTERFACE MIS_FIB |
---|
| 69 | MODULE PROCEDURE MIS_FIBR |
---|
| 70 | MODULE PROCEDURE MIS_FIBP |
---|
| 71 | END INTERFACE |
---|
| 72 | |
---|
| 73 | |
---|
| 74 | contains |
---|
| 75 | ! old Sj_elements |
---|
| 76 | |
---|
| 77 | |
---|
| 78 | ! END old Sj_elements |
---|
| 79 | |
---|
| 80 | ! recursive |
---|
| 81 | integer function TRACK_LAYOUT_FLAG_R1f(R,X,II1,k,X_IN) |
---|
| 82 | implicit none |
---|
| 83 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 84 | real(dp), INTENT(INOUT):: X(6) |
---|
| 85 | TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 86 | TYPE(INTERNAL_STATE) K |
---|
| 87 | INTEGER, INTENT(IN):: II1 |
---|
| 88 | |
---|
| 89 | call track(R,X,II1,k,X_IN) |
---|
| 90 | call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_R1f) |
---|
| 91 | ! call RESET_APERTURE_FLAG(my_false) |
---|
| 92 | end function TRACK_LAYOUT_FLAG_R1f |
---|
| 93 | |
---|
| 94 | ! recursive |
---|
| 95 | integer function TRACK_LAYOUT_FLAG_P1f(R,X,II1,k) |
---|
| 96 | implicit none |
---|
| 97 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 98 | TYPE(REAL_8), INTENT(INOUT):: X(6) |
---|
| 99 | ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 100 | TYPE(INTERNAL_STATE) K |
---|
| 101 | INTEGER, INTENT(IN):: II1 |
---|
| 102 | |
---|
| 103 | call track(R,X,II1,k) |
---|
| 104 | call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_P1f) |
---|
| 105 | ! call RESET_APERTURE_FLAG(my_false) |
---|
| 106 | |
---|
| 107 | end function TRACK_LAYOUT_FLAG_P1f |
---|
| 108 | |
---|
| 109 | ! recursive |
---|
| 110 | SUBROUTINE TRACK_LAYOUT_FLAG_R1(R,X,II1,k,X_IN) ! Tracks real(dp) from II1 to the end or back to II1 if closed |
---|
| 111 | implicit none |
---|
| 112 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 113 | real(dp), INTENT(INOUT):: X(6) |
---|
| 114 | TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 115 | TYPE(INTERNAL_STATE) K |
---|
| 116 | INTEGER, INTENT(IN):: II1 |
---|
| 117 | INTEGER II2 |
---|
| 118 | |
---|
| 119 | ! CALL RESET_APERTURE_FLAG |
---|
| 120 | |
---|
| 121 | IF(R%CLOSED) THEN |
---|
| 122 | II2=II1+R%N |
---|
| 123 | ELSE |
---|
| 124 | II2=R%N+1 |
---|
| 125 | ENDIF |
---|
| 126 | |
---|
| 127 | CALL TRACK(R,X,II1,II2,k,X_IN) |
---|
| 128 | ! if(c_%watch_user) ALLOW_TRACKING=.FALSE. |
---|
| 129 | END SUBROUTINE TRACK_LAYOUT_FLAG_R1 |
---|
| 130 | |
---|
| 131 | ! recursive |
---|
| 132 | SUBROUTINE TRACK_LAYOUT_FLAG_P1(R,X,II1,k) ! Tracks polymorphs from II1 to the end or back to II1 if closed |
---|
| 133 | implicit none |
---|
| 134 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 135 | TYPE(REAL_8), INTENT(INOUT):: X(6) |
---|
| 136 | ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 137 | TYPE(INTERNAL_STATE) K |
---|
| 138 | INTEGER, INTENT(IN):: II1 |
---|
| 139 | INTEGER II2 |
---|
| 140 | |
---|
| 141 | ! CALL RESET_APERTURE_FLAG |
---|
| 142 | |
---|
| 143 | IF(R%CLOSED) THEN |
---|
| 144 | II2=II1+R%N |
---|
| 145 | ELSE |
---|
| 146 | II2=R%N+1 |
---|
| 147 | ENDIF |
---|
| 148 | |
---|
| 149 | CALL TRACK(R,X,II1,II2,k) |
---|
| 150 | ! if(c_%watch_user) ALLOW_TRACKING=.FALSE. |
---|
| 151 | |
---|
| 152 | END SUBROUTINE TRACK_LAYOUT_FLAG_P1 |
---|
| 153 | |
---|
| 154 | ! recursive |
---|
| 155 | integer function TRACK_LAYOUT_FLAG_Rf(R,X,I1,I2,k,X_IN) ! Tracks double from i1 to i2 in state k |
---|
| 156 | IMPLICIT NONE |
---|
| 157 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 158 | real(dp), INTENT(INOUT):: X(6) |
---|
| 159 | TYPE(INTERNAL_STATE) K |
---|
| 160 | TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 161 | INTEGER, INTENT(IN):: I1,I2 |
---|
| 162 | |
---|
| 163 | call track(R,X,I1,I2,k,X_IN) |
---|
| 164 | call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_Rf) |
---|
| 165 | |
---|
| 166 | end function TRACK_LAYOUT_FLAG_Rf |
---|
| 167 | |
---|
| 168 | ! recursive |
---|
| 169 | integer function TRACK_LAYOUT_FLAG_Pf(R,X,I1,I2,k) ! Tracks double from i1 to i2 in state k |
---|
| 170 | IMPLICIT NONE |
---|
| 171 | TYPE(LAYOUT),target,INTENT(INOUT):: R ; |
---|
| 172 | TYPE(REAL_8), INTENT(INOUT):: X(6); |
---|
| 173 | INTEGER, INTENT(IN):: I1,I2; TYPE(INTERNAL_STATE) K; |
---|
| 174 | ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 175 | |
---|
| 176 | call track(R,X,I1,I2,k) |
---|
| 177 | call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_Pf) |
---|
| 178 | |
---|
| 179 | end function TRACK_LAYOUT_FLAG_Pf |
---|
| 180 | |
---|
| 181 | |
---|
| 182 | |
---|
| 183 | |
---|
| 184 | SUBROUTINE TRACK_fibre_based_R(X,k,fibre1,fibre2) ! Tracks double from i1 to i2 in state k |
---|
| 185 | IMPLICIT NONE |
---|
| 186 | real(dp), INTENT(INOUT):: X(6) |
---|
| 187 | TYPE(INTERNAL_STATE) K |
---|
| 188 | TYPE (fibre), POINTER :: fibre1 |
---|
| 189 | TYPE (fibre), optional, POINTER :: fibre2 |
---|
| 190 | TYPE (fibre), POINTER :: C,c1,c2,last |
---|
| 191 | |
---|
| 192 | c1=>fibre1 |
---|
| 193 | if(present(fibre2)) then |
---|
| 194 | c2=>fibre2 |
---|
| 195 | nullify(last) |
---|
| 196 | else |
---|
| 197 | if(fibre1%parent_layout%closed) then |
---|
| 198 | last=>fibre1%previous |
---|
| 199 | c2=>last |
---|
| 200 | else |
---|
| 201 | last=>fibre1%parent_layout%end |
---|
| 202 | c2=>fibre1%parent_layout%end |
---|
| 203 | endif |
---|
| 204 | endif |
---|
| 205 | |
---|
| 206 | |
---|
| 207 | c=>c1 |
---|
| 208 | |
---|
| 209 | |
---|
| 210 | |
---|
| 211 | DO WHILE(.not.ASSOCIATED(C,c2)) |
---|
| 212 | |
---|
| 213 | CALL TRACK(C,X,K) |
---|
| 214 | if(.not.check_stable) exit |
---|
| 215 | |
---|
| 216 | C=>C%NEXT |
---|
| 217 | ENDDO |
---|
| 218 | |
---|
| 219 | if(associated(last).and.check_stable) then |
---|
| 220 | CALL TRACK(last,X,K) |
---|
| 221 | endif |
---|
| 222 | |
---|
| 223 | C_%STABLE_DA=.true. |
---|
| 224 | |
---|
| 225 | |
---|
| 226 | |
---|
| 227 | END SUBROUTINE TRACK_fibre_based_R |
---|
| 228 | |
---|
| 229 | |
---|
| 230 | SUBROUTINE TRACK_fibre_based_p(X,k,fibre1,fibre2) ! Tracks double from i1 to i2 in state k |
---|
| 231 | IMPLICIT NONE |
---|
| 232 | type(real_8), INTENT(INOUT):: X(6) |
---|
| 233 | TYPE(INTERNAL_STATE) K |
---|
| 234 | TYPE (fibre), POINTER :: fibre1 |
---|
| 235 | TYPE (fibre), optional, POINTER :: fibre2 |
---|
| 236 | TYPE (fibre), POINTER :: C,c1,c2,last |
---|
| 237 | |
---|
| 238 | c1=>fibre1 |
---|
| 239 | if(present(fibre2)) then |
---|
| 240 | c2=>fibre2 |
---|
| 241 | nullify(last) |
---|
| 242 | else |
---|
| 243 | if(fibre1%parent_layout%closed) then |
---|
| 244 | last=>fibre1%previous |
---|
| 245 | c2=>last |
---|
| 246 | else |
---|
| 247 | last=>fibre1%parent_layout%end |
---|
| 248 | c2=>fibre1%parent_layout%end |
---|
| 249 | endif |
---|
| 250 | endif |
---|
| 251 | |
---|
| 252 | |
---|
| 253 | c=>c1 |
---|
| 254 | |
---|
| 255 | |
---|
| 256 | |
---|
| 257 | DO WHILE(.not.ASSOCIATED(C,c2)) |
---|
| 258 | |
---|
| 259 | CALL TRACK(C,X,K) |
---|
| 260 | if(.not.check_stable) exit |
---|
| 261 | |
---|
| 262 | C=>C%NEXT |
---|
| 263 | ENDDO |
---|
| 264 | |
---|
| 265 | if(associated(last).and.check_stable) then |
---|
| 266 | CALL TRACK(last,X,K) |
---|
| 267 | endif |
---|
| 268 | |
---|
| 269 | C_%STABLE_DA=.true. |
---|
| 270 | |
---|
| 271 | |
---|
| 272 | END SUBROUTINE TRACK_fibre_based_p |
---|
| 273 | |
---|
| 274 | |
---|
| 275 | |
---|
| 276 | |
---|
| 277 | |
---|
| 278 | SUBROUTINE TRACK_LAYOUT_FLAG_R(R,X,I1,I2,k,X_IN) ! Tracks double from i1 to i2 in state k |
---|
| 279 | IMPLICIT NONE |
---|
| 280 | TYPE(layout),target,INTENT(INOUT):: R |
---|
| 281 | real(dp), INTENT(INOUT):: X(6) |
---|
| 282 | TYPE(INTERNAL_STATE) K |
---|
| 283 | TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 284 | INTEGER, INTENT(IN):: I1,I2 |
---|
| 285 | INTEGER J,i22 |
---|
| 286 | TYPE (fibre), POINTER :: C |
---|
| 287 | |
---|
| 288 | |
---|
| 289 | ! CALL RESET_APERTURE_FLAG |
---|
| 290 | |
---|
| 291 | |
---|
| 292 | |
---|
| 293 | call move_to(r,c,I1) |
---|
| 294 | |
---|
| 295 | if(i2>=i1) then |
---|
| 296 | i22=i2 |
---|
| 297 | else |
---|
| 298 | i22=r%n+i2 |
---|
| 299 | endif |
---|
| 300 | |
---|
| 301 | ! if(i2>i1) then |
---|
| 302 | J=I1 |
---|
| 303 | |
---|
| 304 | DO WHILE(J<I22.AND.ASSOCIATED(C)) |
---|
| 305 | CALL TRACK(C,X,K,X_IN=X_IN) !,C%CHARGE |
---|
| 306 | ! CALL TRACK(C,X,K,R%CHARGE,X_IN) |
---|
| 307 | |
---|
| 308 | if(.not.check_stable) exit |
---|
| 309 | |
---|
| 310 | C=>C%NEXT |
---|
| 311 | J=J+1 |
---|
| 312 | ENDDO |
---|
| 313 | |
---|
| 314 | C_%STABLE_DA=.true. |
---|
| 315 | |
---|
| 316 | ! else |
---|
| 317 | ! J=I1 |
---|
| 318 | ! |
---|
| 319 | ! DO WHILE(J>I2.AND.ASSOCIATED(C)) |
---|
| 320 | ! j_global=j |
---|
| 321 | ! |
---|
| 322 | ! c%dir=-c%dir |
---|
| 323 | ! CALL TRACK(C,X,K,R%CHARGE,X_IN) |
---|
| 324 | ! c%dir=-c%dir |
---|
| 325 | ! |
---|
| 326 | ! C=>C%previous |
---|
| 327 | ! J=J-1 |
---|
| 328 | ! ENDDO |
---|
| 329 | ! |
---|
| 330 | ! endif |
---|
| 331 | |
---|
| 332 | |
---|
| 333 | ! if(c_%watch_user) ALLOW_TRACKING=.FALSE. |
---|
| 334 | |
---|
| 335 | END SUBROUTINE TRACK_LAYOUT_FLAG_R |
---|
| 336 | |
---|
| 337 | |
---|
| 338 | |
---|
| 339 | ! recursive |
---|
| 340 | SUBROUTINE TRACK_LAYOUT_FLAG_P(R,X,I1,I2,K) ! TRACKS POLYMORPHS FROM I1 TO I2 IN STATE K |
---|
| 341 | IMPLICIT NONE |
---|
| 342 | TYPE(LAYOUT),target,INTENT(INOUT):: R ;TYPE(REAL_8), INTENT(INOUT):: X(6); |
---|
| 343 | INTEGER, INTENT(IN):: I1,I2; TYPE(INTERNAL_STATE) K; |
---|
| 344 | ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 345 | INTEGER J,I22 |
---|
| 346 | |
---|
| 347 | TYPE (FIBRE), POINTER :: C |
---|
| 348 | |
---|
| 349 | |
---|
| 350 | ! CALL RESET_APERTURE_FLAG |
---|
| 351 | |
---|
| 352 | call move_to(r,c,I1) |
---|
| 353 | |
---|
| 354 | if(i2>=i1) then |
---|
| 355 | i22=i2 |
---|
| 356 | else |
---|
| 357 | i22=r%n+i2 |
---|
| 358 | endif |
---|
| 359 | |
---|
| 360 | ! if(i2>i1) then |
---|
| 361 | J=I1 |
---|
| 362 | |
---|
| 363 | DO WHILE(J<I22.AND.ASSOCIATED(C)) |
---|
| 364 | CALL TRACK(C,X,K) !,C%CHARGE |
---|
| 365 | ! CALL TRACK(C,X,K,R%CHARGE) |
---|
| 366 | if(.not.check_stable) exit |
---|
| 367 | |
---|
| 368 | C=>C%NEXT |
---|
| 369 | J=J+1 |
---|
| 370 | ENDDO |
---|
| 371 | |
---|
| 372 | C_%STABLE_DA=.true. |
---|
| 373 | |
---|
| 374 | ! else |
---|
| 375 | ! J=I1 |
---|
| 376 | |
---|
| 377 | ! DO WHILE(J>I2.AND.ASSOCIATED(C)) |
---|
| 378 | ! j_global=j |
---|
| 379 | |
---|
| 380 | ! c%dir=-c%dir |
---|
| 381 | ! CALL TRACK(C,X,K,R%CHARGE,X_IN) |
---|
| 382 | ! c%dir=-c%dir |
---|
| 383 | |
---|
| 384 | ! C=>C%previous |
---|
| 385 | ! J=J-1 |
---|
| 386 | ! ENDDO |
---|
| 387 | |
---|
| 388 | ! endif |
---|
| 389 | |
---|
| 390 | ! if(c_%watch_user) ALLOW_TRACKING=.FALSE. |
---|
| 391 | |
---|
| 392 | ! PATCHES |
---|
| 393 | END SUBROUTINE TRACK_LAYOUT_FLAG_P |
---|
| 394 | |
---|
| 395 | ! recursive |
---|
| 396 | ! SUBROUTINE TRACK_FIBRE_R(C,X,K,CHARGE,X_IN) |
---|
| 397 | SUBROUTINE TRACK_FIBRE_R(C,X,K,X_IN) |
---|
| 398 | implicit none |
---|
| 399 | logical(lp) :: doneitt=.true. |
---|
| 400 | logical(lp) :: doneitf=.false. |
---|
| 401 | TYPE(FIBRE),TARGET,INTENT(INOUT):: C |
---|
| 402 | real(dp), INTENT(INOUT):: X(6) |
---|
| 403 | TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 404 | ! INTEGER,optional, target, INTENT(IN) :: CHARGE |
---|
| 405 | TYPE(INTERNAL_STATE), INTENT(IN) :: K |
---|
| 406 | logical(lp) ou,patch |
---|
| 407 | INTEGER(2) PATCHT,PATCHG,PATCHE |
---|
| 408 | TYPE (fibre), POINTER :: CN |
---|
| 409 | real(dp), POINTER :: P0,B0 |
---|
| 410 | REAL(DP) ENT(3,3), A(3) |
---|
| 411 | |
---|
| 412 | ! real(dp), POINTER :: BETA0,GAMMA0I,GAMBET,P0C,MASS0 |
---|
| 413 | !INTEGER, POINTER :: CHARGE |
---|
| 414 | |
---|
| 415 | |
---|
| 416 | IF(.NOT.CHECK_STABLE) then |
---|
| 417 | CALL RESET_APERTURE_FLAG |
---|
| 418 | endif |
---|
| 419 | ! C%MAG%P%p0c=>c%p0c |
---|
| 420 | C%MAG%P%beta0=>c%beta0 |
---|
| 421 | C%MAG%P%GAMMA0I=>c%GAMMA0I |
---|
| 422 | C%MAG%P%GAMBET=>c%GAMBET |
---|
| 423 | C%MAG%P%CHARGE=>c%CHARGE |
---|
| 424 | ! DIRECTIONAL VARIABLE |
---|
| 425 | C%MAG%P%DIR=>C%DIR |
---|
| 426 | ! if(present(charge)) then |
---|
| 427 | ! C%MAG%P%CHARGE=>CHARGE |
---|
| 428 | ! endif |
---|
| 429 | ! C%MAG=K |
---|
| 430 | |
---|
| 431 | ! if(c_%x_prime) then |
---|
| 432 | ! P0=>C%MAG%P%P0C |
---|
| 433 | ! B0=>C%MAG%P%BETA0 |
---|
| 434 | ! IF(C%MAG%P%exact)THEN |
---|
| 435 | ! IF(k%TIME)THEN |
---|
| 436 | ! xp=x(2)/root(one+two*X(5)/B0+X(5)**2-x(2)**2-x(4)**2) |
---|
| 437 | ! x(4)=x(4)/root(one+two*X(5)/B0+X(5)**2-x(2)**2-x(4)**2) |
---|
| 438 | ! x(2)=xp |
---|
| 439 | ! else |
---|
| 440 | ! xp=x(2)/root((one+x(5))**2-x(2)**2-x(4)**2) |
---|
| 441 | ! x(4)=x(4)/root((one+x(5))**2-x(2)**2-x(4)**2) |
---|
| 442 | ! x(2)=xp |
---|
| 443 | ! endif |
---|
| 444 | ! else |
---|
| 445 | ! IF(k%TIME)THEN |
---|
| 446 | ! x(2)=x(2)/root(one+two*X(5)/B0+X(5)**2) |
---|
| 447 | ! x(4)=x(4)/root(one+two*X(5)/B0+X(5)**2) |
---|
| 448 | ! else |
---|
| 449 | ! x(2)=x(2)/(one+x(5)) |
---|
| 450 | ! x(4)=x(4)/(one+x(5)) |
---|
| 451 | ! endif |
---|
| 452 | ! endif |
---|
| 453 | ! endif |
---|
| 454 | |
---|
| 455 | |
---|
| 456 | IF(PRESENT(X_IN)) then |
---|
| 457 | X_IN%F=>c ; X_IN%E%F=>C; X_IN%NST=>X_IN%E%NST; |
---|
| 458 | endif |
---|
| 459 | |
---|
| 460 | ! |
---|
| 461 | ! IF(.NOT.CHECK_STABLE) CHECK_STABLE=.TRUE. |
---|
| 462 | !FRONTAL PATCH |
---|
| 463 | ! IF(ASSOCIATED(C%PATCH)) THEN |
---|
| 464 | PATCHT=C%PATCH%TIME ;PATCHE=C%PATCH%ENERGY ;PATCHG=C%PATCH%PATCH; |
---|
| 465 | ! ELSE |
---|
| 466 | ! PATCHT=0 ; PATCHE=0 ;PATCHG=0; |
---|
| 467 | ! ENDIF |
---|
| 468 | IF(PRESENT(X_IN)) then |
---|
| 469 | CALL XMID(X_IN,X,-6) |
---|
| 470 | X_IN%POS(1)=X_IN%nst |
---|
| 471 | endif |
---|
| 472 | |
---|
| 473 | IF(PATCHE/=0.AND.PATCHE/=2) THEN |
---|
| 474 | NULLIFY(P0);NULLIFY(B0); |
---|
| 475 | CN=>C%PREVIOUS |
---|
| 476 | IF(ASSOCIATED(CN)) THEN ! ASSOCIATED |
---|
| 477 | ! IF(.NOT.CN%PATCH%ENERGY) THEN ! No need to patch IF PATCHED BEFORE |
---|
| 478 | IF(CN%PATCH%ENERGY==0) THEN ! No need to patch IF PATCHED BEFORE |
---|
| 479 | P0=>CN%MAG%P%P0C |
---|
| 480 | B0=>CN%BETA0 |
---|
| 481 | |
---|
| 482 | X(2)=X(2)*P0/C%MAG%P%P0C |
---|
| 483 | X(4)=X(4)*P0/C%MAG%P%P0C |
---|
| 484 | IF(k%TIME.or.recirculator_cheat)THEN |
---|
| 485 | X(5)=root(1.0_dp+2.0_dp*X(5)/B0+X(5)**2) !X(5) = 1+DP/P0C_OLD |
---|
| 486 | X(5)=X(5)*P0/C%MAG%P%P0C-1.0_dp !X(5) = DP/P0C_NEW |
---|
| 487 | X(5)=(2.0_dp*X(5)+X(5)**2)/(root(1.0_dp/C%MAG%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%MAG%P%BETA0) |
---|
| 488 | ELSE |
---|
| 489 | X(5)=(1.0_dp+X(5))*P0/C%MAG%P%P0C-1.0_dp |
---|
| 490 | ENDIF |
---|
| 491 | ENDIF ! No need to patch |
---|
| 492 | ENDIF ! ASSOCIATED |
---|
| 493 | |
---|
| 494 | ENDIF |
---|
| 495 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-5) |
---|
| 496 | |
---|
| 497 | ! The chart frame of reference is located here implicitely |
---|
| 498 | IF(PATCHG==1.or.PATCHG==3) THEN |
---|
| 499 | patch=ALWAYS_EXACT_PATCHING.or.C%MAG%P%EXACT |
---|
| 500 | CALL PATCH_FIB(C,X,k,PATCH,MY_TRUE) |
---|
| 501 | ENDIF |
---|
| 502 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-4) |
---|
| 503 | IF(PATCHT/=0.AND.PATCHT/=2.AND.(K%TOTALPATH==0)) THEN |
---|
| 504 | if(K%time) then |
---|
| 505 | X(6)=X(6)-C%PATCH%a_T/c%beta0 |
---|
| 506 | else |
---|
| 507 | X(6)=X(6)-C%PATCH%a_T |
---|
| 508 | endif |
---|
| 509 | ENDIF |
---|
| 510 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-3) |
---|
| 511 | |
---|
| 512 | CALL DTILTD(C%DIR,C%MAG%P%TILTD,1,X) |
---|
| 513 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-2) |
---|
| 514 | ! The magnet frame of reference is located here implicitely before misalignments |
---|
| 515 | |
---|
| 516 | ! CALL TRACK(C,X,EXACTMIS=K%EXACTMIS) |
---|
| 517 | IF(C%MAG%MIS) THEN |
---|
| 518 | ou = ALWAYS_EXACTMIS !K%EXACTMIS.or. |
---|
| 519 | CALL MIS_FIB(C,X,k,OU,DONEITT) |
---|
| 520 | ENDIF |
---|
| 521 | IF(PRESENT(X_IN)) then |
---|
| 522 | CALL XMID(X_IN,X,-1) |
---|
| 523 | X_IN%POS(2)=X_IN%nst |
---|
| 524 | endif |
---|
| 525 | |
---|
| 526 | CALL TRACK(C%MAG,X,K,X_IN) |
---|
| 527 | ! if(abs(x(1))+abs(x(3))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then ! new 2010 |
---|
| 528 | ! if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in TRACK_FIBRE_R" |
---|
| 529 | ! CHECK_STABLE=.false. |
---|
| 530 | ! else ! new 2010 |
---|
| 531 | |
---|
| 532 | IF(PRESENT(X_IN)) then |
---|
| 533 | CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 534 | X_IN%POS(3)=X_IN%nst |
---|
| 535 | endif |
---|
| 536 | |
---|
| 537 | IF(C%MAG%MIS) THEN |
---|
| 538 | CALL MIS_FIB(C,X,k,OU,DONEITF) |
---|
| 539 | ENDIF |
---|
| 540 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 541 | ! The magnet frame of reference is located here implicitely before misalignments |
---|
| 542 | CALL DTILTD(C%DIR,C%MAG%P%TILTD,2,X) |
---|
| 543 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 544 | |
---|
| 545 | IF(PATCHT/=0.AND.PATCHT/=1.AND.(K%TOTALPATH==0)) THEN |
---|
| 546 | if(K%time) then |
---|
| 547 | X(6)=X(6)-C%PATCH%b_T/c%beta0 |
---|
| 548 | else |
---|
| 549 | X(6)=X(6)-C%PATCH%b_T |
---|
| 550 | endif |
---|
| 551 | ENDIF |
---|
| 552 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 553 | |
---|
| 554 | IF(PATCHG==2.or.PATCHG==3) THEN |
---|
| 555 | patch=ALWAYS_EXACT_PATCHING.or.C%MAG%P%EXACT |
---|
| 556 | CALL PATCH_FIB(C,X,k,PATCH,MY_FALSE) |
---|
| 557 | ENDIF |
---|
| 558 | IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 559 | |
---|
| 560 | ! The CHART frame of reference is located here implicitely |
---|
| 561 | |
---|
| 562 | IF(PATCHE/=0.AND.PATCHE/=1) THEN |
---|
| 563 | NULLIFY(P0);NULLIFY(B0); |
---|
| 564 | CN=>C%NEXT |
---|
| 565 | IF(.NOT.ASSOCIATED(CN)) CN=>C |
---|
| 566 | P0=>CN%MAG%P%P0C |
---|
| 567 | B0=>CN%BETA0 |
---|
| 568 | X(2)=X(2)*C%MAG%P%P0C/P0 |
---|
| 569 | X(4)=X(4)*C%MAG%P%P0C/P0 |
---|
| 570 | IF(k%TIME.or.recirculator_cheat)THEN |
---|
| 571 | X(5)=root(1.0_dp+2.0_dp*X(5)/C%MAG%P%BETA0+X(5)**2) !X(5) = 1+DP/P0C_OLD |
---|
| 572 | X(5)=X(5)*C%MAG%P%P0C/P0-1.0_dp !X(5) = DP/P0C_NEW |
---|
| 573 | X(5)=(2.0_dp*X(5)+X(5)**2)/(root(1.0_dp/B0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/B0) |
---|
| 574 | ELSE |
---|
| 575 | X(5)=(1.0_dp+X(5))*C%MAG%P%P0C/P0-1.0_dp |
---|
| 576 | ENDIF |
---|
| 577 | ENDIF |
---|
| 578 | |
---|
| 579 | IF(PRESENT(X_IN)) then |
---|
| 580 | CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 581 | X_IN%POS(4)=X_IN%nst |
---|
| 582 | endif |
---|
| 583 | |
---|
| 584 | IF(PRESENT(X_IN)) THEN |
---|
| 585 | IF(X_IN%E%DO_SURVEY) THEN |
---|
| 586 | CALL G_FRAME(X_IN%E,ENT,A,-7) |
---|
| 587 | CALL SURVEY(C,ENT,A,E_IN=X_IN%E) |
---|
| 588 | ELSE |
---|
| 589 | CALL SURVEY_INNER_MAG(X_IN%E) |
---|
| 590 | ENDIF |
---|
| 591 | ENDIF |
---|
| 592 | |
---|
| 593 | ! endif ! new 2010 |
---|
| 594 | |
---|
| 595 | if(abs(x(1))+abs(x(3))>absolute_aperture) then !.or.(.not.CHECK_MADX_APERTURE)) then |
---|
| 596 | messageLOST="exceed absolute_aperture in TRACK_FIBRE_R" |
---|
| 597 | xlost=x |
---|
| 598 | CHECK_STABLE=.false. |
---|
| 599 | endif |
---|
| 600 | if(.not.check_stable ) lost_fibre=>c |
---|
| 601 | |
---|
| 602 | END SUBROUTINE TRACK_FIBRE_R |
---|
| 603 | |
---|
| 604 | ! recursive |
---|
| 605 | ! SUBROUTINE TRACK_FIBRE_P(C,X,K,CHARGE) |
---|
| 606 | SUBROUTINE TRACK_FIBRE_P(C,X,K) |
---|
| 607 | IMPLICIT NONE |
---|
| 608 | logical(lp) :: doneitt=.true. |
---|
| 609 | logical(lp) :: doneitf=.false. |
---|
| 610 | TYPE(FIBRE),TARGET,INTENT(INOUT):: C |
---|
| 611 | TYPE(REAL_8), INTENT(INOUT):: X(6) |
---|
| 612 | ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN |
---|
| 613 | ! INTEGER, optional,TARGET, INTENT(IN) :: CHARGE |
---|
| 614 | TYPE(INTERNAL_STATE), INTENT(IN) :: K |
---|
| 615 | logical(lp) OU,PATCH |
---|
| 616 | INTEGER(2) PATCHT,PATCHG,PATCHE |
---|
| 617 | TYPE (FIBRE), POINTER :: CN |
---|
| 618 | REAL(DP), POINTER :: P0,B0 |
---|
| 619 | |
---|
| 620 | IF(.NOT.CHECK_STABLE) then |
---|
| 621 | CALL RESET_APERTURE_FLAG |
---|
| 622 | endif |
---|
| 623 | ! C%MAGp%P%p0c=>c%p0c |
---|
| 624 | C%MAGp%P%beta0=>c%beta0 |
---|
| 625 | C%MAGp%P%GAMMA0I=>c%GAMMA0I |
---|
| 626 | C%MAGp%P%GAMBET=>c%GAMBET |
---|
| 627 | C%MAGp%P%CHARGE=>c%CHARGE |
---|
| 628 | C%MAGP%P%DIR=>C%DIR |
---|
| 629 | ! if(present(charge)) then |
---|
| 630 | ! C%MAGP%P%CHARGE=>CHARGE |
---|
| 631 | ! endif |
---|
| 632 | |
---|
| 633 | ! NEW STUFF WITH KIND=3: KNOB OF FPP IS SET TO TRUE IF NECESSARY |
---|
| 634 | IF(K%PARA_IN ) KNOB=.TRUE. |
---|
| 635 | PATCHT=C%PATCH%TIME ;PATCHE=C%PATCH%ENERGY ;PATCHG=C%PATCH%PATCH; |
---|
| 636 | IF(PATCHE/=0.AND.PATCHE/=2) THEN |
---|
| 637 | NULLIFY(P0);NULLIFY(B0); |
---|
| 638 | CN=>C%PREVIOUS |
---|
| 639 | IF(ASSOCIATED(CN)) THEN ! ASSOCIATED |
---|
| 640 | ! IF(.NOT.CN%PATCH%ENERGY) THEN ! NO NEED TO PATCH IF PATCHED BEFORE |
---|
| 641 | IF(CN%PATCH%ENERGY==0) THEN ! NO NEED TO PATCH IF PATCHED BEFORE |
---|
| 642 | P0=>CN%MAGP%P%P0C |
---|
| 643 | B0=>CN%BETA0 |
---|
| 644 | |
---|
| 645 | X(2)=X(2)*P0/C%MAGP%P%P0C |
---|
| 646 | X(4)=X(4)*P0/C%MAGP%P%P0C |
---|
| 647 | IF(k%TIME.or.recirculator_cheat)THEN |
---|
| 648 | X(5)=SQRT(1.0_dp+2.0_dp*X(5)/B0+X(5)**2) !X(5) = 1+DP/P0C_OLD |
---|
| 649 | X(5)=X(5)*P0/C%MAGP%P%P0C-1.0_dp !X(5) = DP/P0C_NEW |
---|
| 650 | X(5)=(2.0_dp*X(5)+X(5)**2)/(SQRT(1.0_dp/C%MAGP%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%MAGP%P%BETA0) |
---|
| 651 | ELSE |
---|
| 652 | X(5)=(1.0_dp+X(5))*P0/C%MAGP%P%P0C-1.0_dp |
---|
| 653 | ENDIF |
---|
| 654 | ENDIF ! NO NEED TO PATCH |
---|
| 655 | ENDIF ! ASSOCIATED |
---|
| 656 | |
---|
| 657 | ENDIF |
---|
| 658 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-5) |
---|
| 659 | |
---|
| 660 | |
---|
| 661 | ! POSITION PATCH |
---|
| 662 | IF(PATCHG==1.or.PATCHG==3) THEN |
---|
| 663 | patch=ALWAYS_EXACT_PATCHING.or.C%MAGP%P%EXACT |
---|
| 664 | CALL PATCH_FIB(C,X,k,PATCH,MY_TRUE) |
---|
| 665 | ENDIF |
---|
| 666 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-4) |
---|
| 667 | ! TIME PATCH |
---|
| 668 | IF(PATCHT/=0.AND.PATCHT/=2.AND.(K%TOTALPATH==0)) THEN |
---|
| 669 | if(K%time) then |
---|
| 670 | X(6)=X(6)-C%PATCH%a_T/c%beta0 |
---|
| 671 | else |
---|
| 672 | X(6)=X(6)-C%PATCH%a_T |
---|
| 673 | endif |
---|
| 674 | ENDIF |
---|
| 675 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-3) |
---|
| 676 | |
---|
| 677 | CALL DTILTD(C%DIR,C%MAGP%P%TILTD,1,X) |
---|
| 678 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-2) |
---|
| 679 | ! MISALIGNMENTS AT THE ENTRANCE |
---|
| 680 | IF(C%MAGP%MIS) THEN |
---|
| 681 | OU =ALWAYS_EXACTMIS ! K%EXACTMIS.OR. |
---|
| 682 | CALL MIS_FIB(C,X,k,OU,DONEITT) |
---|
| 683 | ENDIF |
---|
| 684 | |
---|
| 685 | CALL TRACK(C%MAGP,X,K) |
---|
| 686 | ! if(abs(x(1))+abs(x(3))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then ! new 2010 |
---|
| 687 | ! if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in TRACK_FIBRE_P" |
---|
| 688 | ! CHECK_STABLE=.false. |
---|
| 689 | ! else ! new 2010 |
---|
| 690 | |
---|
| 691 | |
---|
| 692 | |
---|
| 693 | ! MISALIGNMENTS AT THE EXIT |
---|
| 694 | IF(C%MAGP%MIS) THEN |
---|
| 695 | CALL MIS_FIB(C,X,k,OU,DONEITF) |
---|
| 696 | ENDIF |
---|
| 697 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 698 | |
---|
| 699 | CALL DTILTD(C%DIR,C%MAGP%P%TILTD,2,X) |
---|
| 700 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 701 | |
---|
| 702 | !EXIT PATCH |
---|
| 703 | ! TIME PATCH |
---|
| 704 | IF(PATCHT/=0.AND.PATCHT/=1.AND.(K%TOTALPATH==0)) THEN |
---|
| 705 | if(K%time) then |
---|
| 706 | X(6)=X(6)-C%PATCH%b_T/c%beta0 |
---|
| 707 | else |
---|
| 708 | X(6)=X(6)-C%PATCH%b_T |
---|
| 709 | endif |
---|
| 710 | ENDIF |
---|
| 711 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 712 | |
---|
| 713 | ! POSITION PATCH |
---|
| 714 | IF(PATCHG==2.or.PATCHG==3) THEN |
---|
| 715 | patch=ALWAYS_EXACT_PATCHING.or.C%MAGP%P%EXACT |
---|
| 716 | CALL PATCH_FIB(C,X,k,PATCH,MY_FALSE) |
---|
| 717 | ENDIF |
---|
| 718 | ! IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1) |
---|
| 719 | |
---|
| 720 | ! ENERGY PATCH |
---|
| 721 | IF(PATCHE/=0.AND.PATCHE/=1) THEN |
---|
| 722 | NULLIFY(P0);NULLIFY(B0); |
---|
| 723 | CN=>C%NEXT |
---|
| 724 | IF(.NOT.ASSOCIATED(CN)) CN=>C |
---|
| 725 | P0=>CN%MAGP%P%P0C |
---|
| 726 | B0=>CN%BETA0 |
---|
| 727 | X(2)=X(2)*C%MAGP%P%P0C/P0 |
---|
| 728 | X(4)=X(4)*C%MAGP%P%P0C/P0 |
---|
| 729 | IF(k%TIME.or.recirculator_cheat)THEN |
---|
| 730 | X(5)=SQRT(1.0_dp+2.0_dp*X(5)/C%MAGP%P%BETA0+X(5)**2) !X(5) = 1+DP/P0C_OLD |
---|
| 731 | X(5)=X(5)*C%MAGP%P%P0C/P0-1.0_dp !X(5) = DP/P0C_NEW |
---|
| 732 | X(5)=(2.0_dp*X(5)+X(5)**2)/(SQRT(1.0_dp/B0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/B0) |
---|
| 733 | ELSE |
---|
| 734 | X(5)=(1.0_dp+X(5))*C%MAGP%P%P0C/P0-1.0_dp |
---|
| 735 | ENDIF |
---|
| 736 | ENDIF |
---|
| 737 | ! endif ! new 2010 |
---|
| 738 | |
---|
| 739 | |
---|
| 740 | ! KNOB IS RETURNED TO THE PTC DEFAULT |
---|
| 741 | ! NEW STUFF WITH KIND=3 |
---|
| 742 | KNOB=ALWAYS_knobs |
---|
| 743 | ! END NEW STUFF WITH KIND=3 |
---|
| 744 | |
---|
| 745 | ! new 2010 |
---|
| 746 | if(abs(x(1))+abs(x(3))>absolute_aperture) then !.or.(.not.CHECK_MADX_APERTURE)) then |
---|
| 747 | messageLOST="exceed absolute_aperture in TRACK_FIBRE_P" |
---|
| 748 | xlost=x |
---|
| 749 | CHECK_STABLE=.false. |
---|
| 750 | endif |
---|
| 751 | if(.not.check_stable ) lost_fibre=>c |
---|
| 752 | |
---|
| 753 | END SUBROUTINE TRACK_FIBRE_P |
---|
| 754 | |
---|
| 755 | |
---|
| 756 | |
---|
| 757 | SUBROUTINE PATCH_FIBR(C,X,k,PATCH,ENTERING) |
---|
| 758 | implicit none |
---|
| 759 | ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES |
---|
| 760 | TYPE(FIBRE),INTENT(INOUT):: C |
---|
| 761 | real(dp), INTENT(INOUT):: X(6) |
---|
| 762 | logical(lp),INTENT(IN):: PATCH,ENTERING |
---|
| 763 | TYPE(INTERNAL_STATE) k !,OPTIONAL :: K |
---|
| 764 | |
---|
| 765 | IF(ENTERING) THEN |
---|
| 766 | X(3)=C%PATCH%A_X1*X(3);X(4)=C%PATCH%A_X1*X(4); |
---|
| 767 | CALL ROT_YZ(C%PATCH%A_ANG(1),X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 768 | CALL ROT_XZ(C%PATCH%A_ANG(2),X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 769 | CALL ROT_XY(C%PATCH%A_ANG(3),X) !,PATCH) |
---|
| 770 | CALL TRANS(C%PATCH%A_D,X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 771 | X(3)=C%PATCH%A_X2*X(3);X(4)=C%PATCH%A_X2*X(4); |
---|
| 772 | ELSE |
---|
| 773 | X(3)=C%PATCH%B_X1*X(3);X(4)=C%PATCH%B_X1*X(4); |
---|
| 774 | CALL ROT_YZ(C%PATCH%B_ANG(1),X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 775 | CALL ROT_XZ(C%PATCH%B_ANG(2),X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 776 | CALL ROT_XY(C%PATCH%B_ANG(3),X) !,PATCH) |
---|
| 777 | CALL TRANS(C%PATCH%B_D,X,C%MAG%P%BETA0,PATCH,k%TIME) |
---|
| 778 | X(3)=C%PATCH%B_X2*X(3);X(4)=C%PATCH%B_X2*X(4); |
---|
| 779 | ENDIF |
---|
| 780 | |
---|
| 781 | |
---|
| 782 | END SUBROUTINE PATCH_FIBR |
---|
| 783 | |
---|
| 784 | |
---|
| 785 | SUBROUTINE PATCH_FIBP(C,X,k,PATCH,ENTERING) |
---|
| 786 | implicit none |
---|
| 787 | ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES |
---|
| 788 | TYPE(FIBRE),INTENT(INOUT):: C |
---|
| 789 | TYPE(REAL_8), INTENT(INOUT):: X(6) |
---|
| 790 | logical(lp),INTENT(IN):: PATCH,ENTERING |
---|
| 791 | TYPE(INTERNAL_STATE) k !,OPTIONAL :: K |
---|
| 792 | |
---|
| 793 | IF(ENTERING) THEN |
---|
| 794 | X(3)=C%PATCH%A_X1*X(3);X(4)=C%PATCH%A_X1*X(4); |
---|
| 795 | CALL ROT_YZ(C%PATCH%A_ANG(1),X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 796 | CALL ROT_XZ(C%PATCH%A_ANG(2),X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 797 | CALL ROT_XY(C%PATCH%A_ANG(3),X) !,PATCH) |
---|
| 798 | CALL TRANS(C%PATCH%A_D,X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 799 | X(3)=C%PATCH%A_X2*X(3);X(4)=C%PATCH%A_X2*X(4); |
---|
| 800 | ELSE |
---|
| 801 | X(3)=C%PATCH%B_X1*X(3);X(4)=C%PATCH%B_X1*X(4); |
---|
| 802 | CALL ROT_YZ(C%PATCH%B_ANG(1),X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 803 | CALL ROT_XZ(C%PATCH%B_ANG(2),X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 804 | CALL ROT_XY(C%PATCH%B_ANG(3),X) !,PATCH) |
---|
| 805 | CALL TRANS(C%PATCH%B_D,X,C%MAGP%P%BETA0,PATCH,k%TIME) |
---|
| 806 | X(3)=C%PATCH%B_X2*X(3);X(4)=C%PATCH%B_X2*X(4); |
---|
| 807 | ENDIF |
---|
| 808 | |
---|
| 809 | |
---|
| 810 | END SUBROUTINE PATCH_FIBP |
---|
| 811 | |
---|
| 812 | ! Misalignment routines |
---|
| 813 | SUBROUTINE MIS_FIBR(C,X,k,OU,ENTERING) |
---|
| 814 | implicit none |
---|
| 815 | ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES |
---|
| 816 | TYPE(FIBRE),INTENT(INOUT):: C |
---|
| 817 | real(dp), INTENT(INOUT):: X(6) |
---|
| 818 | logical(lp),INTENT(IN):: OU,ENTERING |
---|
| 819 | TYPE(INTERNAL_STATE) k !,OPTIONAL :: K |
---|
| 820 | |
---|
| 821 | IF(ASSOCIATED(C%CHART)) THEN |
---|
| 822 | IF(C%DIR==1) THEN ! FORWARD PROPAGATION |
---|
| 823 | IF(ENTERING) THEN |
---|
| 824 | CALL ROT_YZ(C%CHART%ANG_IN(1),X,C%MAG%P%BETA0,OU,k%TIME) ! ROTATIONS |
---|
| 825 | CALL ROT_XZ(C%CHART%ANG_IN(2),X,C%MAG%P%BETA0,OU,k%TIME) |
---|
| 826 | CALL ROT_XY(C%CHART%ANG_IN(3),X) !,OU) |
---|
| 827 | CALL TRANS(C%CHART%D_IN,X,C%MAG%P%BETA0,OU,k%TIME) ! TRANSLATION |
---|
| 828 | ELSE |
---|
| 829 | CALL ROT_YZ(C%CHART%ANG_OUT(1),X,C%MAG%P%BETA0,OU,k%TIME) ! ROTATIONS |
---|
| 830 | CALL ROT_XZ(C%CHART%ANG_OUT(2),X,C%MAG%P%BETA0,OU,k%TIME) |
---|
| 831 | CALL ROT_XY(C%CHART%ANG_OUT(3),X) !,OU) |
---|
| 832 | CALL TRANS(C%CHART%D_OUT,X,C%MAG%P%BETA0,OU,k%TIME) ! TRANSLATION |
---|
| 833 | ENDIF |
---|
| 834 | ELSE |
---|
| 835 | IF(ENTERING) THEN ! BACKWARD PROPAGATION |
---|
| 836 | C%CHART%D_OUT(1)=-C%CHART%D_OUT(1) |
---|
| 837 | C%CHART%D_OUT(2)=-C%CHART%D_OUT(2) |
---|
| 838 | C%CHART%ANG_OUT(3)=-C%CHART%ANG_OUT(3) |
---|
| 839 | CALL TRANS(C%CHART%D_OUT,X,C%MAG%P%BETA0,OU,k%TIME) ! TRANSLATION |
---|
| 840 | CALL ROT_XY(C%CHART%ANG_OUT(3),X) !,OU) |
---|
| 841 | CALL ROT_XZ(C%CHART%ANG_OUT(2),X,C%MAG%P%BETA0,OU,k%TIME) |
---|
| 842 | CALL ROT_YZ(C%CHART%ANG_OUT(1),X,C%MAG%P%BETA0,OU,k%TIME) ! ROTATIONS |
---|
| 843 | C%CHART%D_OUT(1)=-C%CHART%D_OUT(1) |
---|
| 844 | C%CHART%D_OUT(2)=-C%CHART%D_OUT(2) |
---|
| 845 | C%CHART%ANG_OUT(3)=-C%CHART%ANG_OUT(3) |
---|
| 846 | ELSE |
---|
| 847 | C%CHART%D_IN(1)=-C%CHART%D_IN(1) |
---|
| 848 | C%CHART%D_IN(2)=-C%CHART%D_IN(2) |
---|
| 849 | C%CHART%ANG_IN(3)=-C%CHART%ANG_IN(3) |
---|
| 850 | CALL TRANS(C%CHART%D_IN,X,C%MAG%P%BETA0,OU,k%TIME) ! TRANSLATION |
---|
| 851 | CALL ROT_XY(C%CHART%ANG_IN(3),X) !,OU) |
---|
| 852 | CALL ROT_XZ(C%CHART%ANG_IN(2),X,C%MAG%P%BETA0,OU,k%TIME) |
---|
| 853 | CALL ROT_YZ(C%CHART%ANG_IN(1),X,C%MAG%P%BETA0,OU,k%TIME) ! ROTATIONS |
---|
| 854 | C%CHART%D_IN(1)=-C%CHART%D_IN(1) |
---|
| 855 | C%CHART%D_IN(2)=-C%CHART%D_IN(2) |
---|
| 856 | C%CHART%ANG_IN(3)=-C%CHART%ANG_IN(3) |
---|
| 857 | ENDIF |
---|
| 858 | ENDIF |
---|
| 859 | ENDIF |
---|
| 860 | END SUBROUTINE MIS_FIBR |
---|
| 861 | |
---|
| 862 | SUBROUTINE MIS_FIBP(C,X,k,OU,ENTERING) ! Misaligns polymorphic fibres in PTC order for forward and backward fibres |
---|
| 863 | implicit none |
---|
| 864 | TYPE(FIBRE),INTENT(INOUT):: C |
---|
| 865 | type(REAL_8), INTENT(INOUT):: X(6) |
---|
| 866 | logical(lp),INTENT(IN):: OU,ENTERING |
---|
| 867 | TYPE(INTERNAL_STATE) k !,OPTIONAL :: K |
---|
| 868 | |
---|
| 869 | IF(ASSOCIATED(C%CHART)) THEN |
---|
| 870 | IF(C%DIR==1) THEN |
---|
| 871 | IF(ENTERING) THEN |
---|
| 872 | CALL ROT_YZ(C%CHART%ang_in(1),X,C%MAGP%P%BETA0,OU,k%TIME) ! rotations |
---|
| 873 | CALL ROT_XZ(C%CHART%ang_in(2),X,C%MAGP%P%BETA0,OU,k%TIME) |
---|
| 874 | CALL ROT_XY(C%CHART%ang_in(3),X) !,OU) |
---|
| 875 | CALL TRANS(C%CHART%d_in,X,C%MAGP%P%BETA0,OU,k%TIME) !translation |
---|
| 876 | ELSE |
---|
| 877 | CALL ROT_YZ(C%CHART%ang_out(1),X,C%MAGP%P%BETA0,OU,k%TIME) ! rotations |
---|
| 878 | CALL ROT_XZ(C%CHART%ang_out(2),X,C%MAGP%P%BETA0,OU,k%TIME) |
---|
| 879 | CALL ROT_XY(C%CHART%ang_out(3),X) !,OU) |
---|
| 880 | CALL TRANS(C%CHART%d_out,X,C%MAGP%P%BETA0,OU,k%TIME) !translation |
---|
| 881 | ENDIF |
---|
| 882 | ELSE |
---|
| 883 | IF(ENTERING) THEN |
---|
| 884 | C%CHART%d_out(1)=-C%CHART%d_out(1) |
---|
| 885 | C%CHART%d_out(2)=-C%CHART%d_out(2) |
---|
| 886 | C%CHART%ang_out(3)=-C%CHART%ang_out(3) |
---|
| 887 | CALL TRANS(C%CHART%d_out,X,C%MAGP%P%BETA0,OU,k%TIME) !translation |
---|
| 888 | CALL ROT_XY(C%CHART%ang_out(3),X) !,OU) |
---|
| 889 | CALL ROT_XZ(C%CHART%ang_out(2),X,C%MAGP%P%BETA0,OU,k%TIME) |
---|
| 890 | CALL ROT_YZ(C%CHART%ang_out(1),X,C%MAGP%P%BETA0,OU,k%TIME) ! rotations |
---|
| 891 | C%CHART%d_out(1)=-C%CHART%d_out(1) |
---|
| 892 | C%CHART%d_out(2)=-C%CHART%d_out(2) |
---|
| 893 | C%CHART%ang_out(3)=-C%CHART%ang_out(3) |
---|
| 894 | ELSE |
---|
| 895 | C%CHART%d_in(1)=-C%CHART%d_in(1) |
---|
| 896 | C%CHART%d_in(2)=-C%CHART%d_in(2) |
---|
| 897 | C%CHART%ang_in(3)=-C%CHART%ang_in(3) |
---|
| 898 | CALL TRANS(C%CHART%d_in,X,C%MAGP%P%BETA0,OU,k%TIME) !translation |
---|
| 899 | CALL ROT_XY(C%CHART%ang_in(3),X) !,OU) |
---|
| 900 | CALL ROT_XZ(C%CHART%ang_in(2),X,C%MAGP%P%BETA0,OU,k%TIME) |
---|
| 901 | CALL ROT_YZ(C%CHART%ang_in(1),X,C%MAGP%P%BETA0,OU,k%TIME) ! rotations |
---|
| 902 | C%CHART%d_in(1)=-C%CHART%d_in(1) |
---|
| 903 | C%CHART%d_in(2)=-C%CHART%d_in(2) |
---|
| 904 | C%CHART%ang_in(3)=-C%CHART%ang_in(3) |
---|
| 905 | ENDIF |
---|
| 906 | ENDIF |
---|
| 907 | ENDIF |
---|
| 908 | END SUBROUTINE MIS_FIBP |
---|
| 909 | |
---|
| 910 | |
---|
| 911 | |
---|
| 912 | END MODULE S_TRACKING |
---|